diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2014-07-17 09:27:38 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2014-07-17 09:27:38 +0200 |
| commit | 6782b1ef34e4b6afca51b219792f3e0f26aeff18 (patch) | |
| tree | b6b5735de0927822e0ecb101202cf01e7f7e5288 | |
| parent | 6ccdd977051143e03a166c8994fd2519a0a7c5f0 (diff) | |
| download | gcc-6782b1ef34e4b6afca51b219792f3e0f26aeff18.zip gcc-6782b1ef34e4b6afca51b219792f3e0f26aeff18.tar.gz gcc-6782b1ef34e4b6afca51b219792f3e0f26aeff18.tar.bz2 | |
[multiple changes]
2014-07-17 Gary Dismukes <dismukes@adacore.com>
* exp_disp.adb: Minor reformatting.
* exp_disp.adb: Minor code reorganization.
2014-07-17 Thomas Quinot <quinot@adacore.com>
* gnat_rm.texi, freeze.adb (Check_Component_Storage_Order): Do not
require an explicit SSO attribute definition clause on a composite type
just because one of its components has one.
2014-07-17 Robert Dewar <dewar@adacore.com>
* sem_attr.adb (Analyze_Attribute, case Loop_Entry): Rewrite
attribute out of existence if the enclosing pragma is ignored.
* sem_util.adb: Minor reformatting.
2014-07-17 Ed Schonberg <schonberg@adacore.com>
* exp_aggr.adb (Expand_Array_Aggregate): Handle properly an
array aggregate expanded into assignments when it appears as a
local declaration in an inlined body.
2014-07-17 Doug Rupp <rupp@adacore.com>
* init.c [__ANDROID__]: Modify for ZCX.
* exp_aggr.adb: Minor reformatting
* sigtramp-armvxw.c, sigtramp-ppcvxw.c: Update comments.
2014-07-17 Robert Dewar <dewar@adacore.com>
* a-strunb-shared.ads, a-stwiun-shared.ads, a-stzunb-shared.ads,
exp_ch7.adb, g-pehage.ads, g-socket.ads, gnat_ugn.texi, gnat_ugx.texi,
scng.adb: Remove incorrect usage "allow to" and "allows to".
2014-07-17 Robert Dewar <dewar@adacore.com>
* exp_dist.adb: Minor reformatting.
From-SVN: r212737
| -rw-r--r-- | gcc/ada/ChangeLog | 39 | ||||
| -rw-r--r-- | gcc/ada/a-strunb-shared.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/a-stwiun-shared.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/a-stzunb-shared.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 863 | ||||
| -rw-r--r-- | gcc/ada/exp_dist.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/g-pehage.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/g-socket.ads | 22 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 22 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 21 | ||||
| -rw-r--r-- | gcc/ada/init.c | 34 | ||||
| -rw-r--r-- | gcc/ada/scng.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 37 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sigtramp-armvxw.c | 10 | ||||
| -rw-r--r-- | gcc/ada/sigtramp-ppcvxw.c | 10 |
19 files changed, 570 insertions, 583 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3102148..9b591d8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,42 @@ +2014-07-17 Gary Dismukes <dismukes@adacore.com> + + * exp_disp.adb: Minor reformatting. + * exp_disp.adb: Minor code reorganization. + +2014-07-17 Thomas Quinot <quinot@adacore.com> + + * gnat_rm.texi, freeze.adb (Check_Component_Storage_Order): Do not + require an explicit SSO attribute definition clause on a composite type + just because one of its components has one. + +2014-07-17 Robert Dewar <dewar@adacore.com> + + * sem_attr.adb (Analyze_Attribute, case Loop_Entry): Rewrite + attribute out of existence if the enclosing pragma is ignored. + * sem_util.adb: Minor reformatting. + +2014-07-17 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Expand_Array_Aggregate): Handle properly an + array aggregate expanded into assignments when it appears as a + local declaration in an inlined body. + +2014-07-17 Doug Rupp <rupp@adacore.com> + + * init.c [__ANDROID__]: Modify for ZCX. + * exp_aggr.adb: Minor reformatting + * sigtramp-armvxw.c, sigtramp-ppcvxw.c: Update comments. + +2014-07-17 Robert Dewar <dewar@adacore.com> + + * a-strunb-shared.ads, a-stwiun-shared.ads, a-stzunb-shared.ads, + exp_ch7.adb, g-pehage.ads, g-socket.ads, gnat_ugn.texi, gnat_ugx.texi, + scng.adb: Remove incorrect usage "allow to" and "allows to". + +2014-07-17 Robert Dewar <dewar@adacore.com> + + * exp_dist.adb: Minor reformatting. + 2014-07-17 Bob Duff <duff@adacore.com> * gnat_ugn.texi: Improve documentation of Unrestricted_Access. diff --git a/gcc/ada/a-strunb-shared.ads b/gcc/ada/a-strunb-shared.ads index 3ec961f..1a00780 100644 --- a/gcc/ada/a-strunb-shared.ads +++ b/gcc/ada/a-strunb-shared.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -64,9 +64,9 @@ -- preallocated memory can used later by Append/Insert operations -- without reallocation. - -- Reference counting uses GCC builtin atomic operations, which allows to - -- safely share internal data between Ada tasks. Nevertheless, this doesn't - -- make objects of Unbounded_String thread-safe: each instance can't be + -- Reference counting uses GCC builtin atomic operations, which allows safe + -- sharing of internal data between Ada tasks. Nevertheless, this does not + -- make objects of Unbounded_String thread-safe: an instance cannot be -- accessed by several tasks simultaneously. with Ada.Strings.Maps; diff --git a/gcc/ada/a-stwiun-shared.ads b/gcc/ada/a-stwiun-shared.ads index b3b62af..20c2d42 100644 --- a/gcc/ada/a-stwiun-shared.ads +++ b/gcc/ada/a-stwiun-shared.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -471,10 +471,10 @@ private -- preallocated memory can used later by Append/Insert operations -- without reallocation. - -- Reference counting uses GCC builtin atomic operations, which allows to - -- safely share internal data between Ada tasks. Nevertheless, this not - -- make objects of Unbounded_Wide_String thread-safe, so each instance - -- can't be accessed by several tasks simultaneously. + -- Reference counting uses GCC builtin atomic operations, which allows safe + -- sharing of internal data between Ada tasks. Nevertheless, this does not + -- make objects of Unbounded_String thread-safe: an instance cannot be + -- accessed by several tasks simultaneously. pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String); -- Provide stream routines without dragging in Ada.Streams diff --git a/gcc/ada/a-stzunb-shared.ads b/gcc/ada/a-stzunb-shared.ads index 66c0427..3c9e016 100644 --- a/gcc/ada/a-stzunb-shared.ads +++ b/gcc/ada/a-stzunb-shared.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -485,10 +485,10 @@ private -- preallocated memory can used later by Append/Insert operations -- without reallocation. - -- Reference counting uses GCC builtin atomic operations, which allows to - -- safely share internal data between Ada tasks. Nevertheless, this not - -- make objects of Unbounded_Wide_Wide_String thread-safe, so each instance - -- can't be accessed by several tasks simultaneously. + -- Reference counting uses GCC builtin atomic operations, which allows safe + -- sharing of internal data between Ada tasks. Nevertheless, this does not + -- make objects of Unbounded_String thread-safe: an instance cannot be + -- accessed by several tasks simultaneously. pragma Stream_Convert (Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 1bc6fb6..c3d7a1f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5235,7 +5235,17 @@ package body Exp_Aggr is Scalar_Comp => Is_Scalar_Type (Ctyp)); end; - if Comes_From_Source (Tmp) then + -- If the aggregate is the expression in a declaration, the expanded + -- code must be inserted after it. The defining entity might not come + -- from source if this is part of an inlined body, but the declaration + -- itself will. + + if Comes_From_Source (Tmp) + or else + (Nkind (Parent (N)) = N_Object_Declaration + and then Comes_From_Source (Parent (N)) + and then Tmp = Defining_Entity (Parent (N))) + then declare Node_After : constant Node_Id := Next (Parent_Node); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 08b47f6..b98362f 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -215,7 +215,7 @@ package body Exp_Ch7 is -- A classwide type can always potentially have controlled components -- but the record controller of the corresponding actual type may not -- be known at compile time so the dispatch table contains a special - -- field that allows to compute the offset of the record controller + -- field that allows computation of the offset of the record controller -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset. -- Here is a simple example of the expansion of a controlled block : diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 34db312..e1032bb 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -90,13 +90,13 @@ package body Exp_Disp is -- an alias of a predefined dispatching primitive (i.e. through a renaming) function New_Value (From : Node_Id) return Node_Id; - -- From is the original Expression. New_Value is equivalent to a call - -- to Duplicate_Subexpr with an explicit dereference when From is an - -- access parameter. + -- From is the original Expression. New_Value is equivalent to a call to + -- Duplicate_Subexpr with an explicit dereference when From is an access + -- parameter. function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; - -- Check if the type has a private view or if the public view appears - -- in the visible part of a package spec. + -- Check if the type has a private view or if the public view appears in + -- the visible part of a package spec. function Prim_Op_Kind (Prim : Entity_Id; @@ -131,10 +131,10 @@ package body Exp_Disp is return; end if; - -- Apply_Tag_Checks is called directly from the semantics, so we need - -- a check to see whether expansion is active before proceeding. In - -- addition, there is no need to expand the call when compiling under - -- restriction No_Dispatching_Calls; the semantic analyzer has + -- Apply_Tag_Checks is called directly from the semantics, so we + -- need a check to see whether expansion is active before proceeding. + -- In addition, there is no need to expand the call when compiling + -- under restriction No_Dispatching_Calls; the semantic analyzer has -- previously notified the violation of this restriction. if not Expander_Active @@ -221,11 +221,10 @@ package body Exp_Disp is elsif Find_Controlling_Arg (Param) = Ctrl_Arg then null; - -- "=" is the only dispatching operation allowed to get - -- operands with incompatible tags (it just returns false). - -- We use Duplicate_Subexpr_Move_Checks instead of calling - -- Relocate_Node because the value will be duplicated to - -- check the tags. + -- "=" is the only dispatching operation allowed to get operands + -- with incompatible tags (it just returns false). We use + -- Duplicate_Subexpr_Move_Checks instead of calling Relocate_Node + -- because the value will be duplicated to check the tags. elsif Subp = Eq_Prim_Op then null; @@ -251,6 +250,7 @@ package body Exp_Disp is else -- Generate code for tag equality check + -- Perhaps should have Checks.Apply_Tag_Equality_Check??? Insert_Action (Ctrl_Arg, @@ -347,8 +347,8 @@ package body Exp_Disp is Build_Dispatch_Tables (Declarations (Proper_Body (Unit (Library_Unit (D))))); - -- Handle full type declarations and derivations of library - -- level tagged types + -- Handle full type declarations and derivations of library level + -- tagged types elsif Nkind_In (D, N_Full_Type_Declaration, N_Derived_Type_Definition) @@ -497,7 +497,7 @@ package body Exp_Disp is Set_Can_Never_Be_Null (Anon_Type); -- Decorate the size and alignment attributes of the anonymous access - -- type, as required by gigi. + -- type, as required by the back end. Layout_Type (Anon_Type); @@ -537,8 +537,7 @@ package body Exp_Disp is CPP_Typ := Enclosing_CPP_Parent (Typ); Tag_Comp := First_Tag_Component (CPP_Typ); - -- If the number of primitives is already set in the tag component - -- then use it + -- If number of primitives already set in the tag component, use it if Present (Tag_Comp) and then DT_Entry_Count (Tag_Comp) /= No_Uint @@ -693,8 +692,8 @@ package body Exp_Disp is return; end if; - -- Expand_Dispatching_Call is called directly from the semantics, - -- so we only proceed if the expander is active. + -- Expand_Dispatching_Call is called directly from the semantics, so we + -- only proceed if the expander is active. if not Expander_Active @@ -1069,8 +1068,8 @@ package body Exp_Disp is Set_SCIL_Node (SCIL_Related_Node, SCIL_Node); end if; - -- Suppress all checks during the analysis of the expanded code - -- to avoid the generation of spurious warnings under ZFP run-time. + -- Suppress all checks during the analysis of the expanded code to avoid + -- the generation of spurious warnings under ZFP run-time. Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks); end Expand_Dispatching_Call; @@ -1246,9 +1245,8 @@ package body Exp_Disp is Analyze (N); - -- If the target is a class-wide interface we change the type of the - -- data returned by IW_Convert to indicate that this is a dispatching - -- call. + -- If target is a class-wide interface, change the type of the data + -- returned by IW_Convert to indicate this is a dispatching call. declare New_Itype : Entity_Id; @@ -1277,8 +1275,8 @@ package body Exp_Disp is if not Is_Access_Type (Etype (N)) then - -- Statically displace the pointer to the object to reference - -- the component containing the secondary dispatch table. + -- Statically displace the pointer to the object to reference the + -- component containing the secondary dispatch table. Rewrite (N, Convert_Tag_To_Interface (Class_Wide_Type (Iface_Typ), @@ -1337,9 +1335,9 @@ package body Exp_Disp is Make_Simple_Return_Statement (Loc, Unchecked_Convert_To (Etype (N), Make_Attribute_Reference (Loc, - Prefix => + Prefix => Make_Selected_Component (Loc, - Prefix => + Prefix => Unchecked_Convert_To (Defining_Identifier (New_Typ_Decl), Make_Identifier (Loc, Name_uO)), @@ -1360,8 +1358,7 @@ package body Exp_Disp is (RTE (RE_Null_Address), Loc)), Then_Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Make_Null (Loc))), + Make_Simple_Return_Statement (Loc, Make_Null (Loc))), Else_Statements => Stats)); end if; @@ -1496,8 +1493,8 @@ package body Exp_Disp is if Actual_Typ = Formal_Typ then null; - -- No need to displace the pointer if the interface type is - -- a parent of the type of the actual because in this case the + -- No need to displace the pointer if the interface type is a + -- parent of the type of the actual because in this case the -- interface primitives are located in the primary dispatch table. elsif Is_Ancestor (Formal_Typ, Actual_Typ, @@ -1505,8 +1502,8 @@ package body Exp_Disp is then null; - -- Implicit conversion to the class-wide formal type to force - -- the displacement of the pointer. + -- Implicit conversion to the class-wide formal type to force the + -- displacement of the pointer. else -- Normally, expansion of actuals for calls to build-in-place @@ -1571,10 +1568,11 @@ package body Exp_Disp is if From_Limited_With (Actual_Typ) then - -- If the type of the actual parameter comes from a limited - -- with-clause and the non-limited view is already available - -- we replace the anonymous access type by a duplicate - -- declaration whose designated type is the non-limited view + -- If the type of the actual parameter comes from a + -- limited with-clause and the non-limited view is already + -- available, we replace the anonymous access type by + -- a duplicate declaration whose designated type is the + -- non-limited view. if Ekind (Actual_DDT) = E_Incomplete_Type and then Present (Non_Limited_View (Actual_DDT)) @@ -1962,12 +1960,12 @@ package body Exp_Disp is Thunk_Code := Make_Subprogram_Body (Loc, - Specification => + Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Thunk_Id, Parameter_Specifications => Formals, Result_Definition => Result_Def), - Declarations => Decl, + Declarations => Decl, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( @@ -2007,9 +2005,7 @@ package body Exp_Disp is E := Next_Entity (Typ); while Present (E) loop - if Ekind (E) = E_Function - and then Is_Constructor (E) - then + if Ekind (E) = E_Function and then Is_Constructor (E) then return True; end if; @@ -2026,7 +2022,7 @@ package body Exp_Disp is function Has_DT (Typ : Entity_Id) return Boolean is begin return not Is_Interface (Typ) - and then not Restriction_Active (No_Dispatching_Calls); + and then not Restriction_Active (No_Dispatching_Calls); end Has_DT; ---------------------------------- @@ -2143,15 +2139,15 @@ package body Exp_Disp is begin -- In VM targets we don't restrict the functionality of this test to -- compiling in Ada 2005 mode since in VM targets any tagged type has - -- these primitives + -- these primitives. return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion) - and then (Chars (E) = Name_uDisp_Asynchronous_Select or else - Chars (E) = Name_uDisp_Conditional_Select or else - Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else - Chars (E) = Name_uDisp_Get_Task_Id or else - Chars (E) = Name_uDisp_Requeue or else - Chars (E) = Name_uDisp_Timed_Select); + and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select, + Name_uDisp_Conditional_Select, + Name_uDisp_Get_Prim_Op_Kind, + Name_uDisp_Get_Task_Id, + Name_uDisp_Requeue, + Name_uDisp_Timed_Select); end Is_Predefined_Interface_Primitive; ---------------------------------------- @@ -2234,13 +2230,15 @@ package body Exp_Disp is if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, - Specification => Make_Disp_Asynchronous_Select_Spec (Typ), - Declarations => New_List, + Specification => + Make_Disp_Asynchronous_Select_Spec (Typ), + Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - New_List (Make_Assignment_Statement (Loc, - Name => Make_Identifier (Loc, Name_uF), - Expression => New_Occurrence_Of (Standard_False, Loc))))); + New_List ( + Make_Assignment_Statement (Loc, + Name => Make_Identifier (Loc, Name_uF), + Expression => New_Occurrence_Of (Standard_False, Loc))))); end if; if Is_Concurrent_Record_Type (Typ) then @@ -2261,7 +2259,7 @@ package body Exp_Disp is else Tag_Node := Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), + Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Tag); end if; @@ -2269,16 +2267,14 @@ package body Exp_Disp is Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), - Object_Definition => + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), - Expression => + Expression => Make_Function_Call (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), Parameter_Associations => - New_List ( - Tag_Node, - Make_Identifier (Loc, Name_uS))))); + New_List (Tag_Node, Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then @@ -2288,9 +2284,8 @@ package body Exp_Disp is Com_Block := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Com_Block, - Object_Definition => + Defining_Identifier => Com_Block, + Object_Definition => New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); -- Build T._object'Access for calls below @@ -2320,7 +2315,7 @@ package body Exp_Disp is Append_To (Stmts, Make_Procedure_Call_Statement (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), Parameter_Associations => New_List ( @@ -2351,10 +2346,9 @@ package body Exp_Disp is Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => - New_Occurrence_Of ( - RTE (RE_Dummy_Communication_Block), Loc), - Expression => - New_Occurrence_Of (Com_Block, Loc)))); + New_Occurrence_Of + (RTE (RE_Dummy_Communication_Block), Loc), + Expression => New_Occurrence_Of (Com_Block, Loc)))); -- Generate: -- F := False; @@ -2380,7 +2374,7 @@ package body Exp_Disp is Append_To (Stmts, Make_Procedure_Call_Statement (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), Parameter_Associations => New_List ( @@ -2391,7 +2385,7 @@ package body Exp_Disp is Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), - Expression => Make_Identifier (Loc, Name_uI)), + Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uP), -- parameter block New_Occurrence_Of -- Asynchronous_Call @@ -2442,38 +2436,29 @@ package body Exp_Disp is Append_List_To (Params, New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uT), - Parameter_Type => - New_Occurrence_Of (Typ, Loc), - In_Present => True, - Out_Present => True), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => New_Occurrence_Of (Typ, Loc), + In_Present => True, + Out_Present => True), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uS), - Parameter_Type => - New_Occurrence_Of (Standard_Integer, Loc)), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uP), - Parameter_Type => - New_Occurrence_Of (RTE (RE_Address), Loc)), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uB), - Parameter_Type => + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uB), + Parameter_Type => New_Occurrence_Of (RTE (RE_Dummy_Communication_Block), Loc), - Out_Present => True), + Out_Present => True), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uF), - Parameter_Type => - New_Occurrence_Of (Standard_Boolean, Loc), - Out_Present => True))); + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), + Out_Present => True))); return Make_Procedure_Specification (Loc, @@ -2573,10 +2558,9 @@ package body Exp_Disp is if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, - Specification => + Specification => Make_Disp_Conditional_Select_Spec (Typ), - Declarations => - No_List, + Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List (Make_Assignment_Statement (Loc, @@ -2595,9 +2579,8 @@ package body Exp_Disp is Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uI), - Object_Definition => + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); -- Generate: @@ -2622,9 +2605,8 @@ package body Exp_Disp is Blk_Nam := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Blk_Nam, - Object_Definition => + Defining_Identifier => Blk_Nam, + Object_Definition => New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); -- Generate: @@ -2641,21 +2623,20 @@ package body Exp_Disp is else Tag_Node := Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), + Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Tag); end if; Append_To (Stmts, Make_Assignment_Statement (Loc, - Name => Make_Identifier (Loc, Name_uI), + Name => Make_Identifier (Loc, Name_uI), Expression => Make_Function_Call (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), - Parameter_Associations => - New_List ( - Tag_Node, - Make_Identifier (Loc, Name_uS))))); + Parameter_Associations => New_List ( + Tag_Node, + Make_Identifier (Loc, Name_uS))))); if Ekind (Conc_Typ) = E_Protected_Type then @@ -2684,10 +2665,9 @@ package body Exp_Disp is Append_To (Stmts, Make_Procedure_Call_Statement (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), - Parameter_Associations => - New_List ( + Parameter_Associations => New_List ( Obj_Ref, Make_Unchecked_Type_Conversion (Loc, -- entry index @@ -2710,11 +2690,10 @@ package body Exp_Disp is Append_To (Stmts, Make_Procedure_Call_Statement (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Protected_Single_Entry_Call), Loc), - Parameter_Associations => - New_List ( + Parameter_Associations => New_List ( Obj_Ref, Make_Attribute_Reference (Loc, @@ -2740,10 +2719,9 @@ package body Exp_Disp is Make_Op_Not (Loc, Right_Opnd => Make_Function_Call (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), - Parameter_Associations => - New_List ( + Parameter_Associations => New_List ( New_Occurrence_Of (Blk_Nam, Loc)))))); else pragma Assert (Ekind (Conc_Typ) = E_Task_Type); @@ -2761,10 +2739,9 @@ package body Exp_Disp is Append_To (Stmts, Make_Procedure_Call_Statement (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), - Parameter_Associations => - New_List ( + Parameter_Associations => New_List ( Make_Selected_Component (Loc, -- T._task_id Prefix => Make_Identifier (Loc, Name_uT), @@ -2828,38 +2805,29 @@ package body Exp_Disp is Append_List_To (Params, New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uT), - Parameter_Type => - New_Occurrence_Of (Typ, Loc), - In_Present => True, - Out_Present => True), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => New_Occurrence_Of (Typ, Loc), + In_Present => True, + Out_Present => True), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uS), - Parameter_Type => - New_Occurrence_Of (Standard_Integer, Loc)), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uP), - Parameter_Type => - New_Occurrence_Of (RTE (RE_Address), Loc)), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uC), - Parameter_Type => + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc), - Out_Present => True), + Out_Present => True), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uF), - Parameter_Type => - New_Occurrence_Of (Standard_Boolean, Loc), - Out_Present => True))); + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), + Out_Present => True))); return Make_Procedure_Specification (Loc, @@ -2871,9 +2839,7 @@ package body Exp_Disp is -- Make_Disp_Get_Prim_Op_Kind_Body -- ------------------------------------- - function Make_Disp_Get_Prim_Op_Kind_Body - (Typ : Entity_Id) return Node_Id - is + function Make_Disp_Get_Prim_Op_Kind_Body (Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Typ); Tag_Node : Node_Id; @@ -2883,10 +2849,9 @@ package body Exp_Disp is if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, - Specification => + Specification => Make_Disp_Get_Prim_Op_Kind_Spec (Typ), - Declarations => - New_List, + Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List (Make_Null_Statement (Loc)))); @@ -2907,22 +2872,20 @@ package body Exp_Disp is else Tag_Node := Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), + Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Tag); end if; return Make_Subprogram_Body (Loc, - Specification => + Specification => Make_Disp_Get_Prim_Op_Kind_Spec (Typ), - Declarations => - New_List, + Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List ( Make_Assignment_Statement (Loc, - Name => - Make_Identifier (Loc, Name_uC), + Name => Make_Identifier (Loc, Name_uC), Expression => Make_Function_Call (Loc, Name => @@ -2941,8 +2904,7 @@ package body Exp_Disp is is Loc : constant Source_Ptr := Sloc (Typ); Def_Id : constant Node_Id := - Make_Defining_Identifier (Loc, - Name_uDisp_Get_Prim_Op_Kind); + Make_Defining_Identifier (Loc, Name_uDisp_Get_Prim_Op_Kind); Params : constant List_Id := New_List; begin @@ -2955,25 +2917,20 @@ package body Exp_Disp is Append_List_To (Params, New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uT), - Parameter_Type => - New_Occurrence_Of (Typ, Loc), - In_Present => True, - Out_Present => True), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => New_Occurrence_Of (Typ, Loc), + In_Present => True, + Out_Present => True), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uS), - Parameter_Type => - New_Occurrence_Of (Standard_Integer, Loc)), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uC), - Parameter_Type => + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc), - Out_Present => True))); + Out_Present => True))); return Make_Procedure_Specification (Loc, @@ -3004,9 +2961,8 @@ package body Exp_Disp is Make_Simple_Return_Statement (Loc, Expression => Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Address), Loc), - Expression => + Subtype_Mark => New_Occurrence_Of (RTE (RE_Address), Loc), + Expression => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uT), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)))); @@ -3019,19 +2975,15 @@ package body Exp_Disp is Ret := Make_Simple_Return_Statement (Loc, - Expression => - New_Occurrence_Of (RTE (RE_Null_Address), Loc)); + Expression => New_Occurrence_Of (RTE (RE_Null_Address), Loc)); end if; return Make_Subprogram_Body (Loc, - Specification => - Make_Disp_Get_Task_Id_Spec (Typ), - Declarations => - New_List, + Specification => Make_Disp_Get_Task_Id_Spec (Typ), + Declarations => New_List, Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - New_List (Ret))); + Make_Handled_Sequence_Of_Statements (Loc, New_List (Ret))); end Make_Disp_Get_Task_Id_Body; -------------------------------- @@ -3048,15 +3000,13 @@ package body Exp_Disp is return Make_Function_Specification (Loc, - Defining_Unit_Name => + Defining_Unit_Name => Make_Defining_Identifier (Loc, Name_uDisp_Get_Task_Id), Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uT), - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)); end Make_Disp_Get_Task_Id_Spec; @@ -3082,10 +3032,8 @@ package body Exp_Disp is then return Make_Subprogram_Body (Loc, - Specification => - Make_Disp_Requeue_Spec (Typ), - Declarations => - No_List, + Specification => Make_Disp_Requeue_Spec (Typ), + Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List (Make_Null_Statement (Loc)))); @@ -3125,8 +3073,8 @@ package body Exp_Disp is Make_Procedure_Call_Statement (Loc, Name => - New_Occurrence_Of ( - RTE (RE_Requeue_Protected_Entry), Loc), + New_Occurrence_Of + (RTE (RE_Requeue_Protected_Entry), Loc), Parameter_Associations => New_List ( @@ -3140,7 +3088,7 @@ package body Exp_Disp is Make_Attribute_Reference (Loc, -- O._object'Acc Attribute_Name => Name_Unchecked_Access, - Prefix => + Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uO), @@ -3149,8 +3097,8 @@ package body Exp_Disp is Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => - New_Occurrence_Of ( - RTE (RE_Protected_Entry_Index), Loc), + New_Occurrence_Of + (RTE (RE_Protected_Entry_Index), Loc), Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uA)))), -- abort status @@ -3162,30 +3110,29 @@ package body Exp_Disp is Make_Procedure_Call_Statement (Loc, Name => - New_Occurrence_Of ( - RTE (RE_Requeue_Task_To_Protected_Entry), Loc), + New_Occurrence_Of + (RTE (RE_Requeue_Task_To_Protected_Entry), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, -- O._object'Acc - Attribute_Name => - Name_Unchecked_Access, - Prefix => + Attribute_Name => Name_Unchecked_Access, + Prefix => Make_Selected_Component (Loc, - Prefix => + Prefix => Make_Identifier (Loc, Name_uO), Selector_Name => Make_Identifier (Loc, Name_uObject))), Make_Unchecked_Type_Conversion (Loc, -- entry index Subtype_Mark => - New_Occurrence_Of ( - RTE (RE_Protected_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + New_Occurrence_Of + (RTE (RE_Protected_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), Make_Identifier (Loc, Name_uA)))))); -- abort status end if; + else pragma Assert (Is_Task_Type (Conc_Typ)); @@ -3240,7 +3187,8 @@ package body Exp_Disp is -- Call to Requeue_Task_Entry Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc), + Name => + New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc), Parameter_Associations => New_List ( @@ -3261,10 +3209,8 @@ package body Exp_Disp is return Make_Subprogram_Body (Loc, - Specification => - Make_Disp_Requeue_Spec (Typ), - Declarations => - New_List, + Specification => Make_Disp_Requeue_Spec (Typ), + Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts)); end Make_Disp_Requeue_Body; @@ -3296,39 +3242,38 @@ package body Exp_Disp is Defining_Unit_Name => Make_Defining_Identifier (Loc, Name_uDisp_Requeue), - Parameter_Specifications => - New_List ( + Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, -- O Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), - Parameter_Type => + Parameter_Type => New_Occurrence_Of (Typ, Loc), - In_Present => True, - Out_Present => True), + In_Present => True, + Out_Present => True), Make_Parameter_Specification (Loc, -- F Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), - Parameter_Type => + Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc)), Make_Parameter_Specification (Loc, -- P Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), - Parameter_Type => + Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, -- I Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI), - Parameter_Type => + Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, -- A Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA), - Parameter_Type => + Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc)))); end Make_Disp_Requeue_Spec; @@ -3429,10 +3374,8 @@ package body Exp_Disp is if Is_Interface (Typ) then return Make_Subprogram_Body (Loc, - Specification => - Make_Disp_Timed_Select_Spec (Typ), - Declarations => - New_List, + Specification => Make_Disp_Timed_Select_Spec (Typ), + Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List ( @@ -3493,10 +3436,9 @@ package body Exp_Disp is Expression => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), - Parameter_Associations => - New_List ( - Tag_Node, - Make_Identifier (Loc, Name_uS))))); + Parameter_Associations => New_List ( + Tag_Node, + Make_Identifier (Loc, Name_uS))))); -- Protected case @@ -3539,21 +3481,19 @@ package body Exp_Disp is Name => New_Occurrence_Of (RTE (RE_Timed_Protected_Entry_Call), Loc), - Parameter_Associations => - New_List ( - Obj_Ref, + Parameter_Associations => New_List ( + Obj_Ref, - Make_Unchecked_Type_Conversion (Loc, -- entry index - Subtype_Mark => - New_Occurrence_Of - (RTE (RE_Protected_Entry_Index), Loc), - Expression => - Make_Identifier (Loc, Name_uI)), + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Protected_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), - Make_Identifier (Loc, Name_uP), -- parameter block - Make_Identifier (Loc, Name_uD), -- delay - Make_Identifier (Loc, Name_uM), -- delay mode - Make_Identifier (Loc, Name_uF)))); -- status flag + Make_Identifier (Loc, Name_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag when others => raise Program_Error; @@ -3579,24 +3519,23 @@ package body Exp_Disp is Append_To (Stmts, Make_Procedure_Call_Statement (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), - Parameter_Associations => - New_List ( - Make_Selected_Component (Loc, -- T._task_id - Prefix => Make_Identifier (Loc, Name_uT), - Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, -- T._task_id + Prefix => Make_Identifier (Loc, Name_uT), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), - Make_Unchecked_Type_Conversion (Loc, -- entry index - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), - Expression => Make_Identifier (Loc, Name_uI)), + Make_Unchecked_Type_Conversion (Loc, -- entry index + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), + Expression => Make_Identifier (Loc, Name_uI)), - Make_Identifier (Loc, Name_uP), -- parameter block - Make_Identifier (Loc, Name_uD), -- delay - Make_Identifier (Loc, Name_uM), -- delay mode - Make_Identifier (Loc, Name_uF)))); -- status flag + Make_Identifier (Loc, Name_uP), -- parameter block + Make_Identifier (Loc, Name_uD), -- delay + Make_Identifier (Loc, Name_uM), -- delay mode + Make_Identifier (Loc, Name_uF)))); -- status flag end if; else @@ -3647,51 +3586,38 @@ package body Exp_Disp is Append_List_To (Params, New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uT), - Parameter_Type => - New_Occurrence_Of (Typ, Loc), - In_Present => True, - Out_Present => True), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uT), + Parameter_Type => New_Occurrence_Of (Typ, Loc), + In_Present => True, + Out_Present => True), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uS), - Parameter_Type => - New_Occurrence_Of (Standard_Integer, Loc)), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), + Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uP), - Parameter_Type => - New_Occurrence_Of (RTE (RE_Address), Loc)), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP), + Parameter_Type => New_Occurrence_Of (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uD), - Parameter_Type => - New_Occurrence_Of (Standard_Duration, Loc)), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uD), + Parameter_Type => New_Occurrence_Of (Standard_Duration, Loc)), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uM), - Parameter_Type => - New_Occurrence_Of (Standard_Integer, Loc)), + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uM), + Parameter_Type => New_Occurrence_Of (Standard_Integer, Loc)), Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uC), - Parameter_Type => + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uC), + Parameter_Type => New_Occurrence_Of (RTE (RE_Prim_Op_Kind), Loc), - Out_Present => True))); + Out_Present => True))); Append_To (Params, Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uF), - Parameter_Type => - New_Occurrence_Of (Standard_Boolean, Loc), - Out_Present => True)); + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), + Out_Present => True)); return Make_Procedure_Specification (Loc, @@ -3704,17 +3630,17 @@ package body Exp_Disp is ------------- -- The frontend supports two models for expanding dispatch tables - -- associated with library-level defined tagged types: statically - -- and non-statically allocated dispatch tables. In the former case - -- the object containing the dispatch table is constant and it is - -- initialized by means of a positional aggregate. In the latter case, - -- the object containing the dispatch table is a variable which is - -- initialized by means of assignments. + -- associated with library-level defined tagged types: statically and + -- non-statically allocated dispatch tables. In the former case the object + -- containing the dispatch table is constant and it is initialized by means + -- of a positional aggregate. In the latter case, the object containing + -- the dispatch table is a variable which is initialized by means of + -- assignments. -- In case of locally defined tagged types, the object containing the - -- object containing the dispatch table is always a variable (instead - -- of a constant). This is currently required to give support to late - -- overriding of primitives. For example: + -- object containing the dispatch table is always a variable (instead of a + -- constant). This is currently required to give support to late overriding + -- of primitives. For example: -- procedure Example is -- package Pkg is @@ -3826,7 +3752,6 @@ package body Exp_Disp is or else not Used_As_Generic_Actual (T) then return False; - else Gen_Par := Generic_Parent (Parent (Current_Scope)); end if; @@ -3834,7 +3759,7 @@ package body Exp_Disp is F := First (Generic_Formal_Declarations - (Unit_Declaration_Node (Gen_Par))); + (Unit_Declaration_Node (Gen_Par))); while Present (F) loop if Ekind (Defining_Identifier (F)) = E_Incomplete_Type then return True; @@ -3864,8 +3789,8 @@ package body Exp_Disp is Error_Msg_NE ("declaration must appear after completion of type &", N, Typ); Error_Msg_NE - ("\which is an untagged type in the profile of" - & " primitive operation & declared#", N, Subp); + ("\which is an untagged type in the profile of " + & "primitive operation & declared#", N, Subp); else Comp := Private_Component (Typ); @@ -3873,19 +3798,18 @@ package body Exp_Disp is if not Is_Tagged_Type (Typ) and then Present (Comp) and then not Is_Frozen (Comp) - and then - not Is_Actual_For_Formal_Incomplete_Type (Comp) + and then not Is_Actual_For_Formal_Incomplete_Type (Comp) then Error_Msg_Sloc := Sloc (Subp); Error_Msg_Node_2 := Subp; Error_Msg_Name_1 := Chars (Tagged_Type); Error_Msg_NE ("declaration must appear after completion of type &", - N, Comp); + N, Comp); Error_Msg_NE - ("\which is a component of untagged type& in the profile of" - & " primitive & of type % that is frozen by the declaration ", - N, Typ); + ("\which is a component of untagged type& in the profile " + & "of primitive & of type % that is frozen by the " + & "declaration ", N, Typ); end if; end if; end Check_Premature_Freezing; @@ -4081,8 +4005,7 @@ package body Exp_Disp is end loop; New_Node := - Make_Aggregate (Loc, - Expressions => Prim_Ops_Aggr_List); + Make_Aggregate (Loc, Expressions => Prim_Ops_Aggr_List); -- Remember aggregates initializing dispatch tables @@ -4162,7 +4085,7 @@ package body Exp_Disp is Append_To (DT_Aggr_List, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Predef_Prims, Loc), + Prefix => New_Occurrence_Of (Predef_Prims, Loc), Attribute_Name => Name_Address)); -- Note: The correct value of Offset_To_Top will be set by the init @@ -4224,7 +4147,7 @@ package body Exp_Disp is Append_To (OSD_Aggr_List, Make_Component_Association (Loc, - Choices => New_List ( + Choices => New_List ( Make_Integer_Literal (Loc, DT_Position (Prim_Alias))), Expression => @@ -4249,7 +4172,7 @@ package body Exp_Disp is Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, Nb_Prim)))), @@ -4258,14 +4181,14 @@ package body Exp_Disp is Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, - Choices => New_List ( + Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), Expression => Make_Integer_Literal (Loc, Nb_Prim)), Make_Component_Association (Loc, - Choices => New_List ( + Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_OSD_Table), Loc)), Expression => Make_Aggregate (Loc, @@ -4277,7 +4200,7 @@ package body Exp_Disp is Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); @@ -4286,7 +4209,7 @@ package body Exp_Disp is Append_To (DT_Aggr_List, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (OSD, Loc), + Prefix => New_Occurrence_Of (OSD, Loc), Attribute_Name => Name_Address)); end if; @@ -4675,15 +4598,16 @@ package body Exp_Disp is -- Build the secondary table containing pointers to thunks Make_Secondary_DT - (Typ => Typ, - Iface => Base_Type (Related_Type (Node (AI_Tag_Comp))), - Suffix_Index => Suffix_Index, - Num_Iface_Prims => UI_To_Int - (DT_Entry_Count (Node (AI_Tag_Comp))), - Iface_DT_Ptr => Node (AI_Tag_Elmt), + (Typ => Typ, + Iface => Base_Type + (Related_Type (Node (AI_Tag_Comp))), + Suffix_Index => Suffix_Index, + Num_Iface_Prims => UI_To_Int + (DT_Entry_Count (Node (AI_Tag_Comp))), + Iface_DT_Ptr => Node (AI_Tag_Elmt), Predef_Prims_Ptr => Node (Next_Elmt (AI_Tag_Elmt)), - Build_Thunks => True, - Result => Result); + Build_Thunks => True, + Result => Result); -- Skip secondary dispatch table referencing thunks to predefined -- primitives. @@ -4762,7 +4686,7 @@ package body Exp_Disp is Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); @@ -4774,12 +4698,12 @@ package body Exp_Disp is Expression => Unchecked_Convert_To (RTE (RE_Tag), Make_Attribute_Reference (Loc, - Prefix => + Prefix => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (DT, Loc), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), + Prefix => New_Occurrence_Of (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); Set_Is_Statically_Allocated (DT_Ptr, @@ -4821,8 +4745,9 @@ package body Exp_Disp is Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Dispatch_Table_Wrapper), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => DT_Constr_List)))); + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => DT_Constr_List)))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, @@ -4830,7 +4755,7 @@ package body Exp_Disp is Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); @@ -4842,12 +4767,12 @@ package body Exp_Disp is Expression => Unchecked_Convert_To (RTE (RE_Tag), Make_Attribute_Reference (Loc, - Prefix => + Prefix => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (DT, Loc), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_Prims_Ptr), Loc)), + Prefix => New_Occurrence_Of (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); Set_Is_Statically_Allocated (DT_Ptr, @@ -4868,16 +4793,16 @@ package body Exp_Disp is Defining_Identifier => Node (Next_Elmt (First_Elmt (Access_Disp_Table (Typ)))), Constant_Present => True, - Object_Definition => New_Occurrence_Of - (RTE (RE_Address), Loc), + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc), Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (DT, Loc), - Selector_Name => - New_Occurrence_Of - (RTE_Record_Component (RE_Predef_Prims), Loc)), + Prefix => New_Occurrence_Of (DT, Loc), + Selector_Name => + New_Occurrence_Of + (RTE_Record_Component (RE_Predef_Prims), Loc)), Attribute_Name => Name_Address))); end if; end if; @@ -4893,8 +4818,7 @@ package body Exp_Disp is Object_Definition => New_Occurrence_Of (Standard_String, Loc), Expression => Make_String_Literal (Loc, - Fully_Qualified_Name_String (First_Subtype (Typ))))); - + Strval => Fully_Qualified_Name_String (First_Subtype (Typ))))); Set_Is_Statically_Allocated (Exname); Set_Is_True_Constant (Exname); @@ -4977,7 +4901,7 @@ package body Exp_Disp is else Append_To (TSD_Aggr_List, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), + Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Alignment)); end if; @@ -5020,14 +4944,13 @@ package body Exp_Disp is and then not Has_External_Tag_Rep_Clause (Typ) then declare - Exname : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_External_Name (Tname, 'A')); - - Full_Name : constant String_Id := + Exname : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Tname, 'A')); + Full_Name : constant String_Id := Fully_Qualified_Name_String (First_Subtype (Typ)); - Str1_Id : String_Id; - Str2_Id : String_Id; + Str1_Id : String_Id; + Str2_Id : String_Id; begin -- Generate: @@ -5058,11 +4981,10 @@ package body Exp_Disp is (Standard_String, Loc), Expression => Make_Op_Concat (Loc, - Left_Opnd => - Make_String_Literal (Loc, Str1_Id), + Left_Opnd => Make_String_Literal (Loc, Str1_Id), Right_Opnd => Make_Op_Concat (Loc, - Left_Opnd => + Left_Opnd => Make_Function_Call (Loc, Name => New_Occurrence_Of @@ -5078,20 +5000,18 @@ package body Exp_Disp is Make_Object_Declaration (Loc, Defining_Identifier => Exname, Constant_Present => True, - Object_Definition => New_Occurrence_Of - (Standard_String, Loc), - Expression => + Object_Definition => + New_Occurrence_Of (Standard_String, Loc), + Expression => Make_Op_Concat (Loc, - Left_Opnd => - Make_String_Literal (Loc, Str1_Id), - Right_Opnd => - Make_String_Literal (Loc, Str2_Id)))); + Left_Opnd => Make_String_Literal (Loc, Str1_Id), + Right_Opnd => Make_String_Literal (Loc, Str2_Id)))); end if; New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Exname, Loc), + Prefix => New_Occurrence_Of (Exname, Loc), Attribute_Name => Name_Address)); end; @@ -5160,7 +5080,7 @@ package body Exp_Disp is New_Node := Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (E, Loc), + Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Address)); end if; end; @@ -5174,7 +5094,7 @@ package body Exp_Disp is Append_To (TSD_Aggr_List, Unchecked_Convert_To (RTE (RE_Tag_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (HT_Link, Loc), + Prefix => New_Occurrence_Of (HT_Link, Loc), Attribute_Name => Name_Address))); else Append_To (TSD_Aggr_List, @@ -5195,7 +5115,7 @@ package body Exp_Disp is or else Is_Shared_Passive (Typ) or else ((Is_Remote_Types (Typ) - or else Is_Remote_Call_Interface (Typ)) + or else Is_Remote_Call_Interface (Typ)) and then Original_View_In_Visible_Part (Typ)) or else not Comes_From_Source (Typ)); @@ -5209,13 +5129,10 @@ package body Exp_Disp is if RTE_Record_Component_Available (RE_Type_Is_Abstract) then declare Type_Is_Abstract : Entity_Id; - begin - Type_Is_Abstract := - Boolean_Literals (Is_Abstract_Type (Typ)); - + Type_Is_Abstract := Boolean_Literals (Is_Abstract_Type (Typ)); Append_To (TSD_Aggr_List, - New_Occurrence_Of (Type_Is_Abstract, Loc)); + New_Occurrence_Of (Type_Is_Abstract, Loc)); end; end if; @@ -5224,7 +5141,6 @@ package body Exp_Disp is declare Needs_Fin : Entity_Id; - begin Needs_Fin := Boolean_Literals (Needs_Finalization (Typ)); Append_To (TSD_Aggr_List, New_Occurrence_Of (Needs_Fin, Loc)); @@ -5267,7 +5183,7 @@ package body Exp_Disp is Size_Comp := Unchecked_Convert_To (RTE (RE_Size_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Prim, Loc), + Prefix => New_Occurrence_Of (Prim, Loc), Attribute_Name => Name_Unrestricted_Access)); end if; @@ -5395,16 +5311,15 @@ package body Exp_Disp is Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Interface_Data), Loc), - Constraint => Make_Index_Or_Discriminant_Constraint - (Loc, - Constraints => New_List ( - Make_Integer_Literal (Loc, Num_Ifaces)))), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Integer_Literal (Loc, Num_Ifaces)))), - Expression => Make_Aggregate (Loc, + Expression => Make_Aggregate (Loc, Expressions => New_List ( Make_Integer_Literal (Loc, Num_Ifaces), - Make_Aggregate (Loc, - Expressions => TSD_Ifaces_List))))); + Make_Aggregate (Loc, TSD_Ifaces_List))))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, @@ -5412,7 +5327,7 @@ package body Exp_Disp is Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); @@ -5460,7 +5375,7 @@ package body Exp_Disp is Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); @@ -5469,7 +5384,7 @@ package body Exp_Disp is Append_To (TSD_Aggr_List, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (SSD, Loc), + Prefix => New_Occurrence_Of (SSD, Loc), Attribute_Name => Name_Unchecked_Access)); else Append_To (TSD_Aggr_List, Make_Null (Loc)); @@ -5572,7 +5487,8 @@ package body Exp_Disp is Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), + Prefix => + New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); -- Initialize or declare the dispatch table object @@ -5585,7 +5501,7 @@ package body Exp_Disp is New_Node := Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (TSD, Loc), + Prefix => New_Occurrence_Of (TSD, Loc), Attribute_Name => Name_Address); Append_To (DT_Constr_List, New_Node); @@ -5601,9 +5517,8 @@ package body Exp_Disp is if not Building_Static_DT (Typ) then Append_To (Result, Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (DT, Loc), - Expression => Make_Aggregate (Loc, - Expressions => DT_Aggr_List))); + Name => New_Occurrence_Of (DT, Loc), + Expression => Make_Aggregate (Loc, DT_Aggr_List))); -- In case of library level tagged types we declare and export now -- the constant object containing the dummy dispatch table. There @@ -5623,8 +5538,7 @@ package body Exp_Disp is Constant_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_No_Dispatch_Table_Wrapper), Loc), - Expression => Make_Aggregate (Loc, - Expressions => DT_Aggr_List))); + Expression => Make_Aggregate (Loc, DT_Aggr_List))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, @@ -5632,7 +5546,7 @@ package body Exp_Disp is Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); @@ -5725,7 +5639,8 @@ package body Exp_Disp is New_Node := Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Prim_Table (J), Loc), + Prefix => + New_Occurrence_Of (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); else New_Node := Make_Null (Loc); @@ -5751,8 +5666,8 @@ package body Exp_Disp is Defining_Identifier => Predef_Prims, Aliased_Present => True, Constant_Present => Building_Static_DT (Typ), - Object_Definition => New_Occurrence_Of - (Defining_Identifier (Decl), Loc), + Object_Definition => + New_Occurrence_Of (Defining_Identifier (Decl), Loc), Expression => New_Node)); -- Remember aggregates initializing dispatch tables @@ -5765,7 +5680,7 @@ package body Exp_Disp is Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); end; @@ -5805,7 +5720,7 @@ package body Exp_Disp is Append_To (DT_Aggr_List, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Predef_Prims, Loc), + Prefix => New_Occurrence_Of (Predef_Prims, Loc), Attribute_Name => Name_Address)); -- Offset_To_Top @@ -5816,7 +5731,7 @@ package body Exp_Disp is Append_To (DT_Aggr_List, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (TSD, Loc), + Prefix => New_Occurrence_Of (TSD, Loc), Attribute_Name => Name_Address)); -- Stage 2: Initialize the table of user-defined primitive operations @@ -5883,7 +5798,8 @@ package body Exp_Disp is New_Node := Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Prim_Table (J), Loc), + Prefix => + New_Occurrence_Of (Prim_Table (J), Loc), Attribute_Name => Name_Unrestricted_Access)); else New_Node := Make_Null (Loc); @@ -5911,9 +5827,8 @@ package body Exp_Disp is if not Building_Static_DT (Typ) then Append_To (Result, Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (DT, Loc), - Expression => Make_Aggregate (Loc, - Expressions => DT_Aggr_List))); + Name => New_Occurrence_Of (DT, Loc), + Expression => Make_Aggregate (Loc, DT_Aggr_List))); -- In case of library level tagged types we declare now and export -- the constant object containing the dispatch table. @@ -5930,8 +5845,7 @@ package body Exp_Disp is (RTE (RE_Dispatch_Table_Wrapper), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)), - Expression => Make_Aggregate (Loc, - Expressions => DT_Aggr_List))); + Expression => Make_Aggregate (Loc, DT_Aggr_List))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, @@ -5939,7 +5853,7 @@ package body Exp_Disp is Chars => Name_Alignment, Expression => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (RTE (RE_Integer_Address), Loc), Attribute_Name => Name_Alignment))); @@ -5956,12 +5870,11 @@ package body Exp_Disp is then Append_To (Result, Make_Assignment_Statement (Loc, - Name => + Name => Make_Indexed_Component (Loc, - Prefix => + Prefix => Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (TSD, Loc), + Prefix => New_Occurrence_Of (TSD, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Tags_Table), Loc)), @@ -6011,15 +5924,15 @@ package body Exp_Disp is Old_Tag_Node => New_Occurrence_Of (Node - (Next_Elmt - (First_Elmt - (Access_Disp_Table (Parent_Typ)))), Loc), + (Next_Elmt + (First_Elmt + (Access_Disp_Table (Parent_Typ)))), Loc), New_Tag_Node => New_Occurrence_Of (Node - (Next_Elmt - (First_Elmt - (Access_Disp_Table (Typ)))), Loc))); + (Next_Elmt + (First_Elmt + (Access_Disp_Table (Typ)))), Loc))); if Nb_Prims /= 0 then Append_To (Elab_Code, @@ -6028,8 +5941,8 @@ package body Exp_Disp is Old_Tag_Node => New_Occurrence_Of (Node - (First_Elmt - (Access_Disp_Table (Parent_Typ))), Loc), + (First_Elmt + (Access_Disp_Table (Parent_Typ))), Loc), New_Tag_Node => New_Occurrence_Of (DT_Ptr, Loc), Num_Prims => Nb_Prims)); end if; @@ -6042,14 +5955,15 @@ package body Exp_Disp is declare Sec_DT_Ancestor : Elmt_Id := Next_Elmt - (Next_Elmt - (First_Elmt - (Access_Disp_Table (Parent_Typ)))); + (Next_Elmt + (First_Elmt + (Access_Disp_Table + (Parent_Typ)))); Sec_DT_Typ : Elmt_Id := Next_Elmt - (Next_Elmt - (First_Elmt - (Access_Disp_Table (Typ)))); + (Next_Elmt + (First_Elmt + (Access_Disp_Table (Typ)))); procedure Copy_Secondary_DTs (Typ : Entity_Id); -- Local procedure required to climb through the ancestors @@ -6256,7 +6170,8 @@ package body Exp_Disp is then Append_To (Elab_Code, Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Register_Tag), Loc), + Name => + New_Occurrence_Of (RTE (RE_Register_Tag), Loc), Parameter_Associations => New_List (New_Occurrence_Of (DT_Ptr, Loc)))); end if; @@ -6439,7 +6354,7 @@ package body Exp_Disp is Append_To (OSD_Aggr_List, Make_Component_Association (Loc, - Choices => New_List ( + Choices => New_List ( Make_Integer_Literal (Loc, DT_Position (Prim_Alias))), Expression => @@ -6452,6 +6367,7 @@ package body Exp_Disp is Next_Elmt (Prim_Elmt); end loop; + pragma Assert (Count = Nb_Prim); end; @@ -6466,7 +6382,7 @@ package body Exp_Disp is Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Object_Specific_Data), Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, Nb_Prim)))), @@ -6475,14 +6391,14 @@ package body Exp_Disp is Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, - Choices => New_List ( + Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), Expression => Make_Integer_Literal (Loc, Nb_Prim)), Make_Component_Association (Loc, - Choices => New_List ( + Choices => New_List ( New_Occurrence_Of (RTE_Record_Component (RE_OSD_Table), Loc)), Expression => Make_Aggregate (Loc, @@ -7171,8 +7087,7 @@ package body Exp_Disp is Set_Ekind (DT_Ptr, E_Variable); Set_Related_Type (DT_Ptr, Typ); - -- Notify the back end that the types are associated with a dispatch - -- table + -- Notify back end that the types are associated with a dispatch table Set_Is_Dispatch_Table_Entity (RTE (RE_Prim_Ptr)); Set_Is_Dispatch_Table_Entity (RTE (RE_Predef_Prims_Table_Ptr)); @@ -7307,9 +7222,8 @@ package body Exp_Disp is Suffix_Index := 1; - -- Note: The value of Suffix_Index must be in sync with the - -- Suffix_Index values of secondary dispatch tables generated - -- by Make_DT. + -- Note: The value of Suffix_Index must be in sync with the values of + -- Suffix_Index in secondary dispatch tables generated by Make_DT. if Is_CPP_Class (Typ) then AI_Tag_Comp := First_Elmt (Typ_Comps); @@ -7318,8 +7232,7 @@ package body Exp_Disp is (Typ, Related_Type (Node (AI_Tag_Comp)), Suffix_Index); Typ_Name := Name_Find; - -- Declare variables that will store the copy of the C++ - -- secondary tags. + -- Declare variables to store copy of the C++ secondary tags Iface_DT_Ptr := Make_Defining_Identifier (Loc, @@ -7528,6 +7441,7 @@ package body Exp_Disp is -- Add the freezing nodes of these declarations; required to avoid -- generating these freezing nodes in wrong scopes (for example in -- the IC routine of a derivation of Typ). + -- What is an "IC routine"? Is "init_proc" meant here??? Append_List_To (Result, Freeze_Entity (DT_Prims, Typ)); @@ -7573,9 +7487,7 @@ package body Exp_Disp is Res : constant Node_Id := Duplicate_Subexpr (From); begin if Is_Access_Type (Etype (From)) then - return - Make_Explicit_Dereference (Sloc (From), - Prefix => Res); + return Make_Explicit_Dereference (Sloc (From), Prefix => Res); else return Res; end if; @@ -7786,6 +7698,7 @@ package body Exp_Disp is end if; -- Ada 2005 (AI-251): Primitive associated with an interface type + -- Generate the code of the thunk only if the interface type is not an -- immediate ancestor of Typ; otherwise the dispatch table associated -- with the interface is the primary dispatch table and we have nothing @@ -7914,9 +7827,8 @@ package body Exp_Disp is -- predefined primitives procedure Validate_Position (Prim : Entity_Id); - -- Check that the position assigned to Prim is completely safe - -- (it has not been assigned to a previously defined primitive - -- operation of Typ) + -- Check that position assigned to Prim is completely safe (it has not + -- been assigned to a previously defined primitive operation of Typ). ------------------------ -- In_Predef_Prims_DT -- @@ -8011,7 +7923,6 @@ package body Exp_Disp is and then not Is_Predefined_Dispatching_Alias (Op) and then not Is_Predefined_Dispatching_Alias (Prim) then - -- Handle aliased subprograms declare @@ -8074,9 +7985,8 @@ package body Exp_Disp is -- Set the DT_Position for each primitive operation. Perform some sanity -- checks to avoid building inconsistent dispatch tables. - -- First stage: Set the DTC entity of all the primitive operations. This - -- is required to properly read the DT_Position attribute in the latter - -- stages. + -- First stage: Set DTC entity of all the primitive operations. This is + -- required to properly read the DT_Position attribute in latter stages. Prim_Elmt := First_Prim; Count_Prim := 0; @@ -8261,9 +8171,9 @@ package body Exp_Disp is Next_Elmt (Prim_Elmt); end loop; - -- Third stage: Fix the position of all the new primitives. - -- Entries associated with primitives covering interfaces - -- are handled in a latter round. + -- Third stage: Fix the position of all the new primitives. Entries + -- associated with primitives covering interfaces are handled in a + -- latter round. Prim_Elmt := First_Prim; while Present (Prim_Elmt) loop @@ -8297,8 +8207,8 @@ package body Exp_Disp is end; -- Fourth stage: Complete the decoration of primitives covering - -- interfaces (that is, propagate the DT_Position attribute - -- from the aliased primitive) + -- interfaces (that is, propagate the DT_Position attribute from + -- the aliased primitive) Prim_Elmt := First_Prim; while Present (Prim_Elmt) loop @@ -8332,10 +8242,10 @@ package body Exp_Disp is Next_Elmt (Prim_Elmt); end loop; - -- Generate listing showing the contents of the dispatch tables. - -- This action is done before some further static checks because - -- in case of critical errors caused by a wrong dispatch table - -- we need to see the contents of such table. + -- Generate listing showing the contents of the dispatch tables. This + -- action is done before some further static checks because in case of + -- critical errors caused by a wrong dispatch table we need to see the + -- contents of such table. if Debug_Flag_ZZ then Write_DT (Typ); @@ -8349,8 +8259,8 @@ package body Exp_Disp is while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); - -- At this point all the primitives MUST have a position - -- in the dispatch table. + -- At this point all the primitives MUST have a position in the + -- dispatch table. if DT_Position (Prim) = No_Uint then raise Program_Error; @@ -8364,8 +8274,8 @@ package body Exp_Disp is DT_Length := UI_To_Int (DT_Position (Prim)); end if; - -- Ensure that the assigned position to non-predefined - -- dispatching operations in the dispatch table is correct. + -- Ensure that the assigned position to non-predefined dispatching + -- operations in the dispatch table is correct. if not Is_Predefined_Dispatching_Operation (Prim) and then not Is_Predefined_Dispatching_Alias (Prim) @@ -8391,8 +8301,8 @@ package body Exp_Disp is -- excluded from this check because interfaces must be visible in -- the public and private part (RM 7.3 (7.3/2)) - -- We disable this check in Relaxed_RM_Semantics mode, to - -- accommodate legacy Ada code. + -- We disable this check in Relaxed_RM_Semantics mode, to accommodate + -- legacy Ada code. if not Relaxed_RM_Semantics and then Is_Abstract_Type (Typ) @@ -8409,9 +8319,8 @@ package body Exp_Disp is and then Original_View_In_Visible_Part (Typ) then -- We exclude Input and Output stream operations because - -- Limited_Controlled inherits useless Input and Output - -- stream operations from Root_Controlled, which can - -- never be overridden. + -- Limited_Controlled inherits useless Input and Output stream + -- operations from Root_Controlled, which can never be overridden. if not Is_TSS (Prim, TSS_Stream_Input) and then @@ -8464,6 +8373,10 @@ package body Exp_Disp is -- Duplicate the parameters profile of the imported C++ constructor -- adding an access to the object as an additional parameter. + ---------------------------- + -- Gen_Parameters_Profile -- + ---------------------------- + function Gen_Parameters_Profile (E : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (E); Parms : List_Id; @@ -8682,10 +8595,10 @@ package body Exp_Disp is end; end if; - -- If this constructor has parameters and all its parameters - -- have defaults then it covers the default constructor. The - -- semantic analyzer ensures that only one constructor with - -- defaults covers the default constructor. + -- If this constructor has parameters and all its parameters have + -- defaults then it covers the default constructor. The semantic + -- analyzer ensures that only one constructor with defaults covers + -- the default constructor. if Present (Parameter_Specifications (Parent (E))) and then Needs_No_Actuals (E) @@ -8935,7 +8848,7 @@ package body Exp_Disp is end if; -- Display the final position of this primitive in its associated - -- (primary or secondary) dispatch table + -- (primary or secondary) dispatch table. if Present (DTC_Entity (Prim)) and then DT_Position (Prim) /= No_Uint diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index ae8a390..78778a0 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -1162,18 +1162,15 @@ package body Exp_Dist is return Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_NVList_Add_Item), Loc), + Name => + New_Occurrence_Of (RTE (RE_NVList_Add_Item), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (NVList, Loc), Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_To_PolyORB_String), Loc), + Name => + New_Occurrence_Of (RTE (RE_To_PolyORB_String), Loc), Parameter_Associations => New_List ( - Make_String_Literal (Loc, - Strval => Parameter_Name_String))), + Make_String_Literal (Loc, Strval => Parameter_Name_String))), New_Occurrence_Of (Any, Loc), Parameter_Mode)); end Add_Parameter_To_NVList; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5a18f3e..26e2e0d 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1131,25 +1131,16 @@ package body Freeze is Attribute_Scalar_Storage_Order); Comp_ADC_Present := Present (Comp_ADC); - -- Case of enclosing type not having explicit SSO: component cannot - -- have it either. + -- Case of record or array component: check storage order compatibility - if No (ADC) then - if Comp_ADC_Present then - Error_Msg_N - ("composite type must have explicit scalar storage order", - Err_Node); - end if; - - -- Case of enclosing type having explicit SSO: check compatible - -- attribute on Comp_Type if composite. - - elsif Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then + if Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then Comp_SSO_Differs := Reverse_Storage_Order (Encl_Type) /= Reverse_Storage_Order (Comp_Type); + -- Parent and extension must have same storage order + if Present (Comp) and then Chars (Comp) = Name_uParent then if Comp_SSO_Differs then Error_Msg_N @@ -1157,10 +1148,16 @@ package body Freeze is & "parent", Err_Node); end if; - elsif No (Comp_ADC) then + -- If enclosing composite has explicit SSO then nested composite must + -- have explicit SSO as well. + + elsif Present (ADC) and then No (Comp_ADC) then Error_Msg_N ("nested composite must have explicit scalar " & "storage order", Err_Node); + -- If component and composite SSO differs, check that component + -- falls on byte boundaries and isn't packed. + elsif Comp_SSO_Differs then -- Component SSO differs from enclosing composite: @@ -1182,10 +1179,10 @@ package body Freeze is end if; end if; - -- Enclosing type has explicit SSO, non-composite component must not + -- Enclosing type has explicit SSO: non-composite component must not -- be aliased. - elsif Component_Aliased then + elsif Present (ADC) and then Component_Aliased then Error_Msg_N ("aliased component not permitted for type with " & "explicit Scalar_Storage_Order", Err_Node); diff --git a/gcc/ada/g-pehage.ads b/gcc/ada/g-pehage.ads index 54ecf6e..67875a6 100644 --- a/gcc/ada/g-pehage.ads +++ b/gcc/ada/g-pehage.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2010, AdaCore -- +-- Copyright (C) 2002-2014, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -121,8 +121,8 @@ package GNAT.Perfect_Hash_Generators is -- Raised after Tries unsuccessful runs procedure Compute (Position : String := Default_Position); - -- Compute the hash function. Position allows to define selection of - -- character positions used in the word hash function. Positions can be + -- Compute the hash function. Position allows the definition of selection + -- of character positions used in the word hash function. Positions can be -- separated by commas and ranges like x-y may be used. Character '$' -- represents the final character of a word. With an empty position, the -- generator automatically produces positions to reduce the memory usage. diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 876e535..7df5af0 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2013, AdaCore -- +-- Copyright (C) 2001-2014, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -759,8 +759,8 @@ package GNAT.Sockets is end case; end record; - -- A request flag allows to specify the type of message transmissions or - -- receptions. A request flag can be combination of zero or more + -- A request flag allows specification of the type of message transmissions + -- or receptions. A request flag can be combination of zero or more -- predefined request flags. type Request_Flag_Type is private; @@ -904,7 +904,7 @@ package GNAT.Sockets is -- Item'First - 1 when the socket has been closed by peer. This is not -- an error, and no exception is raised in this case unless Item'First -- is Stream_Element_Offset'First, in which case Constraint_Error is - -- raised. Flags allows to control the reception. Raise Socket_Error on + -- raised. Flags allows control of the reception. Raise Socket_Error on -- error. procedure Receive_Socket @@ -916,7 +916,7 @@ package GNAT.Sockets is -- Receive message from Socket. If Socket is not connection-oriented, the -- source address From of the message is filled in. Last is the index -- value such that Item (Last) is the last character assigned. Flags - -- allows to control the reception. Raises Socket_Error on error. + -- allows control of the reception. Raises Socket_Error on error. procedure Receive_Vector (Socket : Socket_Type; @@ -958,7 +958,7 @@ package GNAT.Sockets is Last : out Ada.Streams.Stream_Element_Offset; Flags : Request_Flag_Type := No_Request_Flag); -- Transmit a message over a socket. Upon return, Last is set to the index - -- within Item of the last element transmitted. Flags allows to control + -- within Item of the last element transmitted. Flags allows control of -- the transmission. Raises Socket_Error on any detected error condition. procedure Send_Socket @@ -968,7 +968,7 @@ package GNAT.Sockets is To : Sock_Addr_Type; Flags : Request_Flag_Type := No_Request_Flag); -- Transmit a message over a datagram socket. The destination address is - -- To. Flags allows to control the transmission. Raises Socket_Error on + -- To. Flags allows control of the transmission. Raises Socket_Error on -- error. procedure Send_Vector @@ -1027,8 +1027,8 @@ package GNAT.Sockets is -- subprogram when the stream is not needed anymore. type Socket_Set_Type is limited private; - -- This type allows to manipulate sets of sockets. It allows to wait for - -- events on multiple endpoints at one time. This type has default + -- This type allows manipulation of sets of sockets. It allows waiting + -- for events on multiple endpoints at one time. This type has default -- initialization, and the default value is the empty set. -- -- Note: This type used to contain a pointer to dynamically allocated @@ -1072,8 +1072,8 @@ package GNAT.Sockets is -- Check_Selector provides the very same behaviour. The only difference is -- that it does not watch for exception events. Note that on some platforms -- it is kept process blocking on purpose. The timeout parameter allows the - -- user to have the behaviour he wants. Abort_Selector allows to safely - -- abort a blocked Check_Selector call. A special socket is opened by + -- user to have the behaviour he wants. Abort_Selector allows the safe + -- abort of a blocked Check_Selector call. A special socket is opened by -- Create_Selector and included in each call to Check_Selector. -- -- Abort_Selector causes an event to occur on this descriptor in order to diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index b0b3907..854e26e 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -9303,9 +9303,8 @@ that make up scalar components are ordered within S: -- the former is used. @end smallexample -Other properties are -as for standard representation attribute @code{Bit_Order}, as defined by -Ada RM 13.5.3(4). The default is @code{System.Default_Bit_Order}. +Other properties are as for standard representation attribute @code{Bit_Order}, +as defined by Ada RM 13.5.3(4). The default is @code{System.Default_Bit_Order}. For a record type @var{S}, if @code{@var{S}'Scalar_Storage_Order} is specified explicitly, it shall be equal to @code{@var{S}'Bit_Order}. Note: @@ -9316,18 +9315,15 @@ specified explicitly and set to the same value. For a record extension, the derived type shall have the same scalar storage order as the parent type. -If a component of @var{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 is a packed array, or does not start on a byte boundary, then -the scalar storage order specified for S and for the nested component type shall -be identical. +If a component of @var{S} is of a record or array type, then that type shall +also have a @code{Scalar_Storage_Order} attribute definition clause. -If @var{S} appears as the type of a record or array component, the enclosing -record or array shall also have a @code{Scalar_Storage_Order} attribute -definition clause. +A component of a record or array type that is a packed array, or that +does not start on a byte boundary, must have the same scalar storage order +as the enclosing record or array type. -No component of a type that has a @code{Scalar_Storage_Order} attribute -definition may be aliased. +No component of a type that has an explicit @code{Scalar_Storage_Order} +attribute definition may be aliased. A confirming @code{Scalar_Storage_Order} attribute definition clause (i.e. with a value equal to @code{System.Default_Bit_Order}) has no effect. diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 51a8bd4..2132a8b 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -1,3 +1,4 @@ + \input texinfo @c -*-texinfo-*- @c %**start of header @@ -18765,11 +18766,11 @@ leak. @noindent @code{gnatmem} makes use of the output created by the special version of -allocation and deallocation routines that record call information. This -allows to obtain accurate dynamic memory usage history at a minimal cost to -the execution speed. Note however, that @code{gnatmem} is not supported on -all platforms (currently, it is supported on AIX, HP-UX, GNU/Linux, -Solaris and Windows NT/2000/XP (x86). +allocation and deallocation routines that record call information. This allows +it to obtain accurate dynamic memory usage history at a minimal cost to the +execution speed. Note however, that @code{gnatmem} is not supported on all +platforms (currently, it is supported on AIX, HP-UX, GNU/Linux, Solaris and +Windows NT/2000/XP (x86). @noindent The @code{gnatmem} command has the form @@ -18894,8 +18895,8 @@ Do the @code{gnatmem} processing starting from @file{file}, rather than @item -m n @cindex @option{-m} (@code{gnatmem}) This switch causes @code{gnatmem} to mask the allocation roots that have less -than n leaks. The default value is 1. Specifying the value of 0 will allow to -examine even the roots that didn't result in leaks. +than n leaks. The default value is 1. Specifying the value of 0 will allow +examination of even the roots that did not result in leaks. @item -s order @cindex @option{-s} (@code{gnatmem}) @@ -21636,9 +21637,9 @@ breakpoint condition (before the @code{if}). @item task @var{taskno} @cindex Task switching -This command allows to switch to the task referred by @var{taskno}. In -particular, This allows to browse the backtrace of the specified -task. It is advised to switch back to the original task before +This command allows switching to the task referred by @var{taskno}. In +particular, this allows browsing of the backtrace of the specified +task. It is advisable to switch back to the original task before continuing execution otherwise the scheduling of the program may be perturbed. @end table diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 48319d6..587638b 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2013, Free Software Foundation, Inc. * + * Copyright (C) 1992-2014, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -1922,7 +1922,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) #include "sigtramp.h" __gnat_sigtramp (sig, (void *)si, (void *)sc, - (sighandler_t *)&__gnat_map_signal); + (__sigtramphandler_t *)&__gnat_map_signal); #else __gnat_map_signal (sig, si, sc); @@ -2372,12 +2372,23 @@ __gnat_install_handler (void) /*******************/ #include <signal.h> -#include <stdlib.h> +#include "sigtramp.h" + +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) +{ + mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; + + /* ARM Bump has to be an even number because of odd/even architecture. */ + ((mcontext_t *) mcontext)->arm_pc += 2; +} static void -__gnat_error_handler (int sig, - siginfo_t *si ATTRIBUTE_UNUSED, - void *ucontext ATTRIBUTE_UNUSED) +__gnat_map_signal (int sig, + siginfo_t *si ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) { struct Exception_Data *exception; const char *msg; @@ -2407,6 +2418,17 @@ __gnat_error_handler (int sig, Raise_From_Signal_Handler (exception, msg); } +static void +__gnat_error_handler (int sig, + siginfo_t *si ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) +{ + __gnat_adjust_context_for_raise (sig, ucontext); + + __gnat_sigtramp (sig, (void *) si, (void *) ucontext, + (__sigtramphandler_t *)&__gnat_map_signal); +} + /* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */ char __gnat_alternate_stack[16 * 1024]; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index f8377f4..8ccdda6 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -67,7 +67,7 @@ package body Scng is procedure Accumulate_Token_Checksum; pragma Inline (Accumulate_Token_Checksum); -- Called after each numeric literal and identifier/keyword. For keywords, - -- the token used is Tok_Identifier. This allows to detect additional + -- the token used is Tok_Identifier. This allows detection of additional -- spaces added in sources when using the builder switch -m. procedure Accumulate_Token_Checksum_GNAT_6_3; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 1de265d..48d442b 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3904,10 +3904,10 @@ package body Sem_Attr is Context : constant Node_Id := Parent (N); Attr : Node_Id; Enclosing_Loop : Node_Id; - In_Loop_Assertion : Boolean := False; Loop_Id : Entity_Id := Empty; Scop : Entity_Id; Stmt : Node_Id; + Enclosing_Pragma : Node_Id := Empty; -- Start of processing for Loop_Entry @@ -4025,7 +4025,7 @@ package body Sem_Attr is Name_Assert_And_Cut, Name_Assume) then - In_Loop_Assertion := True; + Enclosing_Pragma := Original_Node (Stmt); -- Locate the enclosing loop (if any). Note that Ada 2012 array -- iteration may be expanded into several nested loops, we are @@ -4060,12 +4060,11 @@ package body Sem_Attr is -- purpose if they appear in an appropriate location in a loop, -- which was already checked by the top level pragma circuit). - if not In_Loop_Assertion then - Error_Attr - ("attribute % must appear within appropriate pragma", N); + if No (Enclosing_Pragma) then + Error_Attr ("attribute% must appear within appropriate pragma", N); end if; - -- A Loop_Entry that applies to a given loop statement shall not + -- A Loop_Entry that applies to a given loop statement must not -- appear within a body of accept statement, if this construct is -- itself enclosed by the given loop statement. @@ -4074,10 +4073,8 @@ package body Sem_Attr is if Ekind (Scop) = E_Loop and then Scop = Loop_Id then exit; - elsif Ekind_In (Scop, E_Block, E_Loop, E_Return_Statement) then null; - else Error_Attr ("attribute % cannot appear in body or accept statement", N); @@ -4101,14 +4098,28 @@ package body Sem_Attr is null; elsif Present (Enclosing_Loop) - and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id + and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id then - Error_Attr_P ("prefix of attribute % that applies to " - & "outer loop must denote an entity"); + Error_Attr_P + ("prefix of attribute % that applies to " + & "outer loop must denote an entity"); elsif Is_Potentially_Unevaluated (P) then - Error_Attr_P ("prefix of attribute % that is potentially " - & "unevaluated must denote an entity"); + Error_Attr_P + ("prefix of attribute % that is potentially " + & "unevaluated must denote an entity"); + end if; + + -- Finally, if the Loop_Entry attribute appears within a pragma + -- that is ignored, we replace P'Loop_Entity by P to avoid useless + -- generation of the loop entity variable. Note that in this case + -- the expression won't be executed anyway, and this substitution + -- keeps types happy! + + -- We should really do this in the expander, but it's easier here + + if Is_Ignored (Enclosing_Pragma) then + Rewrite (N, Relocate_Node (P)); end if; end Loop_Entry; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 072383e..b2544d6 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -14669,6 +14669,7 @@ package body Sem_Util is return Name; end Original_Aspect_Name; + -------------------------------------- -- Original_Corresponding_Operation -- -------------------------------------- diff --git a/gcc/ada/sigtramp-armvxw.c b/gcc/ada/sigtramp-armvxw.c index 176be21..cbe774f 100644 --- a/gcc/ada/sigtramp-armvxw.c +++ b/gcc/ada/sigtramp-armvxw.c @@ -6,7 +6,7 @@ * * * Asm Implementation File * * * - * Copyright (C) 2013, Free Software Foundation, Inc. * + * Copyright (C) 2014, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -49,7 +49,7 @@ sequences. The general idea is to establish CFA as sigcontext->sc_pregs and state where to find the registers as offsets from there. - As of today, we support a single stub, providing CFI info for common + As of today, we support a stub providing CFI info for common registers (GPRs, LR, ...). We might need variants with support for floating point or altivec registers as well at some point. @@ -75,7 +75,7 @@ extern void __gnat_sigtramp_common (int signo, void *siginfo, void *sigcontext, - sighandler_t * handler, void * sc_pregs); + __sigtramphandler_t * handler, void * sc_pregs); /* ------------------------------------- @@ -85,11 +85,11 @@ extern void __gnat_sigtramp_common We enforce optimization to minimize the overhead of the extra layer. */ void __gnat_sigtramp (int signo, void *si, void *sc, - sighandler_t * handler) + __sigtramphandler_t * handler) __attribute__((optimize(2))); void __gnat_sigtramp (int signo, void *si, void *sc, - sighandler_t * handler) + __sigtramphandler_t * handler) { struct sigcontext * sctx = (struct sigcontext *) sc; diff --git a/gcc/ada/sigtramp-ppcvxw.c b/gcc/ada/sigtramp-ppcvxw.c index 0432b08..ff2f0a8 100644 --- a/gcc/ada/sigtramp-ppcvxw.c +++ b/gcc/ada/sigtramp-ppcvxw.c @@ -6,7 +6,7 @@ * * * Asm Implementation File * * * - * Copyright (C) 2011-2013, Free Software Foundation, Inc. * + * Copyright (C) 2011-2014, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -49,7 +49,7 @@ sequences. The general idea is to establish CFA as sigcontext->sc_pregs and state where to find the registers as offsets from there. - As of today, we support a single stub, providing CFI info for common + As of today, we support a stub providing CFI info for common registers (GPRs, LR, ...). We might need variants with support for floating point or altivec registers as well at some point. @@ -75,7 +75,7 @@ extern void __gnat_sigtramp_common (int signo, void *siginfo, void *sigcontext, - sighandler_t * handler, void * sc_pregs); + __sigtramphandler_t * handler, void * sc_pregs); /* ------------------------------------- @@ -85,11 +85,11 @@ extern void __gnat_sigtramp_common We enforce optimization to minimize the overhead of the extra layer. */ void __gnat_sigtramp (int signo, void *si, void *sc, - sighandler_t * handler) + __sigtramphandler_t * handler) __attribute__((optimize(2))); void __gnat_sigtramp (int signo, void *si, void *sc, - sighandler_t * handler) + __sigtramphandler_t * handler) { struct sigcontext * sctx = (struct sigcontext *) sc; |