+2012-07-16 Thomas Quinot <quinot@adacore.com>
+
+ * freeze.adb (Check_Component_Storage_Order): Do not reject a
+ nested composite with different scalar storage order if it is
+ byte aligned.
+
+2012-07-16 Thomas Quinot <quinot@adacore.com>
+
+ * gnat_rm.texi: Update documentation for Scalar_Storage_Order.
+
+2012-07-16 Tristan Gingold <gingold@adacore.com>
+
+ * a-exexpr.adb (Propagate_Exception): Adjust call to
+ Exception_Traces procedures.
+ * a-exexpr-gcc.adb (Setup_Current_Excep): Now a
+ function that returns an access to the Ada occurrence.
+ (Propagate_GCC_Exception): Adjust calls.
+ * raise.h (struct Exception_Occurrence): Declare.
+ * a-exextr.adb: Remove useless pragma. (Notify_Handled_Exception,
+ Notify_Unhandled_Exception) (Unhandled_Exception_Terminate):
+ Add Excep parameter.
+ * a-except.adb (Notify_Handled_Exception,
+ Notify_Unhandled_Exception) (Unhandled_Exception_Terminate):
+ Add Excep parameter.
+ (Process_Raise_Exception): Adjust calls.
+ * a-except-2005.adb (Notify_Handled_Exception,
+ Notify_Unhandled_Exception) (Unhandled_Exception_Terminate): Add
+ Excep parameter.
+ (Raise_Exception): Calls Raise_Exception_Always.
+ * raise-gcc.c (__gnat_setup_current_excep,
+ __gnat_notify_handled_exception)
+ (__gnat_notify_unhandled_exception): Adjust declarations.
+ (PERSONALITY_FUNCTION): Adjust calls.
+ (__gnat_personality_seh0): Remove warning.
+
+2012-07-16 Javier Miranda <miranda@adacore.com>
+
+ * sem_eval.adb (Test_Expression_Is_Foldable): Adding documentation.
+ (Eval_Relational_Op): Adding documentation.
+
2012-07-16 Robert Dewar <dewar@adacore.com>
* freeze.adb, g-debpoo.adb, exp_ch3.adb: Minor reformatting.
-- exported to be usable by the Ada exception handling personality
-- routine when the GCC 3 mechanism is used.
- procedure Notify_Handled_Exception;
+ procedure Notify_Handled_Exception (Excep : EOA);
pragma Export
(C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
-- This routine is called for a handled occurrence is about to be
-- propagated.
- procedure Notify_Unhandled_Exception;
+ procedure Notify_Unhandled_Exception (Excep : EOA);
pragma Export
(C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
-- This routine is called when an unhandled occurrence is about to be
-- propagated.
- procedure Unhandled_Exception_Terminate;
+ procedure Unhandled_Exception_Terminate (Excep : EOA);
pragma No_Return (Unhandled_Exception_Terminate);
-- This procedure is called to terminate execution following an
-- unhandled exception. The exception information, including
-- Reraises the exception referenced by the Current_Excep field of
-- the TSD (all fields of this exception occurrence are set). Abort
-- is deferred before the reraise operation.
+ -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous
procedure Transfer_Occurrence
(Target : Exception_Occurrence_Access;
Source : Exception_Occurrence);
pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
- -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous
- -- to setup Target from Source as an exception to be propagated in the
- -- caller task. Target is expected to be a pointer to the fixed TSD
- -- occurrence for this task.
+ -- Called from s-tasren.adb:Local_Complete_RendezVous and
+ -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from
+ -- Source as an exception to be propagated in the caller task. Target is
+ -- expected to be a pointer to the fixed TSD occurrence for this task.
-----------------------------
-- Run-Time Check Routines --
Message : String := "")
is
EF : Exception_Id := E;
- X : constant EOA := Exception_Propagation.Allocate_Occurrence;
-
begin
-- Raise CE if E = Null_ID (AI-446)
-- Go ahead and raise appropriate exception
- Exception_Data.Set_Exception_Msg (X, EF, Message);
-
- if not ZCX_By_Default then
- Abort_Defer.all;
- end if;
-
- Complete_Occurrence (X);
- Exception_Propagation.Propagate_Exception (X);
+ Raise_Exception_Always (EF, Message);
end Raise_Exception;
----------------------------
-- exported to be usable by the Ada exception handling personality
-- routine when the GCC 3 mechanism is used.
- procedure Notify_Handled_Exception;
+ procedure Notify_Handled_Exception (Excep : EOA);
pragma Export
(C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
-- This routine is called for a handled occurrence is about to be
-- propagated.
- procedure Notify_Unhandled_Exception;
+ procedure Notify_Unhandled_Exception (Excep : EOA);
pragma Export
(C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
-- This routine is called when an unhandled occurrence is about to be
-- propagated.
- procedure Unhandled_Exception_Terminate;
+ procedure Unhandled_Exception_Terminate (Excep : EOA);
pragma No_Return (Unhandled_Exception_Terminate);
-- This procedure is called to terminate program execution following an
-- unhandled exception. The exception information, including traceback
if Jumpbuf_Ptr /= Null_Address then
if not Excep.Exception_Raised then
Excep.Exception_Raised := True;
- Exception_Traces.Notify_Handled_Exception;
+ Exception_Traces.Notify_Handled_Exception (Excep);
end if;
builtin_longjmp (Jumpbuf_Ptr, 1);
else
- Exception_Traces.Notify_Unhandled_Exception;
- Exception_Traces.Unhandled_Exception_Terminate;
+ Exception_Traces.Notify_Unhandled_Exception (Excep);
+ Exception_Traces.Unhandled_Exception_Terminate (Excep);
end if;
end Process_Raise_Exception;
-- Called to implement raise without exception, ie reraise. Called
-- directly from gigi.
- procedure Setup_Current_Excep
- (GCC_Exception : not null GCC_Exception_Access);
+ function Setup_Current_Excep
+ (GCC_Exception : not null GCC_Exception_Access)
+ return EOA;
pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
-- Write Get_Current_Excep.all from GCC_Exception
-- Setup_Current_Excep --
-------------------------
- procedure Setup_Current_Excep
+ function Setup_Current_Excep
(GCC_Exception : not null GCC_Exception_Access)
+ return EOA
is
Excep : constant EOA := Get_Current_Excep.all;
To_GNAT_GCC_Exception (GCC_Exception);
begin
Excep.all := GNAT_Occurrence.Occurrence;
+
+ return GNAT_Occurrence.Occurrence'Access;
end;
else
Excep.Exception_Raised := True;
Excep.Pid := Local_Partition_ID;
Excep.Num_Tracebacks := 0;
+
+ return Excep;
end if;
end Setup_Current_Excep;
procedure Propagate_GCC_Exception
(GCC_Exception : not null GCC_Exception_Access)
is
+ Excep : EOA;
begin
-- Perform a standard raise first. If a regular handler is found, it
-- will be entered after all the intermediate cleanups have run. If
-- the necessary steps to enable the debugger to gain control while the
-- stack is still intact.
- Setup_Current_Excep (GCC_Exception);
- Notify_Unhandled_Exception;
+ Excep := Setup_Current_Excep (GCC_Exception);
+ Notify_Unhandled_Exception (Excep);
-- Now, un a forced unwind to trigger cleanups. Control should not
-- resume there, if there are cleanups and in any cases as the
procedure Unhandled_Except_Handler
(GCC_Exception : not null GCC_Exception_Access)
is
+ Excep : EOA;
begin
- Setup_Current_Excep (GCC_Exception);
- Unhandled_Exception_Terminate;
+ Excep := Setup_Current_Excep (GCC_Exception);
+ Unhandled_Exception_Terminate (Excep);
end Unhandled_Except_Handler;
-------------
pragma No_Return (builtin_longjmp);
pragma Import (Intrinsic, builtin_longjmp, "__builtin_longjmp");
- procedure Propagate_Continue (Excep : EOA);
+ procedure Propagate_Continue (E : Exception_Id);
pragma No_Return (Propagate_Continue);
pragma Export (C, Propagate_Continue, "__gnat_raise_nodefer_with_msg");
-- A call to this procedure is inserted automatically by GIGI, in order
if Jumpbuf_Ptr /= Null_Address then
if not Excep.Exception_Raised then
Excep.Exception_Raised := True;
- Exception_Traces.Notify_Handled_Exception;
+ Exception_Traces.Notify_Handled_Exception (Excep);
end if;
builtin_longjmp (Jumpbuf_Ptr, 1);
else
- Exception_Traces.Notify_Unhandled_Exception;
- Exception_Traces.Unhandled_Exception_Terminate;
+ Exception_Traces.Notify_Unhandled_Exception (Excep);
+ Exception_Traces.Unhandled_Exception_Terminate (Excep);
end if;
end Propagate_Exception;
-- Propagate_Continue --
------------------------
- procedure Propagate_Continue (Excep : EOA) is
+ procedure Propagate_Continue (E : Exception_Id) is
+ pragma Unreferenced (E);
begin
- Propagate_Exception (Excep);
+ Propagate_Exception (Get_Current_Excep.all);
end Propagate_Continue;
end Exception_Propagation;
-- latter case because Notify_Handled_Exception may be called for an
-- actually unhandled occurrence in the Front-End-SJLJ case.
- --------------------------------
- -- Import Run-Time C Routines --
- --------------------------------
-
- -- The purpose of the following pragma Import is to ensure that we
- -- generate appropriate subprogram descriptors for all C routines in
- -- the standard GNAT library that can raise exceptions. This ensures
- -- that the exception propagation can properly find these routines
-
- pragma Propagate_Exceptions;
-
----------------------
-- Notify_Exception --
----------------------
-- Notify_Handled_Exception --
------------------------------
- procedure Notify_Handled_Exception is
+ procedure Notify_Handled_Exception (Excep : EOA) is
begin
- Notify_Exception (Get_Current_Excep.all, Is_Unhandled => False);
+ Notify_Exception (Excep, Is_Unhandled => False);
end Notify_Handled_Exception;
--------------------------------
-- Notify_Unhandled_Exception --
--------------------------------
- procedure Notify_Unhandled_Exception is
- Excep : constant EOA := Get_Current_Excep.all;
-
+ procedure Notify_Unhandled_Exception (Excep : EOA) is
begin
-- Check whether there is any termination handler to be executed for
-- the environment task, and execute it if needed. Here we handle both
-- Unhandled_Exception_Terminate --
-----------------------------------
- procedure Unhandled_Exception_Terminate is
- Excep : Exception_Occurrence;
+ procedure Unhandled_Exception_Terminate (Excep : EOA) is
+ Occ : Exception_Occurrence;
-- This occurrence will be used to display a message after finalization.
-- It is necessary to save a copy here, or else the designated value
-- could be overwritten if an exception is raised during finalization
-- that there is enough room on the stack however.
begin
- Save_Occurrence (Excep, Get_Current_Excep.all.all);
- Last_Chance_Handler (Excep);
+ Save_Occurrence (Occ, Excep.all);
+ Last_Chance_Handler (Occ);
end Unhandled_Exception_Terminate;
------------------------------------
Err_Node : Node_Id;
ADC : Node_Id;
+ Comp_Byte_Aligned : Boolean;
+ -- Set True for the record case, when Comp starts on a byte boundary
+ -- (in which case it is allowed to have different storage order).
+
begin
-- Record case
Comp_Type := Etype (Comp);
Comp_Def := Component_Definition (Parent (Comp));
+ Comp_Byte_Aligned := Present (Component_Clause (Comp))
+ and then Normalized_First_Bit (Comp) mod System_Storage_Unit = 0;
+
-- Array case
else
Comp_Type := Component_Type (Encl_Type);
Comp_Def := Component_Definition
(Type_Definition (Declaration_Node (Encl_Type)));
+
+ Comp_Byte_Aligned := False;
end if;
-- Note: the Reverse_Storage_Order flag is set on the base type, but
(First_Subtype (Comp_Type),
Attribute_Scalar_Storage_Order);
- if (Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type))
- and then
- (No (ADC) or else Reverse_Storage_Order (Encl_Type) /=
- Reverse_Storage_Order (Etype (Comp_Type)))
- then
- Error_Msg_N
- ("component type must have same scalar storage order as "
- & "enclosing composite", Err_Node);
+ if Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then
+ if No (ADC) then
+ Error_Msg_N ("nested composite must have explicit scalar "
+ & "storage order", Err_Node);
+
+ elsif (Reverse_Storage_Order (Encl_Type)
+ /=
+ Reverse_Storage_Order (Etype (Comp_Type)))
+ and then not Comp_Byte_Aligned
+ then
+ Error_Msg_N
+ ("type of non-byte-aligned component must have same scalar "
+ & "storage order as enclosing composite", Err_Node);
+ end if;
elsif Aliased_Present (Comp_Def) then
Error_Msg_N
@cindex Scalar storage order
@findex Scalar_Storage_Order
@noindent
-For every record subtype @var{S}, the representation attribute
+For every array or record type @var{S}, the representation attribute
@code{Scalar_Storage_Order} denotes the order in which storage elements
that make up scalar components are ordered within S. Other properties are
as for standard representation attribute @code{Bit_Order}, as defined by
then the type's @code{Bit_Order} shall be specified explicitly and set to
the same value.
+If a component of S has itself a record or array type, then it shall also
+have a @code{Scalar_Storage_Order} attribute definition clause. In addition,
+if the component does not start on a byte boundary, then the scalar storage
+order specified for S and for the nested component type shall be identical.
+
A confirming @code{Scalar_Storage_Order} attribute definition clause (i.e.
with a value equal to @code{System.Default_Bit_Order}) has no effect.
_Unwind_Reason_Code
__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *);
-extern void __gnat_setup_current_excep (_Unwind_Exception *);
+extern struct Exception_Occurrence *__gnat_setup_current_excep
+ (_Unwind_Exception *);
extern void __gnat_unhandled_except_handler (_Unwind_Exception *);
#include "dwarf2.h"
/* The following is defined from a-except.adb. Its purpose is to enable
automatic backtraces upon exception raise, as provided through the
GNAT.Traceback facilities. */
-extern void __gnat_notify_handled_exception (void);
-extern void __gnat_notify_unhandled_exception (void);
+extern void __gnat_notify_handled_exception (struct Exception_Occurrence *);
+extern void __gnat_notify_unhandled_exception (struct Exception_Occurrence *);
/* Below is the eh personality routine per se. We currently assume that only
GNU-Ada exceptions are met. */
}
else
{
+ struct Exception_Occurrence *excep;
+
/* Trigger the appropriate notification routines before the second
phase starts, which ensures the stack is still intact.
First, setup the Ada occurrence. */
- __gnat_setup_current_excep (uw_exception);
+ excep = __gnat_setup_current_excep (uw_exception);
if (action.kind == unhandler)
- __gnat_notify_unhandled_exception ();
+ __gnat_notify_unhandled_exception (excep);
else
- __gnat_notify_handled_exception ();
+ __gnat_notify_handled_exception (excep);
return _URC_HANDLER_FOUND;
}
CONTEXT context;
PRUNTIME_FUNCTION mf_func = NULL;
ULONG64 mf_imagebase;
- ULONG64 mf_rsp;
+ ULONG64 mf_rsp = 0;
/* Get the context. */
RtlCaptureContext (&context);
typedef struct Exception_Data *Exception_Id;
+struct Exception_Occurrence;
+
extern void _gnat_builtin_longjmp (void *, int);
extern void __gnat_unhandled_terminate (void);
extern void *__gnat_malloc (__SIZE_TYPE__);
-- e.g. in the two operand case below, for string comparison, the result
-- is not static even though the two operands are static. In such cases,
-- the caller must reset the Is_Static_Expression flag in N.
+ --
+ -- If Fold and Stat are both set to False then this routine performs also
+ -- the following extra actions:
+ --
+ -- * If either operand is Any_Type then propagate it to result to
+ -- prevent cascaded errors.
+ --
+ -- * If some operand raises constraint error, then replace the node N
+ -- with the raise constraint error node. This replacement inherits the
+ -- Is_Static_Expression flag from the operands.
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Typ : constant Entity_Id := Etype (Left);
Otype : Entity_Id := Empty;
Result : Boolean;
- Stat : Boolean;
- Fold : Boolean;
begin
-- One special case to deal with first. If we can tell that the result
end Length_Mismatch;
end if;
- -- Test for expression being foldable
-
- Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
-
- -- Only comparisons of scalars can give static results. In particular,
- -- comparisons of strings never yield a static result, even if both
- -- operands are static strings.
-
- if not Is_Scalar_Type (Typ) then
- Stat := False;
- Set_Is_Static_Expression (N, False);
- end if;
+ declare
+ Is_Static_Expression : Boolean;
+ Is_Foldable : Boolean;
+ pragma Unreferenced (Is_Foldable);
- -- For operators on universal numeric types called as functions with
- -- an explicit scope, determine appropriate specific numeric type, and
- -- diagnose possible ambiguity.
+ begin
+ -- Initialize the value of Is_Static_Expression. The value of
+ -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed
+ -- since, even when some operand is a variable, we can still perform
+ -- the static evaluation of the expression in some cases (for
+ -- example, for a variable of a subtype of Integer we statically
+ -- know that any value stored in such variable is smaller than
+ -- Integer'Last).
+
+ Test_Expression_Is_Foldable
+ (N, Left, Right, Is_Static_Expression, Is_Foldable);
+
+ -- Only comparisons of scalars can give static results. In
+ -- particular, comparisons of strings never yield a static
+ -- result, even if both operands are static strings.
+
+ if not Is_Scalar_Type (Typ) then
+ Is_Static_Expression := False;
+ Set_Is_Static_Expression (N, False);
+ end if;
- if Is_Universal_Numeric_Type (Etype (Left))
- and then
- Is_Universal_Numeric_Type (Etype (Right))
- then
- Otype := Find_Universal_Operator_Type (N);
- end if;
+ -- For operators on universal numeric types called as functions with
+ -- an explicit scope, determine appropriate specific numeric type,
+ -- and diagnose possible ambiguity.
- -- For static real type expressions, we cannot use Compile_Time_Compare
- -- since it worries about run-time results which are not exact.
+ if Is_Universal_Numeric_Type (Etype (Left))
+ and then
+ Is_Universal_Numeric_Type (Etype (Right))
+ then
+ Otype := Find_Universal_Operator_Type (N);
+ end if;
- if Stat and then Is_Real_Type (Typ) then
- declare
- Left_Real : constant Ureal := Expr_Value_R (Left);
- Right_Real : constant Ureal := Expr_Value_R (Right);
+ -- For static real type expressions, we cannot use
+ -- Compile_Time_Compare since it worries about run-time
+ -- results which are not exact.
- begin
- case Nkind (N) is
- when N_Op_Eq => Result := (Left_Real = Right_Real);
- when N_Op_Ne => Result := (Left_Real /= Right_Real);
- when N_Op_Lt => Result := (Left_Real < Right_Real);
- when N_Op_Le => Result := (Left_Real <= Right_Real);
- when N_Op_Gt => Result := (Left_Real > Right_Real);
- when N_Op_Ge => Result := (Left_Real >= Right_Real);
+ if Is_Static_Expression and then Is_Real_Type (Typ) then
+ declare
+ Left_Real : constant Ureal := Expr_Value_R (Left);
+ Right_Real : constant Ureal := Expr_Value_R (Right);
- when others =>
- raise Program_Error;
- end case;
+ begin
+ case Nkind (N) is
+ when N_Op_Eq => Result := (Left_Real = Right_Real);
+ when N_Op_Ne => Result := (Left_Real /= Right_Real);
+ when N_Op_Lt => Result := (Left_Real < Right_Real);
+ when N_Op_Le => Result := (Left_Real <= Right_Real);
+ when N_Op_Gt => Result := (Left_Real > Right_Real);
+ when N_Op_Ge => Result := (Left_Real >= Right_Real);
+
+ when others =>
+ raise Program_Error;
+ end case;
- Fold_Uint (N, Test (Result), True);
- end;
+ Fold_Uint (N, Test (Result), True);
+ end;
- -- For all other cases, we use Compile_Time_Compare to do the compare
+ -- For all other cases, we use Compile_Time_Compare to do the compare
- else
- declare
- CR : constant Compare_Result :=
- Compile_Time_Compare (Left, Right, Assume_Valid => False);
+ else
+ declare
+ CR : constant Compare_Result :=
+ Compile_Time_Compare
+ (Left, Right, Assume_Valid => False);
- begin
- if CR = Unknown then
- return;
- end if;
+ begin
+ if CR = Unknown then
+ return;
+ end if;
- case Nkind (N) is
- when N_Op_Eq =>
- if CR = EQ then
- Result := True;
- elsif CR = NE or else CR = GT or else CR = LT then
- Result := False;
- else
- return;
- end if;
+ case Nkind (N) is
+ when N_Op_Eq =>
+ if CR = EQ then
+ Result := True;
+ elsif CR = NE or else CR = GT or else CR = LT then
+ Result := False;
+ else
+ return;
+ end if;
- when N_Op_Ne =>
- if CR = NE or else CR = GT or else CR = LT then
- Result := True;
- elsif CR = EQ then
- Result := False;
- else
- return;
- end if;
+ when N_Op_Ne =>
+ if CR = NE or else CR = GT or else CR = LT then
+ Result := True;
+ elsif CR = EQ then
+ Result := False;
+ else
+ return;
+ end if;
- when N_Op_Lt =>
- if CR = LT then
- Result := True;
- elsif CR = EQ or else CR = GT or else CR = GE then
- Result := False;
- else
- return;
- end if;
+ when N_Op_Lt =>
+ if CR = LT then
+ Result := True;
+ elsif CR = EQ or else CR = GT or else CR = GE then
+ Result := False;
+ else
+ return;
+ end if;
- when N_Op_Le =>
- if CR = LT or else CR = EQ or else CR = LE then
- Result := True;
- elsif CR = GT then
- Result := False;
- else
- return;
- end if;
+ when N_Op_Le =>
+ if CR = LT or else CR = EQ or else CR = LE then
+ Result := True;
+ elsif CR = GT then
+ Result := False;
+ else
+ return;
+ end if;
- when N_Op_Gt =>
- if CR = GT then
- Result := True;
- elsif CR = EQ or else CR = LT or else CR = LE then
- Result := False;
- else
- return;
- end if;
+ when N_Op_Gt =>
+ if CR = GT then
+ Result := True;
+ elsif CR = EQ or else CR = LT or else CR = LE then
+ Result := False;
+ else
+ return;
+ end if;
- when N_Op_Ge =>
- if CR = GT or else CR = EQ or else CR = GE then
- Result := True;
- elsif CR = LT then
- Result := False;
- else
- return;
- end if;
+ when N_Op_Ge =>
+ if CR = GT or else CR = EQ or else CR = GE then
+ Result := True;
+ elsif CR = LT then
+ Result := False;
+ else
+ return;
+ end if;
- when others =>
- raise Program_Error;
- end case;
- end;
+ when others =>
+ raise Program_Error;
+ end case;
+ end;
- Fold_Uint (N, Test (Result), Stat);
- end if;
+ Fold_Uint (N, Test (Result), Is_Static_Expression);
+ end if;
+ end;
-- For the case of a folded relational operator on a specific numeric
-- type, freeze operand type now.
projects / platform / upstream / gcc.git / commitdiff