[multiple changes]
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. From-SVN: r189532
This commit is contained in:
Arnaud Charlet
parent
e187fa72fb
commit
5df1266a05
11 changed files with 252 additions and 175 deletions
|
|
@ -1,3 +1,43 @@
|
|||
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.
|
||||
|
|
|
|||
|
|
@ -209,19 +209,19 @@ package body Ada.Exceptions is
|
|||
-- 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
|
||||
|
|
@ -395,15 +395,16 @@ package body Ada.Exceptions is
|
|||
-- 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 --
|
||||
|
|
@ -953,8 +954,6 @@ package body Ada.Exceptions is
|
|||
Message : String := "")
|
||||
is
|
||||
EF : Exception_Id := E;
|
||||
X : constant EOA := Exception_Propagation.Allocate_Occurrence;
|
||||
|
||||
begin
|
||||
-- Raise CE if E = Null_ID (AI-446)
|
||||
|
||||
|
|
@ -964,14 +963,7 @@ package body Ada.Exceptions is
|
|||
|
||||
-- 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;
|
||||
|
||||
----------------------------
|
||||
|
|
|
|||
|
|
@ -189,19 +189,19 @@ package body Ada.Exceptions is
|
|||
-- 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
|
||||
|
|
@ -895,14 +895,14 @@ package body Ada.Exceptions is
|
|||
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;
|
||||
|
||||
|
|
|
|||
|
|
@ -202,8 +202,9 @@ package body Exception_Propagation is
|
|||
-- 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
|
||||
|
||||
|
|
@ -342,8 +343,9 @@ package body Exception_Propagation is
|
|||
-- 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;
|
||||
|
||||
|
|
@ -359,6 +361,8 @@ package body Exception_Propagation is
|
|||
To_GNAT_GCC_Exception (GCC_Exception);
|
||||
begin
|
||||
Excep.all := GNAT_Occurrence.Occurrence;
|
||||
|
||||
return GNAT_Occurrence.Occurrence'Access;
|
||||
end;
|
||||
else
|
||||
|
||||
|
|
@ -370,6 +374,8 @@ package body Exception_Propagation is
|
|||
Excep.Exception_Raised := True;
|
||||
Excep.Pid := Local_Partition_ID;
|
||||
Excep.Num_Tracebacks := 0;
|
||||
|
||||
return Excep;
|
||||
end if;
|
||||
end Setup_Current_Excep;
|
||||
|
||||
|
|
@ -420,6 +426,7 @@ package body Exception_Propagation is
|
|||
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
|
||||
|
|
@ -432,8 +439,8 @@ package body Exception_Propagation is
|
|||
-- 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
|
||||
|
|
@ -466,9 +473,10 @@ package body Exception_Propagation is
|
|||
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;
|
||||
|
||||
-------------
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ package body Exception_Propagation is
|
|||
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
|
||||
|
|
@ -74,14 +74,14 @@ package body Exception_Propagation is
|
|||
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;
|
||||
|
||||
|
|
@ -89,9 +89,10 @@ package body Exception_Propagation is
|
|||
-- 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;
|
||||
|
|
|
|||
|
|
@ -72,17 +72,6 @@ package body Exception_Traces is
|
|||
-- 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 --
|
||||
----------------------
|
||||
|
|
@ -132,18 +121,16 @@ package body Exception_Traces is
|
|||
-- 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
|
||||
|
|
@ -161,8 +148,8 @@ package body Exception_Traces is
|
|||
-- 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
|
||||
|
|
@ -172,8 +159,8 @@ package body Exception_Traces is
|
|||
-- 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;
|
||||
|
||||
------------------------------------
|
||||
|
|
|
|||
|
|
@ -1029,6 +1029,10 @@ package body Freeze is
|
|||
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
|
||||
|
||||
|
|
@ -1037,6 +1041,9 @@ package body Freeze is
|
|||
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
|
||||
|
|
@ -1044,6 +1051,8 @@ package body Freeze is
|
|||
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
|
||||
|
|
@ -1054,14 +1063,20 @@ package body Freeze is
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -6709,7 +6709,7 @@ this attribute.
|
|||
@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
|
||||
|
|
@ -6721,6 +6721,11 @@ equal to @code{@var{S}'Bit_Order}. Note: This means that if a
|
|||
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.
|
||||
|
||||
|
|
|
|||
|
|
@ -77,7 +77,8 @@ __gnat_Unwind_RaiseException (_Unwind_Exception *);
|
|||
_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"
|
||||
|
|
@ -1001,8 +1002,8 @@ setup_to_install (_Unwind_Context *uw_context,
|
|||
/* 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. */
|
||||
|
|
@ -1131,14 +1132,16 @@ PERSONALITY_FUNCTION (version_arg_t version_arg,
|
|||
}
|
||||
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;
|
||||
}
|
||||
|
|
@ -1324,7 +1327,7 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame,
|
|||
CONTEXT context;
|
||||
PRUNTIME_FUNCTION mf_func = NULL;
|
||||
ULONG64 mf_imagebase;
|
||||
ULONG64 mf_rsp;
|
||||
ULONG64 mf_rsp = 0;
|
||||
|
||||
/* Get the context. */
|
||||
RtlCaptureContext (&context);
|
||||
|
|
|
|||
|
|
@ -49,6 +49,8 @@ struct Exception_Data
|
|||
|
||||
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__);
|
||||
|
|
|
|||
|
|
@ -214,6 +214,16 @@ package body Sem_Eval is
|
|||
-- 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;
|
||||
|
|
@ -2702,8 +2712,6 @@ package body Sem_Eval is
|
|||
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
|
||||
|
|
@ -2919,128 +2927,144 @@ package body Sem_Eval is
|
|||
end Length_Mismatch;
|
||||
end if;
|
||||
|
||||
-- Test for expression being foldable
|
||||
declare
|
||||
Is_Static_Expression : Boolean;
|
||||
Is_Foldable : Boolean;
|
||||
pragma Unreferenced (Is_Foldable);
|
||||
|
||||
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
|
||||
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).
|
||||
|
||||
-- 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.
|
||||
Test_Expression_Is_Foldable
|
||||
(N, Left, Right, Is_Static_Expression, Is_Foldable);
|
||||
|
||||
if not Is_Scalar_Type (Typ) then
|
||||
Stat := False;
|
||||
Set_Is_Static_Expression (N, False);
|
||||
end if;
|
||||
-- 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.
|
||||
|
||||
-- For operators on universal numeric types called as functions with
|
||||
-- an explicit scope, determine appropriate specific numeric type, and
|
||||
-- diagnose possible ambiguity.
|
||||
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);
|
||||
|
||||
Fold_Uint (N, Test (Result), True);
|
||||
end;
|
||||
when others =>
|
||||
raise Program_Error;
|
||||
end case;
|
||||
|
||||
-- For all other cases, we use Compile_Time_Compare to do the compare
|
||||
Fold_Uint (N, Test (Result), True);
|
||||
end;
|
||||
|
||||
else
|
||||
declare
|
||||
CR : constant Compare_Result :=
|
||||
Compile_Time_Compare (Left, Right, Assume_Valid => False);
|
||||
-- For all other cases, we use Compile_Time_Compare to do the compare
|
||||
|
||||
begin
|
||||
if CR = Unknown then
|
||||
return;
|
||||
end if;
|
||||
else
|
||||
declare
|
||||
CR : constant Compare_Result :=
|
||||
Compile_Time_Compare
|
||||
(Left, Right, Assume_Valid => False);
|
||||
|
||||
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;
|
||||
begin
|
||||
if CR = Unknown then
|
||||
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;
|
||||
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_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_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_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_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_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_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_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_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 others =>
|
||||
raise Program_Error;
|
||||
end case;
|
||||
end;
|
||||
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;
|
||||
|
||||
Fold_Uint (N, Test (Result), Stat);
|
||||
end if;
|
||||
when others =>
|
||||
raise Program_Error;
|
||||
end case;
|
||||
end;
|
||||
|
||||
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.
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue