Skip to content

R
riscv-gcc-1
Commit 5df1266a by Arnaud Charlet
Options

[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
parent e187fa72
Showing with 255 additions and 178 deletions
gcc/ada/ChangeLog
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> 2012-07-16 Robert Dewar <dewar@adacore.com>
* freeze.adb, g-debpoo.adb, exp_ch3.adb: Minor reformatting. * freeze.adb, g-debpoo.adb, exp_ch3.adb: Minor reformatting.
......
gcc/ada/a-except-2005.adb
...@@ -209,19 +209,19 @@ package body Ada.Exceptions is ...@@ -209,19 +209,19 @@ package body Ada.Exceptions is
-- exported to be usable by the Ada exception handling personality -- exported to be usable by the Ada exception handling personality
-- routine when the GCC 3 mechanism is used. -- routine when the GCC 3 mechanism is used.
procedure Notify_Handled_Exception; procedure Notify_Handled_Exception (Excep : EOA);
pragma Export pragma Export
(C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); (C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
-- This routine is called for a handled occurrence is about to be -- This routine is called for a handled occurrence is about to be
-- propagated. -- propagated.
procedure Notify_Unhandled_Exception; procedure Notify_Unhandled_Exception (Excep : EOA);
pragma Export pragma Export
(C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
-- This routine is called when an unhandled occurrence is about to be -- This routine is called when an unhandled occurrence is about to be
-- propagated. -- propagated.
procedure Unhandled_Exception_Terminate; procedure Unhandled_Exception_Terminate (Excep : EOA);
pragma No_Return (Unhandled_Exception_Terminate); pragma No_Return (Unhandled_Exception_Terminate);
-- This procedure is called to terminate execution following an -- This procedure is called to terminate execution following an
-- unhandled exception. The exception information, including -- unhandled exception. The exception information, including
...@@ -395,15 +395,16 @@ package body Ada.Exceptions is ...@@ -395,15 +395,16 @@ package body Ada.Exceptions is
-- Reraises the exception referenced by the Current_Excep field of -- Reraises the exception referenced by the Current_Excep field of
-- the TSD (all fields of this exception occurrence are set). Abort -- the TSD (all fields of this exception occurrence are set). Abort
-- is deferred before the reraise operation. -- is deferred before the reraise operation.
-- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous
procedure Transfer_Occurrence procedure Transfer_Occurrence
(Target : Exception_Occurrence_Access; (Target : Exception_Occurrence_Access;
Source : Exception_Occurrence); Source : Exception_Occurrence);
pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
-- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous -- Called from s-tasren.adb:Local_Complete_RendezVous and
-- to setup Target from Source as an exception to be propagated in the -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from
-- caller task. Target is expected to be a pointer to the fixed TSD -- Source as an exception to be propagated in the caller task. Target is
-- occurrence for this task. -- expected to be a pointer to the fixed TSD occurrence for this task.
----------------------------- -----------------------------
-- Run-Time Check Routines -- -- Run-Time Check Routines --
...@@ -953,8 +954,6 @@ package body Ada.Exceptions is ...@@ -953,8 +954,6 @@ package body Ada.Exceptions is
Message : String := "") Message : String := "")
is is
EF : Exception_Id := E; EF : Exception_Id := E;
X : constant EOA := Exception_Propagation.Allocate_Occurrence;
begin begin
-- Raise CE if E = Null_ID (AI-446) -- Raise CE if E = Null_ID (AI-446)
...@@ -964,14 +963,7 @@ package body Ada.Exceptions is ...@@ -964,14 +963,7 @@ package body Ada.Exceptions is
-- Go ahead and raise appropriate exception -- Go ahead and raise appropriate exception
Exception_Data.Set_Exception_Msg (X, EF, Message); Raise_Exception_Always (EF, Message);
if not ZCX_By_Default then
Abort_Defer.all;
end if;
Complete_Occurrence (X);
Exception_Propagation.Propagate_Exception (X);
end Raise_Exception; end Raise_Exception;
---------------------------- ----------------------------
......
gcc/ada/a-except.adb
...@@ -189,19 +189,19 @@ package body Ada.Exceptions is ...@@ -189,19 +189,19 @@ package body Ada.Exceptions is
-- exported to be usable by the Ada exception handling personality -- exported to be usable by the Ada exception handling personality
-- routine when the GCC 3 mechanism is used. -- routine when the GCC 3 mechanism is used.
procedure Notify_Handled_Exception; procedure Notify_Handled_Exception (Excep : EOA);
pragma Export pragma Export
(C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); (C, Notify_Handled_Exception, "__gnat_notify_handled_exception");
-- This routine is called for a handled occurrence is about to be -- This routine is called for a handled occurrence is about to be
-- propagated. -- propagated.
procedure Notify_Unhandled_Exception; procedure Notify_Unhandled_Exception (Excep : EOA);
pragma Export pragma Export
(C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception");
-- This routine is called when an unhandled occurrence is about to be -- This routine is called when an unhandled occurrence is about to be
-- propagated. -- propagated.
procedure Unhandled_Exception_Terminate; procedure Unhandled_Exception_Terminate (Excep : EOA);
pragma No_Return (Unhandled_Exception_Terminate); pragma No_Return (Unhandled_Exception_Terminate);
-- This procedure is called to terminate program execution following an -- This procedure is called to terminate program execution following an
-- unhandled exception. The exception information, including traceback -- unhandled exception. The exception information, including traceback
...@@ -895,14 +895,14 @@ package body Ada.Exceptions is ...@@ -895,14 +895,14 @@ package body Ada.Exceptions is
if Jumpbuf_Ptr /= Null_Address then if Jumpbuf_Ptr /= Null_Address then
if not Excep.Exception_Raised then if not Excep.Exception_Raised then
Excep.Exception_Raised := True; Excep.Exception_Raised := True;
Exception_Traces.Notify_Handled_Exception; Exception_Traces.Notify_Handled_Exception (Excep);
end if; end if;
builtin_longjmp (Jumpbuf_Ptr, 1); builtin_longjmp (Jumpbuf_Ptr, 1);
else else
Exception_Traces.Notify_Unhandled_Exception; Exception_Traces.Notify_Unhandled_Exception (Excep);
Exception_Traces.Unhandled_Exception_Terminate; Exception_Traces.Unhandled_Exception_Terminate (Excep);
end if; end if;
end Process_Raise_Exception; end Process_Raise_Exception;
......
gcc/ada/a-exexpr-gcc.adb
...@@ -202,8 +202,9 @@ package body Exception_Propagation is ...@@ -202,8 +202,9 @@ package body Exception_Propagation is
-- Called to implement raise without exception, ie reraise. Called -- Called to implement raise without exception, ie reraise. Called
-- directly from gigi. -- directly from gigi.
procedure Setup_Current_Excep function Setup_Current_Excep
(GCC_Exception : not null GCC_Exception_Access); (GCC_Exception : not null GCC_Exception_Access)
return EOA;
pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep");
-- Write Get_Current_Excep.all from GCC_Exception -- Write Get_Current_Excep.all from GCC_Exception
...@@ -342,8 +343,9 @@ package body Exception_Propagation is ...@@ -342,8 +343,9 @@ package body Exception_Propagation is
-- Setup_Current_Excep -- -- Setup_Current_Excep --
------------------------- -------------------------
procedure Setup_Current_Excep function Setup_Current_Excep
(GCC_Exception : not null GCC_Exception_Access) (GCC_Exception : not null GCC_Exception_Access)
return EOA
is is
Excep : constant EOA := Get_Current_Excep.all; Excep : constant EOA := Get_Current_Excep.all;
...@@ -359,6 +361,8 @@ package body Exception_Propagation is ...@@ -359,6 +361,8 @@ package body Exception_Propagation is
To_GNAT_GCC_Exception (GCC_Exception); To_GNAT_GCC_Exception (GCC_Exception);
begin begin
Excep.all := GNAT_Occurrence.Occurrence; Excep.all := GNAT_Occurrence.Occurrence;
return GNAT_Occurrence.Occurrence'Access;
end; end;
else else
...@@ -370,6 +374,8 @@ package body Exception_Propagation is ...@@ -370,6 +374,8 @@ package body Exception_Propagation is
Excep.Exception_Raised := True; Excep.Exception_Raised := True;
Excep.Pid := Local_Partition_ID; Excep.Pid := Local_Partition_ID;
Excep.Num_Tracebacks := 0; Excep.Num_Tracebacks := 0;
return Excep;
end if; end if;
end Setup_Current_Excep; end Setup_Current_Excep;
...@@ -420,6 +426,7 @@ package body Exception_Propagation is ...@@ -420,6 +426,7 @@ package body Exception_Propagation is
procedure Propagate_GCC_Exception procedure Propagate_GCC_Exception
(GCC_Exception : not null GCC_Exception_Access) (GCC_Exception : not null GCC_Exception_Access)
is is
Excep : EOA;
begin begin
-- Perform a standard raise first. If a regular handler is found, it -- Perform a standard raise first. If a regular handler is found, it
-- will be entered after all the intermediate cleanups have run. If -- will be entered after all the intermediate cleanups have run. If
...@@ -432,8 +439,8 @@ package body Exception_Propagation is ...@@ -432,8 +439,8 @@ package body Exception_Propagation is
-- the necessary steps to enable the debugger to gain control while the -- the necessary steps to enable the debugger to gain control while the
-- stack is still intact. -- stack is still intact.
Setup_Current_Excep (GCC_Exception); Excep := Setup_Current_Excep (GCC_Exception);
Notify_Unhandled_Exception; Notify_Unhandled_Exception (Excep);
-- Now, un a forced unwind to trigger cleanups. Control should not -- Now, un a forced unwind to trigger cleanups. Control should not
-- resume there, if there are cleanups and in any cases as the -- resume there, if there are cleanups and in any cases as the
...@@ -466,9 +473,10 @@ package body Exception_Propagation is ...@@ -466,9 +473,10 @@ package body Exception_Propagation is
procedure Unhandled_Except_Handler procedure Unhandled_Except_Handler
(GCC_Exception : not null GCC_Exception_Access) (GCC_Exception : not null GCC_Exception_Access)
is is
Excep : EOA;
begin begin
Setup_Current_Excep (GCC_Exception); Excep := Setup_Current_Excep (GCC_Exception);
Unhandled_Exception_Terminate; Unhandled_Exception_Terminate (Excep);
end Unhandled_Except_Handler; end Unhandled_Except_Handler;
------------- -------------
......
gcc/ada/a-exexpr.adb
...@@ -43,7 +43,7 @@ package body Exception_Propagation is ...@@ -43,7 +43,7 @@ package body Exception_Propagation is
pragma No_Return (builtin_longjmp); pragma No_Return (builtin_longjmp);
pragma Import (Intrinsic, builtin_longjmp, "__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 No_Return (Propagate_Continue);
pragma Export (C, Propagate_Continue, "__gnat_raise_nodefer_with_msg"); pragma Export (C, Propagate_Continue, "__gnat_raise_nodefer_with_msg");
-- A call to this procedure is inserted automatically by GIGI, in order -- A call to this procedure is inserted automatically by GIGI, in order
...@@ -74,14 +74,14 @@ package body Exception_Propagation is ...@@ -74,14 +74,14 @@ package body Exception_Propagation is
if Jumpbuf_Ptr /= Null_Address then if Jumpbuf_Ptr /= Null_Address then
if not Excep.Exception_Raised then if not Excep.Exception_Raised then
Excep.Exception_Raised := True; Excep.Exception_Raised := True;
Exception_Traces.Notify_Handled_Exception; Exception_Traces.Notify_Handled_Exception (Excep);
end if; end if;
builtin_longjmp (Jumpbuf_Ptr, 1); builtin_longjmp (Jumpbuf_Ptr, 1);
else else
Exception_Traces.Notify_Unhandled_Exception; Exception_Traces.Notify_Unhandled_Exception (Excep);
Exception_Traces.Unhandled_Exception_Terminate; Exception_Traces.Unhandled_Exception_Terminate (Excep);
end if; end if;
end Propagate_Exception; end Propagate_Exception;
...@@ -89,9 +89,10 @@ package body Exception_Propagation is ...@@ -89,9 +89,10 @@ package body Exception_Propagation is
-- Propagate_Continue -- -- Propagate_Continue --
------------------------ ------------------------
procedure Propagate_Continue (Excep : EOA) is procedure Propagate_Continue (E : Exception_Id) is
pragma Unreferenced (E);
begin begin
Propagate_Exception (Excep); Propagate_Exception (Get_Current_Excep.all);
end Propagate_Continue; end Propagate_Continue;
end Exception_Propagation; end Exception_Propagation;
gcc/ada/a-exextr.adb
...@@ -72,17 +72,6 @@ package body Exception_Traces is ...@@ -72,17 +72,6 @@ package body Exception_Traces is
-- latter case because Notify_Handled_Exception may be called for an -- latter case because Notify_Handled_Exception may be called for an
-- actually unhandled occurrence in the Front-End-SJLJ case. -- 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_Exception --
---------------------- ----------------------
...@@ -132,18 +121,16 @@ package body Exception_Traces is ...@@ -132,18 +121,16 @@ package body Exception_Traces is
-- Notify_Handled_Exception -- -- Notify_Handled_Exception --
------------------------------ ------------------------------
procedure Notify_Handled_Exception is procedure Notify_Handled_Exception (Excep : EOA) is
begin begin
Notify_Exception (Get_Current_Excep.all, Is_Unhandled => False); Notify_Exception (Excep, Is_Unhandled => False);
end Notify_Handled_Exception; end Notify_Handled_Exception;
-------------------------------- --------------------------------
-- Notify_Unhandled_Exception -- -- Notify_Unhandled_Exception --
-------------------------------- --------------------------------
procedure Notify_Unhandled_Exception is procedure Notify_Unhandled_Exception (Excep : EOA) is
Excep : constant EOA := Get_Current_Excep.all;
begin begin
-- Check whether there is any termination handler to be executed for -- Check whether there is any termination handler to be executed for
-- the environment task, and execute it if needed. Here we handle both -- the environment task, and execute it if needed. Here we handle both
...@@ -161,8 +148,8 @@ package body Exception_Traces is ...@@ -161,8 +148,8 @@ package body Exception_Traces is
-- Unhandled_Exception_Terminate -- -- Unhandled_Exception_Terminate --
----------------------------------- -----------------------------------
procedure Unhandled_Exception_Terminate is procedure Unhandled_Exception_Terminate (Excep : EOA) is
Excep : Exception_Occurrence; Occ : Exception_Occurrence;
-- This occurrence will be used to display a message after finalization. -- This occurrence will be used to display a message after finalization.
-- It is necessary to save a copy here, or else the designated value -- It is necessary to save a copy here, or else the designated value
-- could be overwritten if an exception is raised during finalization -- could be overwritten if an exception is raised during finalization
...@@ -172,8 +159,8 @@ package body Exception_Traces is ...@@ -172,8 +159,8 @@ package body Exception_Traces is
-- that there is enough room on the stack however. -- that there is enough room on the stack however.
begin begin
Save_Occurrence (Excep, Get_Current_Excep.all.all); Save_Occurrence (Occ, Excep.all);
Last_Chance_Handler (Excep); Last_Chance_Handler (Occ);
end Unhandled_Exception_Terminate; end Unhandled_Exception_Terminate;
------------------------------------ ------------------------------------
......
gcc/ada/freeze.adb
...@@ -1029,6 +1029,10 @@ package body Freeze is ...@@ -1029,6 +1029,10 @@ package body Freeze is
Err_Node : Node_Id; Err_Node : Node_Id;
ADC : 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 begin
-- Record case -- Record case
...@@ -1037,6 +1041,9 @@ package body Freeze is ...@@ -1037,6 +1041,9 @@ package body Freeze is
Comp_Type := Etype (Comp); Comp_Type := Etype (Comp);
Comp_Def := Component_Definition (Parent (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 -- Array case
else else
...@@ -1044,6 +1051,8 @@ package body Freeze is ...@@ -1044,6 +1051,8 @@ package body Freeze is
Comp_Type := Component_Type (Encl_Type); Comp_Type := Component_Type (Encl_Type);
Comp_Def := Component_Definition Comp_Def := Component_Definition
(Type_Definition (Declaration_Node (Encl_Type))); (Type_Definition (Declaration_Node (Encl_Type)));
Comp_Byte_Aligned := False;
end if; end if;
-- Note: the Reverse_Storage_Order flag is set on the base type, but -- Note: the Reverse_Storage_Order flag is set on the base type, but
...@@ -1054,14 +1063,20 @@ package body Freeze is ...@@ -1054,14 +1063,20 @@ package body Freeze is
(First_Subtype (Comp_Type), (First_Subtype (Comp_Type),
Attribute_Scalar_Storage_Order); Attribute_Scalar_Storage_Order);
if (Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type)) if Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then
and then if No (ADC) then
(No (ADC) or else Reverse_Storage_Order (Encl_Type) /= Error_Msg_N ("nested composite must have explicit scalar "
Reverse_Storage_Order (Etype (Comp_Type))) & "storage order", Err_Node);
then
Error_Msg_N elsif (Reverse_Storage_Order (Encl_Type)
("component type must have same scalar storage order as " /=
& "enclosing composite", Err_Node); 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 elsif Aliased_Present (Comp_Def) then
Error_Msg_N Error_Msg_N
......
gcc/ada/gnat_rm.texi
...@@ -6709,7 +6709,7 @@ this attribute. ...@@ -6709,7 +6709,7 @@ this attribute.
@cindex Scalar storage order @cindex Scalar storage order
@findex Scalar_Storage_Order @findex Scalar_Storage_Order
@noindent @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 @code{Scalar_Storage_Order} denotes the order in which storage elements
that make up scalar components are ordered within S. Other properties are that make up scalar components are ordered within S. Other properties are
as for standard representation attribute @code{Bit_Order}, as defined by 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 ...@@ -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 then the type's @code{Bit_Order} shall be specified explicitly and set to
the same value. 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. A confirming @code{Scalar_Storage_Order} attribute definition clause (i.e.
with a value equal to @code{System.Default_Bit_Order}) has no effect. with a value equal to @code{System.Default_Bit_Order}) has no effect.
......
gcc/ada/raise-gcc.c
...@@ -77,7 +77,8 @@ __gnat_Unwind_RaiseException (_Unwind_Exception *); ...@@ -77,7 +77,8 @@ __gnat_Unwind_RaiseException (_Unwind_Exception *);
_Unwind_Reason_Code _Unwind_Reason_Code
__gnat_Unwind_ForcedUnwind (_Unwind_Exception *, void *, void *); __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 *); extern void __gnat_unhandled_except_handler (_Unwind_Exception *);
#include "dwarf2.h" #include "dwarf2.h"
...@@ -1001,8 +1002,8 @@ setup_to_install (_Unwind_Context *uw_context, ...@@ -1001,8 +1002,8 @@ setup_to_install (_Unwind_Context *uw_context,
/* The following is defined from a-except.adb. Its purpose is to enable /* The following is defined from a-except.adb. Its purpose is to enable
automatic backtraces upon exception raise, as provided through the automatic backtraces upon exception raise, as provided through the
GNAT.Traceback facilities. */ GNAT.Traceback facilities. */
extern void __gnat_notify_handled_exception (void); extern void __gnat_notify_handled_exception (struct Exception_Occurrence *);
extern void __gnat_notify_unhandled_exception (void); extern void __gnat_notify_unhandled_exception (struct Exception_Occurrence *);
/* Below is the eh personality routine per se. We currently assume that only /* Below is the eh personality routine per se. We currently assume that only
GNU-Ada exceptions are met. */ GNU-Ada exceptions are met. */
...@@ -1131,14 +1132,16 @@ PERSONALITY_FUNCTION (version_arg_t version_arg, ...@@ -1131,14 +1132,16 @@ PERSONALITY_FUNCTION (version_arg_t version_arg,
} }
else else
{ {
struct Exception_Occurrence *excep;
/* Trigger the appropriate notification routines before the second /* Trigger the appropriate notification routines before the second
phase starts, which ensures the stack is still intact. phase starts, which ensures the stack is still intact.
First, setup the Ada occurrence. */ First, setup the Ada occurrence. */
__gnat_setup_current_excep (uw_exception); excep = __gnat_setup_current_excep (uw_exception);
if (action.kind == unhandler) if (action.kind == unhandler)
__gnat_notify_unhandled_exception (); __gnat_notify_unhandled_exception (excep);
else else
__gnat_notify_handled_exception (); __gnat_notify_handled_exception (excep);
return _URC_HANDLER_FOUND; return _URC_HANDLER_FOUND;
} }
...@@ -1324,7 +1327,7 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame, ...@@ -1324,7 +1327,7 @@ __gnat_personality_seh0 (PEXCEPTION_RECORD ms_exc, void *this_frame,
CONTEXT context; CONTEXT context;
PRUNTIME_FUNCTION mf_func = NULL; PRUNTIME_FUNCTION mf_func = NULL;
ULONG64 mf_imagebase; ULONG64 mf_imagebase;
ULONG64 mf_rsp; ULONG64 mf_rsp = 0;
/* Get the context. */ /* Get the context. */
RtlCaptureContext (&context); RtlCaptureContext (&context);
......
gcc/ada/raise.h
...@@ -49,6 +49,8 @@ struct Exception_Data ...@@ -49,6 +49,8 @@ struct Exception_Data
typedef struct Exception_Data *Exception_Id; typedef struct Exception_Data *Exception_Id;
struct Exception_Occurrence;
extern void _gnat_builtin_longjmp (void *, int); extern void _gnat_builtin_longjmp (void *, int);
extern void __gnat_unhandled_terminate (void); extern void __gnat_unhandled_terminate (void);
extern void *__gnat_malloc (__SIZE_TYPE__); extern void *__gnat_malloc (__SIZE_TYPE__);
......
gcc/ada/sem_eval.adb
...@@ -214,6 +214,16 @@ package body Sem_Eval is ...@@ -214,6 +214,16 @@ package body Sem_Eval is
-- e.g. in the two operand case below, for string comparison, the result -- 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, -- is not static even though the two operands are static. In such cases,
-- the caller must reset the Is_Static_Expression flag in N. -- 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 procedure Test_Expression_Is_Foldable
(N : Node_Id; (N : Node_Id;
...@@ -2702,8 +2712,6 @@ package body Sem_Eval is ...@@ -2702,8 +2712,6 @@ package body Sem_Eval is
Typ : constant Entity_Id := Etype (Left); Typ : constant Entity_Id := Etype (Left);
Otype : Entity_Id := Empty; Otype : Entity_Id := Empty;
Result : Boolean; Result : Boolean;
Stat : Boolean;
Fold : Boolean;
begin begin
-- One special case to deal with first. If we can tell that the result -- One special case to deal with first. If we can tell that the result
...@@ -2919,128 +2927,144 @@ package body Sem_Eval is ...@@ -2919,128 +2927,144 @@ package body Sem_Eval is
end Length_Mismatch; end Length_Mismatch;
end if; end if;
-- Test for expression being foldable declare
Is_Static_Expression : Boolean;
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); Is_Foldable : Boolean;
pragma Unreferenced (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
Stat := False;
Set_Is_Static_Expression (N, False);
end if;
-- For operators on universal numeric types called as functions with begin
-- an explicit scope, determine appropriate specific numeric type, and -- Initialize the value of Is_Static_Expression. The value of
-- diagnose possible ambiguity. -- 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)) -- For operators on universal numeric types called as functions with
and then -- an explicit scope, determine appropriate specific numeric type,
Is_Universal_Numeric_Type (Etype (Right)) -- and diagnose possible ambiguity.
then
Otype := Find_Universal_Operator_Type (N);
end if;
-- For static real type expressions, we cannot use Compile_Time_Compare if Is_Universal_Numeric_Type (Etype (Left))
-- since it worries about run-time results which are not exact. 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 -- For static real type expressions, we cannot use
declare -- Compile_Time_Compare since it worries about run-time
Left_Real : constant Ureal := Expr_Value_R (Left); -- results which are not exact.
Right_Real : constant Ureal := Expr_Value_R (Right);
begin if Is_Static_Expression and then Is_Real_Type (Typ) then
case Nkind (N) is declare
when N_Op_Eq => Result := (Left_Real = Right_Real); Left_Real : constant Ureal := Expr_Value_R (Left);
when N_Op_Ne => Result := (Left_Real /= Right_Real); Right_Real : constant Ureal := Expr_Value_R (Right);
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 => begin
raise Program_Error; case Nkind (N) is
end case; 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); Fold_Uint (N, Test (Result), True);
end; 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 else
declare declare
CR : constant Compare_Result := CR : constant Compare_Result :=
Compile_Time_Compare (Left, Right, Assume_Valid => False); Compile_Time_Compare
(Left, Right, Assume_Valid => False);
begin begin
if CR = Unknown then if CR = Unknown then
return; return;
end if; end if;
case Nkind (N) is case Nkind (N) is
when N_Op_Eq => when N_Op_Eq =>
if CR = EQ then if CR = EQ then
Result := True; Result := True;
elsif CR = NE or else CR = GT or else CR = LT then elsif CR = NE or else CR = GT or else CR = LT then
Result := False; Result := False;
else else
return; return;
end if; end if;
when N_Op_Ne => when N_Op_Ne =>
if CR = NE or else CR = GT or else CR = LT then if CR = NE or else CR = GT or else CR = LT then
Result := True; Result := True;
elsif CR = EQ then elsif CR = EQ then
Result := False; Result := False;
else else
return; return;
end if; end if;
when N_Op_Lt => when N_Op_Lt =>
if CR = LT then if CR = LT then
Result := True; Result := True;
elsif CR = EQ or else CR = GT or else CR = GE then elsif CR = EQ or else CR = GT or else CR = GE then
Result := False; Result := False;
else else
return; return;
end if; end if;
when N_Op_Le => when N_Op_Le =>
if CR = LT or else CR = EQ or else CR = LE then if CR = LT or else CR = EQ or else CR = LE then
Result := True; Result := True;
elsif CR = GT then elsif CR = GT then
Result := False; Result := False;
else else
return; return;
end if; end if;
when N_Op_Gt => when N_Op_Gt =>
if CR = GT then if CR = GT then
Result := True; Result := True;
elsif CR = EQ or else CR = LT or else CR = LE then elsif CR = EQ or else CR = LT or else CR = LE then
Result := False; Result := False;
else else
return; return;
end if; end if;
when N_Op_Ge => when N_Op_Ge =>
if CR = GT or else CR = EQ or else CR = GE then if CR = GT or else CR = EQ or else CR = GE then
Result := True; Result := True;
elsif CR = LT then elsif CR = LT then
Result := False; Result := False;
else else
return; return;
end if; end if;
when others => when others =>
raise Program_Error; raise Program_Error;
end case; end case;
end; end;
Fold_Uint (N, Test (Result), Stat); Fold_Uint (N, Test (Result), Is_Static_Expression);
end if; end if;
end;
-- For the case of a folded relational operator on a specific numeric -- For the case of a folded relational operator on a specific numeric
-- type, freeze operand type now. -- type, freeze operand type now.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment