diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-10-11 10:43:04 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2010-10-11 10:43:04 +0000 |
| commit | d74fc39a48322ac04f88391b52f72fdd5ec6dd92 (patch) | |
| tree | 8193b0facbe2ccdb239a536cc0e48b413a954d64 /gcc/ada | |
| parent | ae888dbd6f5b381d5661b8242edafbd85ce7947c (diff) | |
| download | gcc-d74fc39a48322ac04f88391b52f72fdd5ec6dd92.tar.gz | |
2010-10-11 Robert Dewar <dewar@adacore.com>
* g-htable.ads (Get_First): New procedural version for Simple_HTable
(Get_Next): New procedural version for Simple_HTable
* s-htable.adb (Get_First): New procedural version for Simple_HTable
(Get_Next): New procedural version for Simple_HTable
* s-htable.ads (Get_First): New procedural version for Simple_HTable
(Get_Next): New procedural version for Simple_HTable
2010-10-11 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Propagate_Discriminants): To gather the components of a
variant part, use the association list of the subaggregate, which
already includes the values of the needed discriminants.
2010-10-11 Robert Dewar <dewar@adacore.com>
* aspects.ads, aspects.adb: Changes to accomodate aspect delay
(Tree_Write): New procedure.
* atree.ads, atree.adb: Flag3 is now Has_Aspects and applies to all
nodes.
* atree.h: Flag3 is now Has_Aspects and applies to all nodes
* debug.adb: Add debug flag gnatd.A
* einfo.adb (Has_Delayed_Aspects): New flag
(Get_Rep_Item_For_Entity): New function
* einfo.ads (Has_Delayed_Aspects): New flag
(Get_Rep_Item_For_Entity): New function
* exp_ch13.adb (Expand_N_Freeze_Entity): Insert delayed aspects into
tree.
* exp_ch3.adb, exp_ch6.adb, exp_ch9.adb, exp_disp.adb: New calling
sequence for Freeze_Entity.
* freeze.ads, freeze.adb (Freeze_Entity): Takes node rather than source
ptr. All calls are changed to this new interface.
(Freeze_And_Append): Same change
(Freeze_Entity): Evaluate deferred aspects
* sem_attr.adb: New calling sequence for Freeze_Entity
(Eval_Attribute): Don't try to evaluate attributes of unfrozen types
when we are in spec expression preanalysis mode.
* sem_ch10.adb: New calling sequence for Freeze_Entity
* sem_ch11.adb: Simplify analysis of aspect specifications now that the
flag Has_Aspects applies to all nodes (no need to save aspects).
* sem_ch12.adb: Simplify analysis of aspect specifications now that the
flag Has_Aspects applies to all nodes (no need to save aspects).
* sem_ch13.adb (Analyze_Aspect_Specifications): Major rewrite to
accomodate delaying aspect evaluation to the freeze point.
(Duplicate_Clause): Simplify using Get_Rep_Item_For_Entity, and also
accomodate delayed aspects.
(Rep_Item_Too_Late): Deal with delayed aspects case
* sem_ch13.ads (Rep_Item_Too_Late): Document handling of delayed aspects
* sem_ch3.adb (Analyze_Subtype_Declaration): Make sure that generic
actual types are properly frozen (this is needed because of the new
check in Eval_Attribute that declines to evaluate attributes
for unfrozen types).
Simplify analysis of aspect specifications now that the flag
Has_Aspects applies to all nodes (no need to save aspects).
* sem_ch3.ads (Preanalyze_Spec_Expression): Note use for delayed aspects
* sem_ch5.adb: Simplify analysis of aspect specifications now that the
flag Has_Aspects applies to all nodes (no need to save aspects).
New calling sequence for Freeze_Entity.
* sem_ch9.adb, sem_ch7.adb, sem_ch6.adb: Simplify analysis of aspect
specifications now that the flag Has_Aspects applies to all nodes
(no need to save aspects).
New calling sequence for Freeze_Entity
* sem_prag.adb (Check_Duplicate_Pragma): Simplify using
Get_Rep_Item_For_Entity
(Get_Pragma_Arg): Moved to Sinfo
* sinfo.ads, sinfo.adb (Aspect_Rep_Item_: New field
(Is_Delayed_Aspect): New flag
(Next_Rep_Item): Document use for aspects
(Get_Pragma_Arg): Moved here from Sem_Prag
* sprint.adb (Sprint_Aspect_Specifications): Now called after semicolon
is output and removes semicolon (simplifies interface).
(Sprint_Node_Actual): Simplify handling of aspects now that Has_Aspects
applies to any node.
* tree_gen.adb: Write contents of Aspect_Specifications hash table
* tree_in.adb: Read and initialize Aspect_Specifications hash table
* treepr.adb (Print_Node): Print Has_Aspects flag
(Print_Node): Print Aspect_Specifications in Has_Aspects set
* xtreeprs.adb: Remove obsolete references to Flag1,2,3
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165300 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
40 files changed, 1093 insertions, 580 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fe541b0506f..2282a299380 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,85 @@ 2010-10-11 Robert Dewar <dewar@adacore.com> + * g-htable.ads (Get_First): New procedural version for Simple_HTable + (Get_Next): New procedural version for Simple_HTable + * s-htable.adb (Get_First): New procedural version for Simple_HTable + (Get_Next): New procedural version for Simple_HTable + * s-htable.ads (Get_First): New procedural version for Simple_HTable + (Get_Next): New procedural version for Simple_HTable + +2010-10-11 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb (Propagate_Discriminants): To gather the components of a + variant part, use the association list of the subaggregate, which + already includes the values of the needed discriminants. + +2010-10-11 Robert Dewar <dewar@adacore.com> + + * aspects.ads, aspects.adb: Changes to accomodate aspect delay + (Tree_Write): New procedure. + * atree.ads, atree.adb: Flag3 is now Has_Aspects and applies to all + nodes. + * atree.h: Flag3 is now Has_Aspects and applies to all nodes + * debug.adb: Add debug flag gnatd.A + * einfo.adb (Has_Delayed_Aspects): New flag + (Get_Rep_Item_For_Entity): New function + * einfo.ads (Has_Delayed_Aspects): New flag + (Get_Rep_Item_For_Entity): New function + * exp_ch13.adb (Expand_N_Freeze_Entity): Insert delayed aspects into + tree. + * exp_ch3.adb, exp_ch6.adb, exp_ch9.adb, exp_disp.adb: New calling + sequence for Freeze_Entity. + * freeze.ads, freeze.adb (Freeze_Entity): Takes node rather than source + ptr. All calls are changed to this new interface. + (Freeze_And_Append): Same change + (Freeze_Entity): Evaluate deferred aspects + * sem_attr.adb: New calling sequence for Freeze_Entity + (Eval_Attribute): Don't try to evaluate attributes of unfrozen types + when we are in spec expression preanalysis mode. + * sem_ch10.adb: New calling sequence for Freeze_Entity + * sem_ch11.adb: Simplify analysis of aspect specifications now that the + flag Has_Aspects applies to all nodes (no need to save aspects). + * sem_ch12.adb: Simplify analysis of aspect specifications now that the + flag Has_Aspects applies to all nodes (no need to save aspects). + * sem_ch13.adb (Analyze_Aspect_Specifications): Major rewrite to + accomodate delaying aspect evaluation to the freeze point. + (Duplicate_Clause): Simplify using Get_Rep_Item_For_Entity, and also + accomodate delayed aspects. + (Rep_Item_Too_Late): Deal with delayed aspects case + * sem_ch13.ads (Rep_Item_Too_Late): Document handling of delayed aspects + * sem_ch3.adb (Analyze_Subtype_Declaration): Make sure that generic + actual types are properly frozen (this is needed because of the new + check in Eval_Attribute that declines to evaluate attributes + for unfrozen types). + Simplify analysis of aspect specifications now that the flag + Has_Aspects applies to all nodes (no need to save aspects). + * sem_ch3.ads (Preanalyze_Spec_Expression): Note use for delayed aspects + * sem_ch5.adb: Simplify analysis of aspect specifications now that the + flag Has_Aspects applies to all nodes (no need to save aspects). + New calling sequence for Freeze_Entity. + * sem_ch9.adb, sem_ch7.adb, sem_ch6.adb: Simplify analysis of aspect + specifications now that the flag Has_Aspects applies to all nodes + (no need to save aspects). + New calling sequence for Freeze_Entity + * sem_prag.adb (Check_Duplicate_Pragma): Simplify using + Get_Rep_Item_For_Entity + (Get_Pragma_Arg): Moved to Sinfo + * sinfo.ads, sinfo.adb (Aspect_Rep_Item_: New field + (Is_Delayed_Aspect): New flag + (Next_Rep_Item): Document use for aspects + (Get_Pragma_Arg): Moved here from Sem_Prag + * sprint.adb (Sprint_Aspect_Specifications): Now called after semicolon + is output and removes semicolon (simplifies interface). + (Sprint_Node_Actual): Simplify handling of aspects now that Has_Aspects + applies to any node. + * tree_gen.adb: Write contents of Aspect_Specifications hash table + * tree_in.adb: Read and initialize Aspect_Specifications hash table + * treepr.adb (Print_Node): Print Has_Aspects flag + (Print_Node): Print Aspect_Specifications in Has_Aspects set + * xtreeprs.adb: Remove obsolete references to Flag1,2,3 + +2010-10-11 Robert Dewar <dewar@adacore.com> + * aspects.ads, aspects.adb: Major revision of this package for 2nd stage of aspects implementation. * gcc-interface/Make-lang.in: Add entry for aspects.o diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 4b08632c57f..d951c5aadb1 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -29,10 +29,11 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; -with Nlists; use Nlists; -with Sinfo; use Sinfo; -with Snames; use Snames; +with Atree; use Atree; +with Nlists; use Nlists; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Tree_IO; use Tree_IO; with GNAT.HTable; use GNAT.HTable; @@ -152,7 +153,11 @@ package body Aspects is function Aspect_Specifications (N : Node_Id) return List_Id is begin - return Aspect_Specifications_Hash_Table.Get (N); + if Has_Aspects (N) then + return Aspect_Specifications_Hash_Table.Get (N); + else + return No_List; + end if; end Aspect_Specifications; ----------------------------------- @@ -199,14 +204,47 @@ package body Aspects is procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id) is begin pragma Assert (Permits_Aspect_Specifications (N)); - pragma Assert (not Has_Aspect_Specifications (N)); + pragma Assert (not Has_Aspects (N)); pragma Assert (L /= No_List); - Set_Has_Aspect_Specifications (N); + Set_Has_Aspects (N); Set_Parent (L, N); Aspect_Specifications_Hash_Table.Set (N, L); end Set_Aspect_Specifications; + --------------- + -- Tree_Read -- + --------------- + + procedure Tree_Read is + Node : Node_Id; + List : List_Id; + begin + loop + Tree_Read_Int (Int (Node)); + Tree_Read_Int (Int (List)); + exit when List = No_List; + Set_Aspect_Specifications (Node, List); + end loop; + end Tree_Read; + + ---------------- + -- Tree_Write -- + ---------------- + + procedure Tree_Write is + Node : Node_Id := Empty; + List : List_Id; + begin + Aspect_Specifications_Hash_Table.Get_First (Node, List); + loop + Tree_Write_Int (Int (Node)); + Tree_Write_Int (Int (List)); + exit when List = No_List; + Aspect_Specifications_Hash_Table.Get_Next (Node, List); + end loop; + end Tree_Write; + -- Package initialization sets up Aspect Id hash table begin diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index b8ee3888a20..3289d22d60f 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -168,27 +168,37 @@ package Aspects is function Permits_Aspect_Specifications (N : Node_Id) return Boolean; -- Returns True if the node N is a declaration node that permits aspect - -- specifications. All such nodes have the Has_Aspect_Specifications - -- flag defined. Returns False for all other nodes. + -- specifications in the grammar. It is possible for other nodes to have + -- aspect specifications as a result of Rewrite or Replace calls. function Aspect_Specifications (N : Node_Id) return List_Id; -- Given a node N, returns the list of N_Aspect_Specification nodes that -- are attached to this declaration node. If the node is in the class of -- declaration nodes that permit aspect specifications, as defined by the - -- predicate above, and if their Has_Aspect_Specifications flag is set to - -- True, then this will always be a non-empty list. If this flag is set to - -- False, or the node is not in the declaration class permitting aspect - -- specifications, then No_List is returned. + -- predicate above, and if their Has_Aspects flag is set to True, then this + -- will always be a non-empty list. If this flag is set to False, then + -- No_List is returned. Normally, the only nodes that have Has_Aspects set + -- True are the nodes for which Permits_Aspect_Specifications would return + -- True (i.e. the declaration nodes defined in the RM as permitting the + -- presence of Aspect_Specifications). However, it is possible for the + -- flag Has_Aspects to be set on other nodes as a result of Rewrite and + -- Replace calls, and this function may be used to retrive the aspect + -- specifications for the original rewritten node in such cases. procedure Set_Aspect_Specifications (N : Node_Id; L : List_Id); -- The node N must be in the class of declaration nodes that permit aspect - -- specifications and the Has_Aspect_Specifications flag must be False on - -- entry. L must be a non-empty list of N_Aspect_Specification nodes. This - -- procedure sets the Has_Aspect_Specifications flag to True, and makes an - -- entry that can be retrieved by a subsequent Aspect_Specifications call. - -- The parent of list L is set to reference the declaration node N. It is - -- an error to call this procedure with a node that does not permit aspect - -- specifications, or a node that has its Has_Aspect_Specifications flag - -- set True on entry, or with L being an empty list or No_List. + -- specifications and the Has_Aspects flag must be False on entry. L must + -- be a non-empty list of N_Aspect_Specification nodes. This procedure sets + -- the Has_Aspects flag to True, and makes an entry that can be retrieved + -- by a subsequent Aspect_Specifications call. It is an error to call this + -- procedure with a node that does not permit aspect specifications, or a + -- node that has its Has_Aspects flag set True on entry, or with L being an + -- empty list or No_List. + + procedure Tree_Write; + -- Writes contents of Aspect_Specifications hash table to the tree file + + procedure Tree_Read; + -- Reads contents of Aspect_Specificatins hash table from the tree file end Aspects; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 47ca88ef980..2a54d63e7ec 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -36,6 +36,7 @@ pragma Style_Checks (All_Checks); -- file must be properly reflected in the file atree.h which is a C header -- file containing equivalent definitions for use by gigi. +with Aspects; use Aspects; with Debug; use Debug; with Nlists; use Nlists; with Output; use Output; @@ -1087,6 +1088,16 @@ package body Atree is return Default_Node.Comes_From_Source; end Get_Comes_From_Source_Default; + ----------------- + -- Has_Aspects -- + ----------------- + + function Has_Aspects (N : Node_Id) return Boolean is + begin + pragma Assert (N <= Nodes.Last); + return Nodes.Table (N).Has_Aspects; + end Has_Aspects; + ------------------- -- Has_Extension -- ------------------- @@ -1563,20 +1574,22 @@ package body Atree is ------------- procedure Replace (Old_Node, New_Node : Node_Id) is - Old_Post : constant Boolean := Nodes.Table (Old_Node).Error_Posted; - Old_CFS : constant Boolean := Nodes.Table (Old_Node).Comes_From_Source; + Old_Post : constant Boolean := Nodes.Table (Old_Node).Error_Posted; + Old_HasA : constant Boolean := Nodes.Table (Old_Node).Has_Aspects; + Old_CFS : constant Boolean := Nodes.Table (Old_Node).Comes_From_Source; begin pragma Assert (not Has_Extension (Old_Node) - and not Has_Extension (New_Node) - and not Nodes.Table (New_Node).In_List); + and not Has_Extension (New_Node) + and not Nodes.Table (New_Node).In_List); - -- Do copy, preserving link and in list status and comes from source + -- Do copy, preserving link and in list status and required flags Copy_Node (Source => New_Node, Destination => Old_Node); Nodes.Table (Old_Node).Comes_From_Source := Old_CFS; Nodes.Table (Old_Node).Error_Posted := Old_Post; + Nodes.Table (Old_Node).Has_Aspects := Old_HasA; -- Fix parents of substituted node, since it has changed identity @@ -1601,7 +1614,10 @@ package body Atree is procedure Rewrite (Old_Node, New_Node : Node_Id) is Old_Error_P : constant Boolean := Nodes.Table (Old_Node).Error_Posted; - -- This fields is always preserved in the new node + -- This field is always preserved in the new node + + Old_Has_Aspects : constant Boolean := Nodes.Table (Old_Node).Has_Aspects; + -- This field is always preserved in the new node Old_Paren_Count : Nat; Old_Must_Not_Freeze : Boolean; @@ -1616,15 +1632,15 @@ package body Atree is begin pragma Assert (not Has_Extension (Old_Node) - and not Has_Extension (New_Node) - and not Nodes.Table (New_Node).In_List); + and not Has_Extension (New_Node) + and not Nodes.Table (New_Node).In_List); pragma Debug (Rewrite_Debugging_Output (Old_Node, New_Node)); if Nkind (Old_Node) in N_Subexpr then Old_Paren_Count := Paren_Count (Old_Node); Old_Must_Not_Freeze := Must_Not_Freeze (Old_Node); else - Old_Paren_Count := 0; + Old_Paren_Count := 0; Old_Must_Not_Freeze := False; end if; @@ -1638,12 +1654,21 @@ package body Atree is Sav_Node := New_Copy (Old_Node); Orig_Nodes.Table (Sav_Node) := Sav_Node; Orig_Nodes.Table (Old_Node) := Sav_Node; + + -- Both the old and new copies of the node will share the same list + -- of aspect specifications if aspect specifications are present. + + if Has_Aspects (Sav_Node) then + Set_Aspect_Specifications + (Sav_Node, Aspect_Specifications (Old_Node)); + end if; end if; -- Copy substitute node into place, preserving old fields as required Copy_Node (Source => New_Node, Destination => Old_Node); Nodes.Table (Old_Node).Error_Posted := Old_Error_P; + Nodes.Table (Old_Node).Has_Aspects := Old_Has_Aspects; if Nkind (New_Node) in N_Subexpr then Set_Paren_Count (Old_Node, Old_Paren_Count); @@ -1737,6 +1762,16 @@ package body Atree is end Set_Error_Posted; --------------------- + -- Set_Has_Aspects -- + --------------------- + + procedure Set_Has_Aspects (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (N <= Nodes.Last); + Nodes.Table (N).Has_Aspects := Val; + end Set_Has_Aspects; + + --------------------- -- Set_Paren_Count -- --------------------- @@ -2704,12 +2739,6 @@ package body Atree is return From_Union (Nodes.Table (N + 3).Field8); end Ureal21; - function Flag3 (N : Node_Id) return Boolean is - begin - pragma Assert (N <= Nodes.Last); - return Nodes.Table (N).Flag3; - end Flag3; - function Flag4 (N : Node_Id) return Boolean is begin pragma Assert (N <= Nodes.Last); @@ -2809,7 +2838,7 @@ package body Atree is function Flag20 (N : Node_Id) return Boolean is begin pragma Assert (Nkind (N) in N_Entity); - return Nodes.Table (N + 1).Flag3; + return Nodes.Table (N + 1).Has_Aspects; end Flag20; function Flag21 (N : Node_Id) return Boolean is @@ -2935,7 +2964,7 @@ package body Atree is function Flag41 (N : Node_Id) return Boolean is begin pragma Assert (Nkind (N) in N_Entity); - return Nodes.Table (N + 2).Flag3; + return Nodes.Table (N + 2).Has_Aspects; end Flag41; function Flag42 (N : Node_Id) return Boolean is @@ -3469,7 +3498,7 @@ package body Atree is function Flag130 (N : Node_Id) return Boolean is begin pragma Assert (Nkind (N) in N_Entity); - return Nodes.Table (N + 3).Flag3; + return Nodes.Table (N + 3).Has_Aspects; end Flag130; function Flag131 (N : Node_Id) return Boolean is @@ -3991,7 +4020,7 @@ package body Atree is function Flag217 (N : Node_Id) return Boolean is begin pragma Assert (Nkind (N) in N_Entity); - return Nodes.Table (N + 4).Flag3; + return Nodes.Table (N + 4).Has_Aspects; end Flag217; function Flag218 (N : Node_Id) return Boolean is @@ -4812,12 +4841,6 @@ package body Atree is Nodes.Table (N + 3).Field8 := To_Union (Val); end Set_Ureal21; - procedure Set_Flag3 (N : Node_Id; Val : Boolean) is - begin - pragma Assert (N <= Nodes.Last); - Nodes.Table (N).Flag3 := Val; - end Set_Flag3; - procedure Set_Flag4 (N : Node_Id; Val : Boolean) is begin pragma Assert (N <= Nodes.Last); @@ -4917,7 +4940,7 @@ package body Atree is procedure Set_Flag20 (N : Node_Id; Val : Boolean) is begin pragma Assert (Nkind (N) in N_Entity); - Nodes.Table (N + 1).Flag3 := Val; + Nodes.Table (N + 1).Has_Aspects := Val; end Set_Flag20; procedure Set_Flag21 (N : Node_Id; Val : Boolean) is @@ -5043,7 +5066,7 @@ package body Atree is procedure Set_Flag41 (N : Node_Id; Val : Boolean) is begin pragma Assert (Nkind (N) in N_Entity); - Nodes.Table (N + 2).Flag3 := Val; + Nodes.Table (N + 2).Has_Aspects := Val; end Set_Flag41; procedure Set_Flag42 (N : Node_Id; Val : Boolean) is @@ -5705,7 +5728,7 @@ package body Atree is procedure Set_Flag130 (N : Node_Id; Val : Boolean) is begin pragma Assert (Nkind (N) in N_Entity); - Nodes.Table (N + 3).Flag3 := Val; + Nodes.Table (N + 3).Has_Aspects := Val; end Set_Flag130; procedure Set_Flag131 (N : Node_Id; Val : Boolean) is @@ -6355,7 +6378,7 @@ package body Atree is procedure Set_Flag217 (N : Node_Id; Val : Boolean) is begin pragma Assert (Nkind (N) in N_Entity); - Nodes.Table (N + 4).Flag3 := Val; + Nodes.Table (N + 4).Has_Aspects := Val; end Set_Flag217; procedure Set_Flag218 (N : Node_Id; Val : Boolean) is diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 9e29a57a59e..8b81ade2454 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -151,7 +151,6 @@ package Atree is -- it is useful to be able to do untyped traversals, and an internal -- package in Atree allows for direct untyped accesses in such cases. - -- Flag3 -- Flag4 Sixteen Boolean flags (use depends on Nkind and -- Flag5 Ekind, as described for FieldN). Again the access -- Flag6 is usually via subprograms in Sinfo and Einfo which @@ -293,7 +292,7 @@ package Atree is ------------------------------------- -- A subpackage Atree.Unchecked_Access provides routines for reading and - -- writing the fields defined above (Field1-27, Node1-27, Flag3-254 etc). + -- writing the fields defined above (Field1-27, Node1-27, Flag4-254 etc). -- These unchecked access routines can be used for untyped traversals. -- In addition they are used in the implementations of the Sinfo and -- Einfo packages. These packages both provide logical synonyms for @@ -518,6 +517,9 @@ package Atree is function Analyzed (N : Node_Id) return Boolean; pragma Inline (Analyzed); + function Has_Aspects (N : Node_Id) return Boolean; + pragma Inline (Has_Aspects); + function Comes_From_Source (N : Node_Id) return Boolean; pragma Inline (Comes_From_Source); @@ -750,6 +752,9 @@ package Atree is -- unusual cases, the value needs to be reset (e.g. when a source -- node is copied, and the copy must not have Comes_From_Source set. + procedure Set_Has_Aspects (N : Node_Id; Val : Boolean := True); + pragma Inline (Set_Has_Aspects); + ------------------------------ -- Entity Update Procedures -- ------------------------------ @@ -1196,9 +1201,6 @@ package Atree is function Ureal21 (N : Node_Id) return Ureal; pragma Inline (Ureal21); - function Flag3 (N : Node_Id) return Boolean; - pragma Inline (Flag3); - function Flag4 (N : Node_Id) return Boolean; pragma Inline (Flag4); @@ -2254,9 +2256,6 @@ package Atree is procedure Set_Ureal21 (N : Node_Id; Val : Ureal); pragma Inline (Set_Ureal21); - procedure Set_Flag3 (N : Node_Id; Val : Boolean); - pragma Inline (Set_Flag3); - procedure Set_Flag4 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag4); @@ -3091,7 +3090,9 @@ package Atree is -- Flag used to indicate if node is a member of a list. -- This field is considered private to the Atree package. - Flag3 : Boolean; + Has_Aspects : Boolean; + -- Flag used to indicate that a node has aspect specifications that + -- are associated with the node. See Aspects package for details. Rewrite_Ins : Boolean; -- Flag set by Mark_Rewrite_Insertion procedure. @@ -3126,32 +3127,31 @@ package Atree is -- The eighteen flags for a normal node -- The above fields are used as follows in components 2-5 of - -- an extended node entry. These fields are not currently - -- used in component 5 (where we still have lots of room!) - - -- In_List used as Flag19, Flag40, Flag129, Flag216 - -- Flag3 used as Flag20, Flag41, Flag130, Flag217 - -- Rewrite_Ins used as Flag21, Flag42, Flag131, Flag218 - -- Analyzed used as Flag22, Flag43, Flag132, Flag219 - -- Comes_From_Source used as Flag23, Flag44, Flag133, Flag220 - -- Error_Posted used as Flag24, Flag45, Flag134, Flag221 - -- Flag4 used as Flag25, Flag46, Flag135, Flag222 - -- Flag5 used as Flag26, Flag47, Flag136, Flag223 - -- Flag6 used as Flag27, Flag48, Flag137, Flag224 - -- Flag7 used as Flag28, Flag49, Flag138, Flag225 - -- Flag8 used as Flag29, Flag50, Flag139, Flag226 - -- Flag9 used as Flag30, Flag51, Flag140, Flag227 - -- Flag10 used as Flag31, Flag52, Flag141, Flag228 - -- Flag11 used as Flag32, Flag53, Flag142, Flag229 - -- Flag12 used as Flag33, Flag54, Flag143, Flag230 - -- Flag13 used as Flag34, Flag55, Flag144, Flag231 - -- Flag14 used as Flag35, Flag56, Flag145, Flag232 - -- Flag15 used as Flag36, Flag57, Flag146, Flag233 - -- Flag16 used as Flag37, Flag58, Flag147, Flag234 - -- Flag17 used as Flag38, Flag59, Flag148, Flag235 - -- Flag18 used as Flag39, Flag60, Flag149, Flag236 - -- Pflag1 used as Flag61, Flag62, Flag150, Flag237 - -- Pflag2 used as Flag63, Flag64, Flag151, Flag238 + -- an extended node entry. + + -- In_List used as Flag19, Flag40, Flag129, Flag216 + -- Has_Aspects used as Flag20, Flag41, Flag130, Flag217 + -- Rewrite_Ins used as Flag21, Flag42, Flag131, Flag218 + -- Analyzed used as Flag22, Flag43, Flag132, Flag219 + -- Comes_From_Source used as Flag23, Flag44, Flag133, Flag220 + -- Error_Posted used as Flag24, Flag45, Flag134, Flag221 + -- Flag4 used as Flag25, Flag46, Flag135, Flag222 + -- Flag5 used as Flag26, Flag47, Flag136, Flag223 + -- Flag6 used as Flag27, Flag48, Flag137, Flag224 + -- Flag7 used as Flag28, Flag49, Flag138, Flag225 + -- Flag8 used as Flag29, Flag50, Flag139, Flag226 + -- Flag9 used as Flag30, Flag51, Flag140, Flag227 + -- Flag10 used as Flag31, Flag52, Flag141, Flag228 + -- Flag11 used as Flag32, Flag53, Flag142, Flag229 + -- Flag12 used as Flag33, Flag54, Flag143, Flag230 + -- Flag13 used as Flag34, Flag55, Flag144, Flag231 + -- Flag14 used as Flag35, Flag56, Flag145, Flag232 + -- Flag15 used as Flag36, Flag57, Flag146, Flag233 + -- Flag16 used as Flag37, Flag58, Flag147, Flag234 + -- Flag17 used as Flag38, Flag59, Flag148, Flag235 + -- Flag18 used as Flag39, Flag60, Flag149, Flag236 + -- Pflag1 used as Flag61, Flag62, Flag150, Flag237 + -- Pflag2 used as Flag63, Flag64, Flag151, Flag238 Nkind : Node_Kind; -- For a non-extended node, or the initial section of an extended @@ -3245,7 +3245,7 @@ package Atree is Pflag1 => False, Pflag2 => False, In_List => False, - Flag3 => False, + Has_Aspects => False, Rewrite_Ins => False, Analyzed => False, Comes_From_Source => False, @@ -3290,7 +3290,7 @@ package Atree is Pflag1 => False, Pflag2 => False, In_List => False, - Flag3 => False, + Has_Aspects => False, Rewrite_Ins => False, Analyzed => False, Comes_From_Source => False, diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index d7375e00146..447338fefeb 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -40,7 +40,7 @@ struct NFK Boolean pflag1 : 1; Boolean pflag2 : 1; Boolean in_list : 1; - Boolean flag3 : 1; + Boolean has_aspects : 1; Boolean rewrite_ins : 1; Boolean analyzed : 1; Boolean c_f_s : 1; @@ -75,7 +75,7 @@ struct NFNK Boolean pflag1 : 1; Boolean pflag2 : 1; Boolean in_list : 1; - Boolean flag3 : 1; + Boolean has_aspects : 1; Boolean rewrite_ins : 1; Boolean analyzed : 1; Boolean c_f_s : 1; @@ -466,10 +466,10 @@ extern Node_Id Current_Error_Node; #define Analyzed(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.analyzed) #define Comes_From_Source(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.c_f_s) #define Error_Posted(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.error_posted) +#define Has_Aspects(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.has_aspects) #define Convention(N) \ (Nodes_Ptr[(N) - First_Node_Id + 2].V.EX.U.fw.convention) -#define Flag3(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag3) #define Flag4(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag4) #define Flag5(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag5) #define Flag6(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag6) @@ -487,7 +487,7 @@ extern Node_Id Current_Error_Node; #define Flag18(N) (Nodes_Ptr[(N) - First_Node_Id].U.K.flag18) #define Flag19(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.in_list) -#define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag3) +#define Flag20(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.has_aspects) #define Flag21(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.rewrite_ins) #define Flag22(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.analyzed) #define Flag23(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.c_f_s) @@ -509,7 +509,7 @@ extern Node_Id Current_Error_Node; #define Flag39(N) (Nodes_Ptr[(N) - First_Node_Id + 1].U.K.flag18) #define Flag40(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.in_list) -#define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.flag3) +#define Flag41(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.has_aspects) #define Flag42(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.rewrite_ins) #define Flag43(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.analyzed) #define Flag44(N) (Nodes_Ptr[(N) - First_Node_Id + 2].U.K.c_f_s) @@ -601,7 +601,7 @@ extern Node_Id Current_Error_Node; #define Flag128(N) (Nodes_Ptr[(N) - First_Node_Id + 3].V.EX.U.fw2.flag128) #define Flag129(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.in_list) -#define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.flag3) +#define Flag130(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.has_aspects) #define Flag131(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.rewrite_ins) #define Flag132(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.analyzed) #define Flag133(N) (Nodes_Ptr[(N) - First_Node_Id + 3].U.K.c_f_s) @@ -691,7 +691,7 @@ extern Node_Id Current_Error_Node; #define Flag215(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw4.flag215) #define Flag216(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.in_list) -#define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.flag3) +#define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.has_aspects) #define Flag218(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.rewrite_ins) #define Flag219(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.analyzed) #define Flag220(N) (Nodes_Ptr[(N) - First_Node_Id + 4].U.K.c_f_s) diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 41657c4d28c..a22b52147c5 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -118,7 +118,7 @@ package body Debug is -- d.y -- d.z - -- d.A + -- d.A Properly defer address aspect -- d.B -- d.C Generate concatenation call, do not generate inline code -- d.D @@ -558,6 +558,12 @@ package body Debug is -- d.w This flag turns off the scanning of loops to detect possible -- infinite loops. + -- d.A Properly defer address aspect. In the case where the expression + -- of an address aspect is non-static, we should defer the evaluation + -- of the expression till the freeze point, but this does not seem to + -- work properly. So we have this debug switch temporarily so that we + -- can easily investigate this problem. + -- d.x No exception handlers in generated code. This causes exception -- handlers to be eliminated from the generated code. They are still -- fully compiled and analyzed, they just get eliminated from the diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 9612408d71b..8c583238314 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -459,6 +459,7 @@ package body Einfo is -- Has_Pragma_Ordered Flag198 -- Is_Ada_2012_Only Flag199 + -- Has_Delayed_Aspects Flag200 -- Has_Anon_Block_Suffix Flag201 -- Itype_Printed Flag202 -- Has_Pragma_Pure Flag203 @@ -510,8 +511,6 @@ package body Einfo is -- Is_Underlying_Record_View Flag246 -- OK_To_Rename Flag247 - -- (unused) Flag3 - -- (unused) Flag200 -- (unused) Flag232 -- (unused) Flag248 @@ -580,18 +579,6 @@ package body Einfo is return Flag104 (Id); end Address_Taken; - function Aft_Value (Id : E) return U is - Result : Nat := 1; - Delta_Val : Ureal := Delta_Value (Id); - begin - while Delta_Val < Ureal_Tenth loop - Delta_Val := Delta_Val * Ureal_10; - Result := Result + 1; - end loop; - - return UI_From_Int (Result); - end Aft_Value; - function Alias (Id : E) return E is begin pragma Assert @@ -1220,6 +1207,12 @@ package body Einfo is return Flag119 (Id); end Has_Convention_Pragma; + function Has_Delayed_Aspects (Id : E) return B is + begin + pragma Assert (Nkind (Id) in N_Entity); + return Flag200 (Id); + end Has_Delayed_Aspects; + function Has_Delayed_Freeze (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -3628,6 +3621,12 @@ package body Einfo is Set_Flag119 (Id, V); end Set_Has_Convention_Pragma; + procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is + begin + pragma Assert (Nkind (Id) in N_Entity); + Set_Flag200 (Id, V); + end Set_Has_Delayed_Aspects; + procedure Set_Has_Delayed_Freeze (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -5476,6 +5475,22 @@ package body Einfo is return Rep_Clause (Id, Name_Address); end Address_Clause; + --------------- + -- Aft_Value -- + --------------- + + function Aft_Value (Id : E) return U is + Result : Nat := 1; + Delta_Val : Ureal := Delta_Value (Id); + begin + while Delta_Val < Ureal_Tenth loop + Delta_Val := Delta_Val * Ureal_10; + Result := Result + 1; + end loop; + + return UI_From_Int (Result); + end Aft_Value; + ---------------------- -- Alignment_Clause -- ---------------------- @@ -5802,6 +5817,46 @@ package body Einfo is return Empty; end Get_Record_Representation_Clause; + ----------------------------- + -- Get_Rep_Item_For_Entity -- + ----------------------------- + + function Get_Rep_Item_For_Entity + (E : Entity_Id; + Nam : Name_Id) return Node_Id + is + N : Node_Id; + Arg : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then + Arg := Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); + + if Is_Entity_Name (Arg) and then Entity (Arg) = E then + return N; + end if; + + elsif Nkind (N) = N_Attribute_Definition_Clause + and then Chars (N) = Nam + and then Entity (N) = E + then + return N; + + elsif Nkind (N) = N_Aspect_Specification + and then Chars (Identifier (N)) = Nam + and then Entity (N) = E + then + return N; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Rep_Item_For_Entity; + -------------------- -- Get_Rep_Pragma -- -------------------- @@ -6899,6 +6954,7 @@ package body Einfo is W ("Has_Controlled_Component", Flag43 (Id)); W ("Has_Controlling_Result", Flag98 (Id)); W ("Has_Convention_Pragma", Flag119 (Id)); + W ("Has_Delayed_Aspects", Flag200 (Id)); W ("Has_Delayed_Freeze", Flag18 (Id)); W ("Has_Discriminants", Flag5 (Id)); W ("Has_Enumeration_Rep_Clause", Flag66 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 40c0c81f3f1..ea2a20862e3 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -264,8 +264,8 @@ package Einfo is -- on the actions triggered by a freeze node, which include the construction -- of initialization procedures and dispatch tables. --- b) The presence of a freeze node on an entity is used by the backend to --- defer elaboration of the entity until its freeze node is seen. In the +-- b) The presence of a freeze node on an entity is used by the backend to +-- defer elaboration of the entity until its freeze node is seen. In the -- absence of an explicit freeze node, an entity is frozen (and elaborated) -- at the point of declaration. @@ -1391,6 +1391,12 @@ package Einfo is -- Convention, Import, or Export pragma has been given. Used to prevent -- more than one such pragma appearing for a given entity (RM B.1(45)). +-- Has_Delayed_Aspects (Flag200) Present in all entities. Set true if the +-- Rep_Item chain for the entity has one or more N_Aspect_Definition +-- nodes chained which are not to be evaluated till the freeze point. +-- The aspect definition expression clause has been preanalyzed to get +-- visibility at the point of use, but no other action has been taken. + -- Has_Delayed_Freeze (Flag18) -- Present in all entities. Set to indicate that an explicit freeze -- node must be generated for the entity at its freezing point. See @@ -4572,6 +4578,7 @@ package Einfo is -- Has_Anon_Block_Suffix (Flag201) -- Has_Controlled_Component (Flag43) (base type only) -- Has_Convention_Pragma (Flag119) + -- Has_Delayed_Aspects (Flag200) -- Has_Delayed_Freeze (Flag18) -- Has_Fully_Qualified_Name (Flag173) -- Has_Gigi_Rep_Item (Flag82) @@ -5863,6 +5870,7 @@ package Einfo is function Has_Controlled_Component (Id : E) return B; function Has_Controlling_Result (Id : E) return B; function Has_Convention_Pragma (Id : E) return B; + function Has_Delayed_Aspects (Id : E) return B; function Has_Delayed_Freeze (Id : E) return B; function Has_Discriminants (Id : E) return B; function Has_Dispatch_Table (Id : E) return B; @@ -6424,6 +6432,7 @@ package Einfo is procedure Set_Has_Controlled_Component (Id : E; V : B := True); procedure Set_Has_Controlling_Result (Id : E; V : B := True); procedure Set_Has_Convention_Pragma (Id : E; V : B := True); + procedure Set_Has_Delayed_Aspects (Id : E; V : B := True); procedure Set_Has_Delayed_Freeze (Id : E; V : B := True); procedure Set_Has_Discriminants (Id : E; V : B := True); procedure Set_Has_Dispatch_Table (Id : E; V : B := True); @@ -6846,13 +6855,17 @@ package Einfo is -- Subprograms for Accessing Rep Item Chain -- ---------------------------------------------- - -- The First_Rep_Item field of every entity points to a linked list - -- (linked through Next_Rep_Item) of representation pragmas and attribute - -- definition clauses that apply to the item. Note that in the case of - -- types, it is assumed that any such rep items for a base type also apply - -- to all subtypes. This is implemented by having the chain for subtypes - -- link onto the chain for the base type, so that any new entries for the - -- subtype are added at the start of the chain. + -- The First_Rep_Item field of every entity points to a linked list (linked + -- through Next_Rep_Item) of representation pragmas, attribute definition + -- clauses, representation clauses, and aspect specifications that apply to + -- the item. Note that in the case of types, it is assumed that any such + -- rep items for a base type also apply to all subtypes. This is achieved + -- by having the chain for subtypes link onto the chain for the base type, + -- so that new entries for the subtype are added at the start of the chain. + -- + -- Note: aspect specification nodes are linked only when evaluation of the + -- expression is deferred to the freeze point. For further details see + -- Sem_Ch13.Analyze_Aspect_Specifications. function Get_Attribute_Definition_Clause (E : Entity_Id; @@ -6862,6 +6875,16 @@ package Einfo is -- value returned is the N_Attribute_Definition_Clause node, otherwise -- Empty is returned. + function Get_Rep_Item_For_Entity + (E : Entity_Id; + Nam : Name_Id) return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for an instance of a + -- rep item (pragma, attribute definition clause, or aspect specitication) + -- whose name matches the given name. If one is found, it is returned, + -- otherwise Empty is returned. Unlike the other Get routines for the + -- Rep_Item chain, this only returns items whose entity matches E (it + -- does not return items from the parent chain). + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id; -- Searches the Rep_Item chain for a given entity E, for a record -- representation clause, and if found, returns it. Returns Empty @@ -6885,15 +6908,15 @@ package Einfo is -- is returned, otherwise False indicates that no matching entry was found. procedure Record_Rep_Item (E : Entity_Id; N : Node_Id); - -- N is the node for either a representation pragma or an attribute - -- definition clause that applies to entity E. This procedure links the - -- node N onto the Rep_Item chain for entity E. Note that it is an error to - -- call this procedure with E being overloadable, and N being a pragma that - -- can apply to multiple overloadable entities (i.e. Convention, Interface, - -- Inline, Inline_Always, Import, Export, External). This is not allowed - -- even if in fact the entity is not overloaded, since we can't rely on - -- it being present in the overloaded case, it is not useful to have it - -- present in the non-overloaded case. + -- N is the node for a representation pragma, representation clause, an + -- attribute definition clause, or an aspect specification that applies to + -- entity E. This procedure links the node N onto the Rep_Item chain for + -- entity E. Note that it is an error to call this procedure with E being + -- overloadable, and N being a pragma that applies to multiple overloadable + -- entities (Convention, Interface, Inline, Inline_Always, Import, Export, + -- External). This is not allowed even in the case where the entity is not + -- overloaded, since we can't rely on it being present in the overloaded + -- case, it is not useful to have it present in the non-overloaded case. ------------------------------- -- Miscellaneous Subprograms -- @@ -7083,6 +7106,7 @@ package Einfo is pragma Inline (Has_Controlled_Component); pragma Inline (Has_Controlling_Result); pragma Inline (Has_Convention_Pragma); + pragma Inline (Has_Delayed_Aspects); pragma Inline (Has_Delayed_Freeze); pragma Inline (Has_Discriminants); pragma Inline (Has_Dispatch_Table); @@ -7515,6 +7539,7 @@ package Einfo is pragma Inline (Set_Has_Controlled_Component); pragma Inline (Set_Has_Controlling_Result); pragma Inline (Set_Has_Convention_Pragma); + pragma Inline (Set_Has_Delayed_Aspects); pragma Inline (Set_Has_Delayed_Freeze); pragma Inline (Set_Has_Discriminants); pragma Inline (Set_Has_Dispatch_Table); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 6e8fa823d91..9cdef48449e 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -220,6 +220,31 @@ package body Exp_Ch13 is Delete : Boolean := False; begin + -- If there are delayed aspect specifications, we insert them just + -- before the freeze node. They are already analyzed so we don't need + -- to reanalyze them (they were analyzed before the type was frozen), + -- but we want them in the tree for the back end, and so that the + -- listing from sprint is clearer on where these occur logically. + + if Has_Delayed_Aspects (E) then + declare + Aitem : Node_Id; + Ritem : Node_Id; + + begin + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification then + Aitem := Aspect_Rep_Item (Ritem); + pragma Assert (Is_Delayed_Aspect (Aitem)); + Insert_Before (N, Aitem); + end if; + + Next_Rep_Item (Ritem); + end loop; + end; + end if; + -- Processing for objects with address clauses if Is_Object (E) and then Present (Address_Clause (E)) then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 2cc0b58178e..f67e1c4e039 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6157,16 +6157,16 @@ package body Exp_Ch3 is if not Is_Limited_Type (Def_Id) then Append_Freeze_Actions (Def_Id, Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id))); + (Find_Prim_Op (Def_Id, Name_Adjust), Def_Id)); end if; Append_Freeze_Actions (Def_Id, Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id))); + (Find_Prim_Op (Def_Id, Name_Initialize), Def_Id)); Append_Freeze_Actions (Def_Id, Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id))); + (Find_Prim_Op (Def_Id, Name_Finalize), Def_Id)); end if; -- Freeze rest of primitive operations. There is no need to handle @@ -6361,8 +6361,7 @@ package body Exp_Ch3 is N_Subprogram_Declaration and then not Is_Frozen (Stream_Op) then - Append_Freeze_Actions - (Typ, Freeze_Entity (Stream_Op, Sloc (N))); + Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N)); end if; end loop; end Freeze_Stream_Operations; @@ -8998,7 +8997,6 @@ package body Exp_Ch3 is function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Tag_Typ); Res : constant List_Id := New_List; Prim : Elmt_Id; Frnodes : List_Id; @@ -9007,7 +9005,7 @@ package body Exp_Ch3 is Prim := First_Elmt (Primitive_Operations (Tag_Typ)); while Present (Prim) loop if Is_Predefined_Dispatching_Operation (Node (Prim)) then - Frnodes := Freeze_Entity (Node (Prim), Loc); + Frnodes := Freeze_Entity (Node (Prim), Tag_Typ); if Present (Frnodes) then Append_List_To (Res, Frnodes); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index cc9852a63a4..e2b5ea86af1 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5459,7 +5459,7 @@ package body Exp_Ch6 is Push_Scope (Scope (Scop)); Analyze (Prot_Decl); - Insert_Actions (N, Freeze_Entity (Prot_Id, Loc)); + Insert_Actions (N, Freeze_Entity (Prot_Id, N)); Set_Protected_Body_Subprogram (Subp, Prot_Id); -- Create protected operation as well. Even though the operation @@ -5699,7 +5699,7 @@ package body Exp_Ch6 is (Corresponding_Record_Type (Scop), Loc)))); Insert_Actions (N, Decls); - Insert_Actions (N, Freeze_Entity (Obj_Ptr, Sloc (N))); + Insert_Actions (N, Freeze_Entity (Obj_Ptr, N)); Rec := Make_Explicit_Dereference (Loc, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 62c6c780ad4..aa035571b11 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -10587,7 +10587,7 @@ package body Exp_Ch9 is -- in time if we don't freeze now. declare - L : constant List_Id := Freeze_Entity (Rec_Ent, Loc); + L : constant List_Id := Freeze_Entity (Rec_Ent, N); begin if Is_Non_Empty_List (L) then Insert_List_After (Body_Decl, L); diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 3a0682f5e79..ce9c3358717 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -4387,7 +4387,7 @@ package body Exp_Disp is Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); - Frnodes := Freeze_Entity (Prim, Loc); + Frnodes := Freeze_Entity (Prim, Typ); declare F : Entity_Id; @@ -6728,8 +6728,8 @@ package body Exp_Disp is -- generating these freezing nodes in wrong scopes (for example in -- the IC routine of a derivation of Typ). - Append_List_To (Result, Freeze_Entity (DT_Prims, Loc)); - Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Loc)); + Append_List_To (Result, Freeze_Entity (DT_Prims, Typ)); + Append_List_To (Result, Freeze_Entity (DT_Prims_Acc, Typ)); -- Mark entity of dispatch table. Required by the back end to -- handle them properly. diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index c8a31f05932..91e984386f2 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -101,10 +101,11 @@ package body Freeze is procedure Freeze_And_Append (Ent : Entity_Id; - Loc : Source_Ptr; + N : Node_Id; Result : in out List_Id); -- Freezes Ent using Freeze_Entity, and appends the resulting list of - -- nodes to Result, modifying Result from No_List if necessary. + -- nodes to Result, modifying Result from No_List if necessary. N has + -- the same usage as in Freeze_Entity. procedure Freeze_Enumeration_Type (Typ : Entity_Id); -- Freeze enumeration type. The Esize field is set as processing @@ -138,20 +139,20 @@ package body Freeze is procedure Process_Default_Expressions (E : Entity_Id; After : in out Node_Id); - -- This procedure is called for each subprogram to complete processing - -- of default expressions at the point where all types are known to be - -- frozen. The expressions must be analyzed in full, to make sure that - -- all error processing is done (they have only been pre-analyzed). If - -- the expression is not an entity or literal, its analysis may generate - -- code which must not be executed. In that case we build a function - -- body to hold that code. This wrapper function serves no other purpose - -- (it used to be called to evaluate the default, but now the default is - -- inlined at each point of call). + -- This procedure is called for each subprogram to complete processing of + -- default expressions at the point where all types are known to be frozen. + -- The expressions must be analyzed in full, to make sure that all error + -- processing is done (they have only been pre-analyzed). If the expression + -- is not an entity or literal, its analysis may generate code which must + -- not be executed. In that case we build a function body to hold that + -- code. This wrapper function serves no other purpose (it used to be + -- called to evaluate the default, but now the default is inlined at each + -- point of call). procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id); - -- Typ is a record or array type that is being frozen. This routine - -- sets the default component alignment from the scope stack values - -- if the alignment is otherwise not specified. + -- Typ is a record or array type that is being frozen. This routine sets + -- the default component alignment from the scope stack values if the + -- alignment is otherwise not specified. procedure Check_Debug_Info_Needed (T : Entity_Id); -- As each entity is frozen, this routine is called to deal with the @@ -162,9 +163,9 @@ package body Freeze is -- subsidiary entities have the flag set as required. procedure Undelay_Type (T : Entity_Id); - -- T is a type of a component that we know to be an Itype. - -- We don't want this to have a Freeze_Node, so ensure it doesn't. - -- Do the same for any Full_View or Corresponding_Record_Type. + -- T is a type of a component that we know to be an Itype. We don't want + -- this to have a Freeze_Node, so ensure it doesn't. Do the same for any + -- Full_View or Corresponding_Record_Type. procedure Warn_Overlay (Expr : Node_Id; @@ -1208,7 +1209,6 @@ package body Freeze is -- as they are generated. procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is - Loc : constant Source_Ptr := Sloc (After); E : Entity_Id; Decl : Node_Id; @@ -1311,7 +1311,7 @@ package body Freeze is if Comes_From_Source (Subp) and then not Is_Frozen (Subp) then - Flist := Freeze_Entity (Subp, Loc); + Flist := Freeze_Entity (Subp, After); Process_Flist; end if; @@ -1321,7 +1321,7 @@ package body Freeze is end if; if not Is_Frozen (E) then - Flist := Freeze_Entity (E, Loc); + Flist := Freeze_Entity (E, After); Process_Flist; end if; @@ -1446,10 +1446,10 @@ package body Freeze is procedure Freeze_And_Append (Ent : Entity_Id; - Loc : Source_Ptr; + N : Node_Id; Result : in out List_Id) is - L : constant List_Id := Freeze_Entity (Ent, Loc); + L : constant List_Id := Freeze_Entity (Ent, N); begin if Is_Non_Empty_List (L) then if Result = No_List then @@ -1465,7 +1465,7 @@ package body Freeze is ------------------- procedure Freeze_Before (N : Node_Id; T : Entity_Id) is - Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N)); + Freeze_Nodes : constant List_Id := Freeze_Entity (T, N); begin if Is_Non_Empty_List (Freeze_Nodes) then Insert_Actions (N, Freeze_Nodes); @@ -1476,7 +1476,8 @@ package body Freeze is -- Freeze_Entity -- ------------------- - function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id is + function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (N); Test_E : Entity_Id := E; Comp : Entity_Id; F_Node : Node_Id; @@ -1829,7 +1830,7 @@ package body Freeze is Undelay_Type (Etype (Comp)); end if; - Freeze_And_Append (Etype (Comp), Loc, Result); + Freeze_And_Append (Etype (Comp), N, Result); -- Check for error of component clause given for variable -- sized type. We have to delay this test till this point, @@ -1988,13 +1989,13 @@ package body Freeze is then if Is_Entity_Name (Expression (Alloc)) then Freeze_And_Append - (Entity (Expression (Alloc)), Loc, Result); + (Entity (Expression (Alloc)), N, Result); elsif Nkind (Expression (Alloc)) = N_Subtype_Indication then Freeze_And_Append (Entity (Subtype_Mark (Expression (Alloc))), - Loc, Result); + N, Result); end if; elsif Is_Itype (Designated_Type (Etype (Comp))) then @@ -2002,7 +2003,7 @@ package body Freeze is else Freeze_And_Append - (Designated_Type (Etype (Comp)), Loc, Result); + (Designated_Type (Etype (Comp)), N, Result); end if; end if; end; @@ -2023,7 +2024,7 @@ package body Freeze is then Freeze_And_Append (Designated_Type - (Component_Type (Etype (Comp))), Loc, Result); + (Component_Type (Etype (Comp))), N, Result); end if; Prev := Comp; @@ -2110,8 +2111,7 @@ package body Freeze is if Ekind (Rec) = E_Record_Type then if Present (Corresponding_Remote_Type (Rec)) then - Freeze_And_Append - (Corresponding_Remote_Type (Rec), Loc, Result); + Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result); end if; Comp := First_Component (Rec); @@ -2372,6 +2372,32 @@ package body Freeze is end; end if; + -- Deal with delayed aspect specifications. At the point of occurrence + -- of the aspect definition, we preanalyzed the argument, to capture + -- the visibility at that point, but the actual analysis of the aspect + -- is required to be delayed to the freeze point, so we evalute the + -- pragma or attribute definition clause in the tree at this point. + + if Has_Delayed_Aspects (E) then + declare + Ritem : Node_Id; + Aitem : Node_Id; + + begin + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification then + Aitem := Aspect_Rep_Item (Ritem); + pragma Assert (Is_Delayed_Aspect (Aitem)); + Set_Parent (Aitem, Ritem); + Analyze (Aitem); + end if; + + Next_Rep_Item (Ritem); + end loop; + end; + end if; + -- Here to freeze the entity Result := No_List; @@ -2433,7 +2459,7 @@ package body Freeze is Formal := First_Formal (E); while Present (Formal) loop F_Type := Etype (Formal); - Freeze_And_Append (F_Type, Loc, Result); + Freeze_And_Append (F_Type, N, Result); if Is_Private_Type (F_Type) and then Is_Private_Type (Base_Type (F_Type)) @@ -2589,7 +2615,7 @@ package body Freeze is if Is_Itype (Etype (Formal)) and then Ekind (F_Type) = E_Subprogram_Type then - Freeze_And_Append (F_Type, Loc, Result); + Freeze_And_Append (F_Type, N, Result); end if; end if; @@ -2603,7 +2629,7 @@ package body Freeze is -- Freeze return type R_Type := Etype (E); - Freeze_And_Append (R_Type, Loc, Result); + Freeze_And_Append (R_Type, N, Result); -- Check suspicious return type for C function @@ -2716,7 +2742,7 @@ package body Freeze is -- Must freeze its parent first if it is a derived subprogram if Present (Alias (E)) then - Freeze_And_Append (Alias (E), Loc, Result); + Freeze_And_Append (Alias (E), N, Result); end if; -- We don't freeze internal subprograms, because we don't normally @@ -2740,7 +2766,7 @@ package body Freeze is if Present (Etype (E)) and then Ekind (E) /= E_Generic_Function then - Freeze_And_Append (Etype (E), Loc, Result); + Freeze_And_Append (Etype (E), N, Result); end if; -- Special processing for objects created by object declaration @@ -3075,20 +3101,20 @@ package body Freeze is Atype := Ancestor_Subtype (E); if Present (Atype) then - Freeze_And_Append (Atype, Loc, Result); + Freeze_And_Append (Atype, N, Result); -- Otherwise freeze the base type of the entity before freezing -- the entity itself (RM 13.14(15)). elsif E /= Base_Type (E) then - Freeze_And_Append (Base_Type (E), Loc, Result); + Freeze_And_Append (Base_Type (E), N, Result); end if; -- For a derived type, freeze its parent type first (RM 13.14(15)) elsif Is_Derived_Type (E) then - Freeze_And_Append (Etype (E), Loc, Result); - Freeze_And_Append (First_Subtype (Etype (E)), Loc, Result); + Freeze_And_Append (Etype (E), N, Result); + Freeze_And_Append (First_Subtype (Etype (E)), N, Result); end if; -- For array type, freeze index types and component type first @@ -3105,11 +3131,11 @@ package body Freeze is -- with a non-standard representation. begin - Freeze_And_Append (Ctyp, Loc, Result); + Freeze_And_Append (Ctyp, N, Result); Indx := First_Index (E); while Present (Indx) loop - Freeze_And_Append (Etype (Indx), Loc, Result); + Freeze_And_Append (Etype (Indx), N, Result); if Is_Enumeration_Type (Etype (Indx)) and then Has_Non_Standard_Rep (Etype (Indx)) @@ -3458,7 +3484,7 @@ package body Freeze is and then Ekind (E) /= E_String_Literal_Subtype then Create_Packed_Array_Type (E); - Freeze_And_Append (Packed_Array_Type (E), Loc, Result); + Freeze_And_Append (Packed_Array_Type (E), N, Result); -- Size information of packed array type is copied to the -- array type, since this is really the representation. But @@ -3501,7 +3527,7 @@ package body Freeze is -- frozen as well (RM 13.14(15)) elsif Is_Class_Wide_Type (E) then - Freeze_And_Append (Root_Type (E), Loc, Result); + Freeze_And_Append (Root_Type (E), N, Result); -- If the base type of the class-wide type is still incomplete, -- the class-wide remains unfrozen as well. This is legal when @@ -3541,7 +3567,7 @@ package body Freeze is if Ekind (E) = E_Class_Wide_Subtype and then Present (Equivalent_Type (E)) then - Freeze_And_Append (Equivalent_Type (E), Loc, Result); + Freeze_And_Append (Equivalent_Type (E), N, Result); end if; -- For a record (sub)type, freeze all the component types (RM @@ -3565,13 +3591,13 @@ package body Freeze is elsif Is_Concurrent_Type (E) then if Present (Corresponding_Record_Type (E)) then Freeze_And_Append - (Corresponding_Record_Type (E), Loc, Result); + (Corresponding_Record_Type (E), N, Result); end if; Comp := First_Entity (E); while Present (Comp) loop if Is_Type (Comp) then - Freeze_And_Append (Comp, Loc, Result); + Freeze_And_Append (Comp, N, Result); elsif (Ekind (Comp)) /= E_Function then if Is_Itype (Etype (Comp)) @@ -3580,7 +3606,7 @@ package body Freeze is Undelay_Type (Etype (Comp)); end if; - Freeze_And_Append (Etype (Comp), Loc, Result); + Freeze_And_Append (Etype (Comp), N, Result); end if; Next_Entity (Comp); @@ -3638,7 +3664,6 @@ package body Freeze is -- processing is required if Is_Frozen (Full_View (E)) then - Set_Has_Delayed_Freeze (E, False); Set_Freeze_Node (E, Empty); Check_Debug_Info_Needed (E); @@ -3655,10 +3680,10 @@ package body Freeze is and then Present (Underlying_Full_View (Full)) then Freeze_And_Append - (Underlying_Full_View (Full), Loc, Result); + (Underlying_Full_View (Full), N, Result); end if; - Freeze_And_Append (Full, Loc, Result); + Freeze_And_Append (Full, N, Result); if Has_Delayed_Freeze (E) then F_Node := Freeze_Node (Full); @@ -3746,7 +3771,7 @@ package body Freeze is end if; end if; - Freeze_And_Append (Etype (Formal), Loc, Result); + Freeze_And_Append (Etype (Formal), N, Result); Next_Formal (Formal); end loop; @@ -3758,7 +3783,7 @@ package body Freeze is elsif Is_Access_Protected_Subprogram_Type (E) then if Present (Equivalent_Type (E)) then - Freeze_And_Append (Equivalent_Type (E), Loc, Result); + Freeze_And_Append (Equivalent_Type (E), N, Result); end if; end if; @@ -4008,7 +4033,7 @@ package body Freeze is -- since obviously the first subtype depends on its own base type. if Is_Type (E) then - Freeze_And_Append (First_Subtype (E), Loc, Result); + Freeze_And_Append (First_Subtype (E), N, Result); -- If we just froze a tagged non-class wide record, then freeze the -- corresponding class-wide type. This must be done after the tagged @@ -4019,7 +4044,7 @@ package body Freeze is and then not Is_Class_Wide_Type (E) and then Present (Class_Wide_Type (E)) then - Freeze_And_Append (Class_Wide_Type (E), Loc, Result); + Freeze_And_Append (Class_Wide_Type (E), N, Result); end if; end if; @@ -4525,21 +4550,21 @@ package body Freeze is or else Ekind (Current_Scope) = E_Void then declare - Loc : constant Source_Ptr := Sloc (Current_Scope); - Freeze_Nodes : List_Id := No_List; - Pos : Int := Scope_Stack.Last; + N : constant Node_Id := Current_Scope; + Freeze_Nodes : List_Id := No_List; + Pos : Int := Scope_Stack.Last; begin if Present (Desig_Typ) then - Freeze_And_Append (Desig_Typ, Loc, Freeze_Nodes); + Freeze_And_Append (Desig_Typ, N, Freeze_Nodes); end if; if Present (Typ) then - Freeze_And_Append (Typ, Loc, Freeze_Nodes); + Freeze_And_Append (Typ, N, Freeze_Nodes); end if; if Present (Nam) then - Freeze_And_Append (Nam, Loc, Freeze_Nodes); + Freeze_And_Append (Nam, N, Freeze_Nodes); end if; -- The current scope may be that of a constrained component of @@ -4553,7 +4578,7 @@ package body Freeze is if Is_Non_Empty_List (Freeze_Nodes) then if No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then Scope_Stack.Table (Pos).Pending_Freeze_Actions := - Freeze_Nodes; + Freeze_Nodes; else Append_List (Freeze_Nodes, Scope_Stack.Table (Pos).Pending_Freeze_Actions); @@ -5056,7 +5081,7 @@ package body Freeze is begin Set_Has_Delayed_Freeze (T); - L := Freeze_Entity (T, Sloc (N)); + L := Freeze_Entity (T, N); if Is_Non_Empty_List (L) then Insert_Actions (N, L); diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index 81dab28d30e..d4dd1a1251b 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -179,21 +179,21 @@ package Freeze is (E : Entity_Id; Typ : Entity_Id) return Boolean; - -- If an atomic object is initialized with an aggregate or is assigned - -- an aggregate, we have to prevent a piecemeal access or assignment - -- to the object, even if the aggregate is to be expanded. We create - -- a temporary for the aggregate, and assign the temporary instead, - -- so that the back end can generate an atomic move for it. This is - -- only done in the context of an object declaration or an assignment. - -- Function is a noop and returns false in other contexts. - - function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id; - -- Freeze an entity, and return Freeze nodes, to be inserted at the - -- point of call. Loc is a source location which corresponds to the - -- freeze point. This is used in placing warning messages in the - -- situation where it appears that a type has been frozen too early, - -- e.g. when a primitive operation is declared after the freezing - -- point of its tagged type. Returns No_List if no freeze nodes needed. + -- If an atomic object is initialized with an aggregate or is assigned an + -- aggregate, we have to prevent a piecemeal access or assignment to the + -- object, even if the aggregate is to be expanded. We create a temporary + -- for the aggregate, and assign the temporary instead, so that the back + -- end can generate an atomic move for it. This is only done in the context + -- of an object declaration or an assignment. Function is a noop and + -- returns false in other contexts. + + function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id; + -- Freeze an entity, and return Freeze nodes, to be inserted at the point + -- of call. N is a node whose source location corresponds to the freeze + -- point. This is used in placing warning messages in the situation where + -- it appears that a type has been frozen too early, e.g. when a primitive + -- operation is declared after the freezing point of its tagged type. + -- Returns No_List if no freeze nodes needed. procedure Freeze_All (From : Entity_Id; After : in out Node_Id); -- Before a non-instance body, or at the end of a declarative part diff --git a/gcc/ada/g-htable.ads b/gcc/ada/g-htable.ads index e747637a590..a080ee8311a 100644 --- a/gcc/ada/g-htable.ads +++ b/gcc/ada/g-htable.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2009, AdaCore -- +-- Copyright (C) 1995-2010, 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- -- @@ -111,6 +111,20 @@ package GNAT.HTable is -- -- same function since the last call to Get_First or No_Element if -- -- there is no such element. If there is no call to 'Set' in between -- -- Get_Next calls, all the elements of the HTable will be traversed. + + -- procedure Get_First (K : out Key; E : out Element); + -- -- This version of the iterator returns a key/element pair. A non- + -- -- specified entry is returned, and there is no guarantee that two + -- -- calls to this procedure will return the same element. + + -- procedure Get_Next (K : out Key; E : out Element); + -- -- This version of the iterator returns a key/element pair. It + -- -- returns a non-specified element that has not been returned since + -- -- the last call to Get_First. If there is no remaining element, + -- -- then E is set to No_Element, and the value in K is undefined. + -- -- If there is no call to Set in between Get_Next calls, all the + -- -- elements of the HTable will be traversed. + -- end Simple_HTable; ------------------- diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb index 27a6aa75e64..2a54ed1622d 100644 --- a/gcc/ada/s-htable.adb +++ b/gcc/ada/s-htable.adb @@ -246,6 +246,17 @@ package body System.HTable is end if; end Get_First; + procedure Get_First (K : in out Key; E : out Element) is + Tmp : constant Elmt_Ptr := Tab.Get_First; + begin + if Tmp = null then + E := No_Element; + else + K := Tmp.K; + E := Tmp.E; + end if; + end Get_First; + ------------- -- Get_Key -- ------------- @@ -269,6 +280,17 @@ package body System.HTable is end if; end Get_Next; + procedure Get_Next (K : in out Key; E : out Element) is + Tmp : constant Elmt_Ptr := Tab.Get_Next; + begin + if Tmp = null then + E := No_Element; + else + K := Tmp.K; + E := Tmp.E; + end if; + end Get_Next; + ---------- -- Next -- ---------- diff --git a/gcc/ada/s-htable.ads b/gcc/ada/s-htable.ads index 9e7d1044cc3..8f02b95f476 100644 --- a/gcc/ada/s-htable.ads +++ b/gcc/ada/s-htable.ads @@ -94,8 +94,24 @@ package System.HTable is function Get_Next return Element; -- Returns a non-specified element that has not been returned by the -- same function since the last call to Get_First or No_Element if - -- there is no such element. If there is no call to 'Set' in between + -- there is no such element. If there is no call to Set in between -- Get_Next calls, all the elements of the HTable will be traversed. + + procedure Get_First (K : in out Key; E : out Element); + -- This version of the iterator returns a key/element pair. A non- + -- specified entry is returned, and there is no guarantee that two + -- calls to this procedure will return the same element. If the table + -- is empty, E is set to No_Element, and K is unchanged, otherwise + -- K and E are set to the first returned entry. + + procedure Get_Next (K : in out Key; E : out Element); + -- This version of the iterator returns a key/element pair. It returns + -- a non-specified element that has not been returned since the last + -- call to Get_First. If there is no remaining element, then E is set + -- to No_Element, and the value in K is unchanged, otherwise K and E + -- are set to the next entry. If there is no call to Set in between + -- Get_Next calls, all the elements of the HTable will be traversed. + end Simple_HTable; ------------------- diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 53b340dae69..1e28ab0cd42 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -3706,10 +3706,14 @@ package body Sem_Aggr is end if; end Process_Component; + -- Start of processing for Propagate_Discriminants + begin -- The component type may be a variant type, so -- collect the components that are ruled by the - -- known values of the discriminants. + -- known values of the discriminants. Their values + -- have already been inserted into the component + -- list of the current aggregate. if Nkind (Def_Node) = N_Record_Definition and then @@ -3720,7 +3724,7 @@ package body Sem_Aggr is then Gather_Components (Aggr_Type, Component_List (Def_Node), - Governed_By => Assoc_List, + Governed_By => Component_Associations (Aggr), Into => Components, Report_Errors => Errors); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 75cc2db21ff..1dd183d284f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5356,8 +5356,34 @@ package body Sem_Attr is -- Start of processing for Eval_Attribute begin - -- Acquire first two expressions (at the moment, no attributes - -- take more than two expressions in any case). + -- No folding in spec expression that comes from source where the prefix + -- is an unfrozen entity. This avoids premature folding in cases like: + + -- procedure DefExprAnal is + -- type R is new Integer; + -- procedure P (Arg : Integer := R'Size); + -- for R'Size use 64; + -- procedure P (Arg : Integer := R'Size) is + -- begin + -- Put_Line (Arg'Img); + -- end P; + -- begin + -- P; + -- end; + + -- which shouold print 64 rather than 32. The exclusion of non-source + -- constructs from this test comes from some internal usage in packed + -- arrays, which otherwise fails, could use more analysis perhaps??? + + if In_Spec_Expression + and then Comes_From_Source (N) + and then not (Is_Entity_Name (P) and then Is_Frozen (Entity (P))) + then + return; + end if; + + -- Acquire first two expressions (at the moment, no attributes take more + -- than two expressions in any case). if Present (Expressions (N)) then E1 := First (Expressions (N)); @@ -5374,8 +5400,6 @@ package body Sem_Attr is if Id = Attribute_Enabled then - -- Evaluate the Enabled attribute - -- We skip evaluation if the expander is not active. This is not just -- an optimization. It is of key importance that we not rewrite the -- attribute in a generic template, since we want to pick up the @@ -7889,7 +7913,7 @@ package body Sem_Attr is -- Avoid insertion of freeze actions in spec expression mode if not In_Spec_Expression then - Insert_Actions (N, Freeze_Entity (Entity (P), Loc)); + Insert_Actions (N, Freeze_Entity (Entity (P), N)); end if; elsif Is_Type (Entity (P)) then @@ -8668,14 +8692,14 @@ package body Sem_Attr is -- Range -- ----------- - -- We replace the Range attribute node with a range expression - -- whose bounds are the 'First and 'Last attributes applied to the - -- same prefix. The reason that we do this transformation here - -- instead of in the expander is that it simplifies other parts of - -- the semantic analysis which assume that the Range has been - -- replaced; thus it must be done even when in semantic-only mode - -- (note that the RM specifically mentions this equivalence, we - -- take care that the prefix is only evaluated once). + -- We replace the Range attribute node with a range expression whose + -- bounds are the 'First and 'Last attributes applied to the same + -- prefix. The reason that we do this transformation here instead of + -- in the expander is that it simplifies other parts of the semantic + -- analysis which assume that the Range has been replaced; thus it + -- must be done even when in semantic-only mode (note that the RM + -- specifically mentions this equivalence, we take care that the + -- prefix is only evaluated once). when Attribute_Range => Range_Attribute : declare diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 7c8a2ea048c..4db2fb74245 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1204,9 +1204,8 @@ package body Sem_Ch10 is -- compilation unit actions list, and analyze them. declare - Loc : constant Source_Ptr := Sloc (N); - L : constant List_Id := - Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc); + L : constant List_Id := + Freeze_Entity (Cunit_Entity (Current_Sem_Unit), N); begin while Is_Non_Empty_List (L) loop Insert_Library_Level_Action (Remove_Head (L)); diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index d3661ff0835..da7e05e3242 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -57,7 +57,6 @@ package body Sem_Ch11 is procedure Analyze_Exception_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); PF : constant Boolean := Is_Pure (Current_Scope); - AS : constant List_Id := Aspect_Specifications (N); begin Generate_Definition (Id); Enter_Name (Id); @@ -66,7 +65,7 @@ package body Sem_Ch11 is Set_Etype (Id, Standard_Exception_Type); Set_Is_Statically_Allocated (Id); Set_Is_Pure (Id, PF); - Analyze_Aspect_Specifications (N, Id, AS); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Exception_Declaration; -------------------------------- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index a03971c9742..5ef69869597 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1802,7 +1802,6 @@ package body Sem_Ch12 is procedure Analyze_Formal_Object_Declaration (N : Node_Id) is E : constant Node_Id := Default_Expression (N); Id : constant Node_Id := Defining_Identifier (N); - AS : constant List_Id := Aspect_Specifications (N); K : Entity_Kind; T : Node_Id; @@ -1932,7 +1931,7 @@ package body Sem_Ch12 is end if; end if; - Analyze_Aspect_Specifications (N, Id, AS); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Formal_Object_Declaration; ---------------------------------------------- @@ -1983,7 +1982,6 @@ package body Sem_Ch12 is procedure Analyze_Formal_Package_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Pack_Id : constant Entity_Id := Defining_Identifier (N); - AS : constant List_Id := Aspect_Specifications (N); Formal : Entity_Id; Gen_Id : constant Node_Id := Name (N); Gen_Decl : Node_Id; @@ -2279,7 +2277,8 @@ package body Sem_Ch12 is Set_Scope (Pack_Id, Scope (Formal)); Set_Has_Completion (Pack_Id, True); - <<Leave>> Analyze_Aspect_Specifications (N, Pack_Id, AS); + <<Leave>> + Analyze_Aspect_Specifications (N, Pack_Id, Aspect_Specifications (N)); end Analyze_Formal_Package_Declaration; --------------------------------- @@ -2338,7 +2337,6 @@ package body Sem_Ch12 is Spec : constant Node_Id := Specification (N); Def : constant Node_Id := Default_Name (N); Nam : constant Entity_Id := Defining_Unit_Name (Spec); - AS : constant List_Id := Aspect_Specifications (N); Subp : Entity_Id; begin @@ -2500,7 +2498,8 @@ package body Sem_Ch12 is end if; end if; - <<Leave>> Analyze_Aspect_Specifications (N, Nam, AS); + <<Leave>> + Analyze_Aspect_Specifications (N, Nam, Aspect_Specifications (N)); end Analyze_Formal_Subprogram_Declaration; ------------------------------------- @@ -2509,7 +2508,6 @@ package body Sem_Ch12 is procedure Analyze_Formal_Type_Declaration (N : Node_Id) is Def : constant Node_Id := Formal_Type_Definition (N); - AS : constant List_Id := Aspect_Specifications (N); T : Entity_Id; begin @@ -2575,7 +2573,7 @@ package body Sem_Ch12 is end case; Set_Is_Generic_Type (T); - Analyze_Aspect_Specifications (N, T, AS); + Analyze_Aspect_Specifications (N, T, Aspect_Specifications (N)); end Analyze_Formal_Type_Declaration; ------------------------------------ @@ -2642,7 +2640,6 @@ package body Sem_Ch12 is procedure Analyze_Generic_Package_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - AS : constant List_Id := Aspect_Specifications (N); Id : Entity_Id; New_N : Node_Id; Save_Parent : Node_Id; @@ -2754,7 +2751,7 @@ package body Sem_Ch12 is end if; end if; - Analyze_Aspect_Specifications (N, Id, AS); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Generic_Package_Declaration; -------------------------------------------- @@ -2762,7 +2759,6 @@ package body Sem_Ch12 is -------------------------------------------- procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is - AS : constant List_Id := Aspect_Specifications (N); Spec : Node_Id; Id : Entity_Id; Formals : List_Id; @@ -2881,7 +2877,7 @@ package body Sem_Ch12 is End_Scope; Exit_Generic_Scope (Id); Generate_Reference_To_Formals (Id); - Analyze_Aspect_Specifications (N, Id, AS); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Generic_Subprogram_Declaration; ----------------------------------- @@ -2891,7 +2887,6 @@ package body Sem_Ch12 is procedure Analyze_Package_Instantiation (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Gen_Id : constant Node_Id := Name (N); - AS : constant List_Id := Aspect_Specifications (N); Act_Decl : Node_Id; Act_Decl_Name : Node_Id; @@ -3555,7 +3550,9 @@ package body Sem_Ch12 is Set_Defining_Identifier (N, Act_Decl_Id); end if; - <<Leave>> Analyze_Aspect_Specifications (N, Act_Decl_Id, AS); + <<Leave>> + Analyze_Aspect_Specifications + (N, Act_Decl_Id, Aspect_Specifications (N)); exception when Instantiation_Error => @@ -3582,8 +3579,7 @@ package body Sem_Ch12 is Cunit_Entity (Get_Source_Unit (Gen_Unit)); Curr_Comp : constant Node_Id := Cunit (Current_Sem_Unit); Curr_Scope : Entity_Id := Empty; - Curr_Unit : constant Entity_Id := - Cunit_Entity (Current_Sem_Unit); + Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); Removed : Boolean := False; Num_Scopes : Int := 0; @@ -3910,7 +3906,6 @@ package body Sem_Ch12 is is Loc : constant Source_Ptr := Sloc (N); Gen_Id : constant Node_Id := Name (N); - AS : constant List_Id := Aspect_Specifications (N); Anon_Id : constant Entity_Id := Make_Defining_Identifier (Sloc (Defining_Entity (N)), @@ -4332,7 +4327,9 @@ package body Sem_Ch12 is Generic_Renamings_HTable.Reset; end if; - <<Leave>> Analyze_Aspect_Specifications (N, Act_Decl_Id, AS); + <<Leave>> + Analyze_Aspect_Specifications + (N, Act_Decl_Id, Aspect_Specifications (N)); exception when Instantiation_Error => diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 6fcb998e1dd..921c23c4422 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -26,6 +26,7 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -629,12 +630,31 @@ package body Sem_Ch13 is L : List_Id) is Aspect : Node_Id; + Aitem : Node_Id; Ent : Node_Id; - Result : Boolean; - Ritem : Node_Id; Ins_Node : Node_Id := N; - -- Insert pragmas after this node + -- Insert pragmas (other than Pre/Post) after this node + + -- The general processing involves building an attribute definition + -- clause or a pragma node that corresponds to the access type. Then + -- one of two things happens: + + -- If we are required to delay the evaluation of this aspect to the + -- freeze point, we preanalyze the relevant argument, and then attach + -- the corresponding pragma/attribute definition clause to the aspect + -- specification node, which is then placed in the Rep Item chain. + -- In this case we mark the entity with the Has_Delayed_Aspects flag, + -- and we evaluate the rep item at the freeze point. + + -- If no delay is required, we just insert the pragma or attribute + -- after the declaration, and it will get processed by the normal + -- circuit. The From_Aspect_Specification flag is set on the pragma + -- or attribute definition node in either case to activate special + -- processing (e.g. not traversing the list of homonyms for inline). + + Delay_Required : Boolean; + -- Set True if delay is required begin if L = No_List then @@ -644,12 +664,17 @@ package body Sem_Ch13 is Aspect := First (L); while Present (Aspect) loop declare - Id : constant Node_Id := Identifier (Aspect); - Expr : constant Node_Id := Expression (Aspect); - Nam : constant Name_Id := Chars (Id); + Id : constant Node_Id := Identifier (Aspect); + Expr : constant Node_Id := Expression (Aspect); + Nam : constant Name_Id := Chars (Id); + A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); Anod : Node_Id; + T : Entity_Id; begin + Set_Entity (Aspect, E); + Ent := New_Occurrence_Of (E, Sloc (Id)); + -- Check for duplicate aspect Anod := First (L); @@ -667,7 +692,7 @@ package body Sem_Ch13 is -- Processing based on specific aspect - case Get_Aspect_Id (Nam) is + case A_Id is -- No_Aspect should be impossible @@ -701,40 +726,46 @@ package body Sem_Ch13 is Aspect_Volatile | Aspect_Volatile_Components => + -- Build corresponding pragma node + + Aitem := + Make_Pragma (Sloc (Aspect), + Pragma_Argument_Associations => New_List (Ent), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Chars (Id))); + + -- Deal with missing expression case, delay never needed + if No (Expr) then - Result := True; + Delay_Required := False; + + -- Expression is present else - Analyze_And_Resolve (Expr); + Preanalyze_Spec_Expression (Expr, Standard_Boolean); - if not Is_OK_Static_Expression (Expr) then - Error_Msg_N - ("static boolean expression required here", Expr); - Result := True; + -- If preanalysis gives a static expression, we don't + -- need to delay (this will happen often in practice). - else - Result := Is_True (Expr_Value (Expr)); - end if; - end if; + if Is_OK_Static_Expression (Expr) then + Delay_Required := False; - Ent := New_Occurrence_Of (E, Sloc (Id)); + if Is_False (Expr_Value (Expr)) then + Set_Aspect_Cancel (Aitem); + end if; - Ritem := - Make_Pragma (Sloc (Aspect), - Pragma_Argument_Associations => New_List (Ent), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + -- If we don't get a static expression, then delay, the + -- expression may turn out static by freeze time. - if Result = False then - Set_Aspect_Cancel (Ritem); + else + Delay_Required := True; + end if; end if; - -- Aspects corresponding to attribute definition clauses. We - -- create the matching clause and insert it following the - -- declaration in the tree. + -- Aspects corresponding to attribute definition clauses with + -- the exception of Address which is treated specially. - when Aspect_Address | - Aspect_Alignment | + when Aspect_Alignment | Aspect_Bit_Order | Aspect_Component_Size | Aspect_External_Tag | @@ -746,12 +777,72 @@ package body Sem_Ch13 is Aspect_Stream_Size | Aspect_Value_Size => - Ritem := + -- Preanalyze the expression with the appropriate type + + case A_Id is + when Aspect_Bit_Order => + T := RTE (RE_Bit_Order); + when Aspect_External_Tag => + T := Standard_String; + when Aspect_Storage_Pool => + T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); + when others => + T := Any_Integer; + end case; + + Preanalyze_Spec_Expression (Expr, T); + + -- Construct the attribute definition clause + + Aitem := Make_Attribute_Definition_Clause (Sloc (Aspect), - Name => New_Occurrence_Of (E, Sloc (Id)), + Name => Ent, Chars => Chars (Id), Expression => Relocate_Node (Expr)); + -- We do not need a delay if we have a static expression + + if Is_OK_Static_Expression (Expression (Aitem)) then + Delay_Required := False; + + -- Here a delay is required + + else + Delay_Required := True; + end if; + + -- Address aspect, treated specially because we have some + -- strange problem in the back end if we try to delay ??? + + when Aspect_Address => + + -- Construct the attribute definition clause + + Aitem := + Make_Attribute_Definition_Clause (Sloc (Aspect), + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + + -- If -gnatd.A is set, do the delay if needed (this is + -- so we can debug the relevant problem). + + if Debug_Flag_Dot_AA then + Preanalyze_Spec_Expression + (Expression (Aitem), RTE (RE_Address)); + + if Is_OK_Static_Expression (Expression (Aitem)) then + Delay_Required := False; + else + Delay_Required := True; + end if; + + -- Here if -gnatd.A not set, never do the delay + + else + Delay_Required := False; + end if; + -- Aspects corresponding to pragmas with two arguments, where -- the first argument is a local name referring to the entity, -- and the second argument is the aspect definition expression. @@ -759,13 +850,20 @@ package body Sem_Ch13 is when Aspect_Suppress | Aspect_Unsuppress => - Ritem := + -- Construct the pragma + + Aitem := Make_Pragma (Sloc (Aspect), Pragma_Argument_Associations => New_List ( New_Occurrence_Of (E, Sloc (Expr)), Relocate_Node (Expr)), Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + Make_Identifier (Sloc (Id), Chars (Id))); + + -- We don't have to play the delay game here, since the only + -- values are check names which don't get analyzed anyway. + + Delay_Required := False; -- Aspects corresponding to pragmas with two arguments, where -- the second argument is a local name referring to the entity, @@ -773,7 +871,9 @@ package body Sem_Ch13 is when Aspect_Warnings => - Ritem := + -- Construct the pragma + + Aitem := Make_Pragma (Sloc (Aspect), Pragma_Argument_Associations => New_List ( Relocate_Node (Expr), @@ -781,35 +881,52 @@ package body Sem_Ch13 is Pragma_Identifier => Make_Identifier (Sloc (Id), Chars (Id))); + -- We don't have to play the delay game here, since the only + -- values are check names which don't get analyzed anyway. + + Delay_Required := False; + -- Aspect Post corresponds to pragma Postcondition with single -- argument that is the expression (we never give a message - -- argument. This is inserted right after the declaration, to + -- argument. This is inserted right after the declaration, -- to get the required pragma placement. when Aspect_Post => - Insert_After (N, + -- Construct the pragma + + Aitem := Make_Pragma (Sloc (Expr), Pragma_Argument_Associations => New_List ( Relocate_Node (Expr)), Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Postcondition))); - goto Continue; + Make_Identifier (Sloc (Id), Name_Postcondition)); + + -- We don't have to play the delay game here. The required + -- delay in this case is already implemented by the pragma. + + Delay_Required := False; -- Aspect Pre corresponds to pragma Precondition with single -- argument that is the expression (we never give a message - -- argument. This is inserted right after the declaration, to - -- get the required pragma placement. + -- argument). This is inserted right after the declaration, + -- to get the required pragma placement. when Aspect_Pre => - Insert_After (N, + -- Construct the pragma + + Aitem := Make_Pragma (Sloc (Expr), Pragma_Argument_Associations => New_List ( Relocate_Node (Expr)), Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Precondition))); - goto Continue; + Make_Identifier (Sloc (Id), Name_Precondition)); + + -- We don't have to play the delay game here. The required + -- delay in this case is already implemented by the pragma. + + Delay_Required := False; -- Aspects currently unimplemented @@ -820,9 +937,36 @@ package body Sem_Ch13 is goto Continue; end case; - Set_From_Aspect_Specification (Ritem); - Insert_After (Ins_Node, Ritem); - Ins_Node := Ritem; + Set_From_Aspect_Specification (Aitem, True); + + -- If a delay is required, we delay the freeze (not much point in + -- delaying the aspect if we don't delay the freeze!). The pragma + -- or clause is then attached to the aspect specification which + -- is placed in the rep item list. + + if Delay_Required then + Ensure_Freeze_Node (E); + Set_Is_Delayed_Aspect (Aitem); + Set_Has_Delayed_Aspects (E); + Set_Aspect_Rep_Item (Aspect, Aitem); + Record_Rep_Item (E, Aspect); + + -- If no delay required, insert the pragma/clause in the tree + + else + -- For Pre/Post cases, insert immediately after the entity + -- declaration, since that is the required pragma placement. + + if A_Id = Aspect_Pre or else A_Id = Aspect_Post then + Insert_After (N, Aitem); + + -- For all other cases, insert in sequence + + else + Insert_After (Ins_Node, Aitem); + Ins_Node := Aitem; + end if; + end if; end; <<Continue>> @@ -1043,9 +1187,7 @@ package body Sem_Ch13 is ---------------------- function Duplicate_Clause return Boolean is - A : constant Node_Id := - Get_Attribute_Definition_Clause - (U_Ent, Get_Attribute_Id (Chars (N))); + A : Node_Id; begin -- Nothing to do if this attribute definition clause comes from an @@ -1057,8 +1199,10 @@ package body Sem_Ch13 is return False; end if; - -- Otherwise current pragma may duplicate previous pragma or a - -- previously given aspect specification for the same pragma. + -- Otherwise current clause may duplicate previous clause or a + -- previously given aspect specification for the same aspect. + + A := Get_Rep_Item_For_Entity (U_Ent, Chars (N)); if Present (A) then if Entity (A) = U_Ent then @@ -1572,12 +1716,11 @@ package body Sem_Ch13 is elsif Csize /= No_Uint then Check_Size (Expr, Ctyp, Csize, Biased); - -- For the biased case, build a declaration for a subtype - -- that will be used to represent the biased subtype that - -- reflects the biased representation of components. We need - -- this subtype to get proper conversions on referencing - -- elements of the array. Note that component size clauses - -- are ignored in VM mode. + -- For the biased case, build a declaration for a subtype that + -- will be used to represent the biased subtype that reflects + -- the biased representation of components. We need the subtype + -- to get proper conversions on referencing elements of the + -- array. Note: component size clauses are ignored in VM mode. if VM_Target = No_VM then if Biased then @@ -4879,6 +5022,17 @@ package body Sem_Ch13 is -- Start of processing for Rep_Item_Too_Late begin + -- If this is from an aspect that was delayed till the freeze point, + -- then we skip this check entirely, since it is not required and + -- furthermore can generate false errors. Also we don't need to chain + -- the item into the rep item chain in that case, it is already there! + + if Nkind_In (N, N_Attribute_Definition_Clause, N_Pragma) + and then Is_Delayed_Aspect (N) + then + return False; + end if; + -- First make sure entity is not frozen (RM 13.1(9)). Exclude imported -- types, which may be frozen if they appear in a representation clause -- for a local type. diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 108112b6f7b..b00d270a4e1 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -159,6 +159,11 @@ package Sem_Ch13 is -- the case of a private or incomplete type. The protocol is to first -- check for Rep_Item_Too_Early using the initial entity, then take the -- underlying type, then call Rep_Item_Too_Late on the result. + -- + -- Note: Calls to Rep_Item_Too_Late are ignored for the case of attribute + -- definition clauses which have From_Aspect_Specification set. This is + -- because such clauses are linked on to the Rep_Item chain in procedure + -- Sem_Ch13.Analyze_Aspect_Specifications. See that procedure for details. function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean; -- Given two types, where the two types are related by possible derivation, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 30127b4386f..954833e9b5f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1619,7 +1619,6 @@ package body Sem_Ch3 is procedure Analyze_Component_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); E : constant Node_Id := Expression (N); - AS : constant List_Id := Aspect_Specifications (N); T : Entity_Id; P : Entity_Id; @@ -1946,7 +1945,7 @@ package body Sem_Ch3 is end if; Set_Original_Record_Component (Id, Id); - Analyze_Aspect_Specifications (N, Id, AS); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Component_Declaration; -------------------------- @@ -2079,7 +2078,6 @@ package body Sem_Ch3 is procedure Analyze_Full_Type_Declaration (N : Node_Id) is Def : constant Node_Id := Type_Definition (N); Def_Id : constant Entity_Id := Defining_Identifier (N); - AS : constant List_Id := Aspect_Specifications (N); T : Entity_Id; Prev : Entity_Id; @@ -2381,7 +2379,8 @@ package body Sem_Ch3 is Set_Optimize_Alignment_Flags (Def_Id); Check_Eliminated (Def_Id); - <<Leave>> Analyze_Aspect_Specifications (N, Def_Id, AS); + <<Leave>> + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); end Analyze_Full_Type_Declaration; ---------------------------------- @@ -2644,7 +2643,6 @@ package body Sem_Ch3 is procedure Analyze_Object_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Entity_Id := Defining_Identifier (N); - AS : constant List_Id := Aspect_Specifications (N); T : Entity_Id; Act_T : Entity_Id; @@ -3530,7 +3528,8 @@ package body Sem_Ch3 is Check_Restriction (No_Local_Timing_Events, N); end if; - <<Leave>> Analyze_Aspect_Specifications (N, Id, AS); + <<Leave>> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Object_Declaration; --------------------------- @@ -3553,7 +3552,6 @@ package body Sem_Ch3 is procedure Analyze_Private_Extension_Declaration (N : Node_Id) is T : constant Entity_Id := Defining_Identifier (N); Indic : constant Node_Id := Subtype_Indication (N); - AS : constant List_Id := Aspect_Specifications (N); Parent_Type : Entity_Id; Parent_Base : Entity_Id; @@ -3740,7 +3738,8 @@ package body Sem_Ch3 is end if; end if; - <<Leave>> Analyze_Aspect_Specifications (N, T, AS); + <<Leave>> + Analyze_Aspect_Specifications (N, T, Aspect_Specifications (N)); end Analyze_Private_Extension_Declaration; --------------------------------- @@ -3752,7 +3751,6 @@ package body Sem_Ch3 is Skip : Boolean := False) is Id : constant Entity_Id := Defining_Identifier (N); - AS : constant List_Id := Aspect_Specifications (N); T : Entity_Id; R_Checks : Check_Result; @@ -4152,10 +4150,19 @@ package body Sem_Ch3 is end if; end if; + -- Make sure that generic actual types are properly frozen + + if Expander_Active + and then Is_Generic_Actual_Type (Id) + then + Insert_Actions (N, Freeze_Entity (Id, N)); + end if; + Set_Optimize_Alignment_Flags (Id); Check_Eliminated (Id); - <<Leave>> Analyze_Aspect_Specifications (N, Id, AS); + <<Leave>> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Subtype_Declaration; -------------------------------- @@ -14345,7 +14352,7 @@ package body Sem_Ch3 is then null; else - Insert_Actions (Obj_Def, Freeze_Entity (T, Sloc (P))); + Insert_Actions (Obj_Def, Freeze_Entity (T, P)); end if; -- Ada 2005 AI-406: the object definition in an object declaration diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 7d163c1b90b..2bff2e2bbd9 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -227,6 +227,8 @@ package Sem_Ch3 is -- In_Default_Expression flag. See the documentation section entitled -- "Handling of Default and Per-Object Expressions" in sem.ads for full -- details. N is the expression to be analyzed, T is the expected type. + -- This mechanism is also used for aspect specifications that have an + -- expression parameter that needs similar preanalysis. procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); -- Process some semantic actions when the full view of a private type is diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 5887ea563e9..f74d24e3b06 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1841,7 +1841,7 @@ package body Sem_Ch5 is -- declared "within" must be frozen explicitly. declare - Flist : constant List_Id := Freeze_Entity (Id, Sloc (N)); + Flist : constant List_Id := Freeze_Entity (Id, N); begin if Is_Non_Empty_List (Flist) then Insert_Actions (N, Flist); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 58cfae39577..4a2d3df4e36 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -354,7 +354,6 @@ package body Sem_Ch6 is Designator : constant Entity_Id := Analyze_Subprogram_Specification (Specification (N)); Scop : constant Entity_Id := Current_Scope; - AS : constant List_Id := Aspect_Specifications (N); begin Generate_Definition (Designator); @@ -384,7 +383,7 @@ package body Sem_Ch6 is Generate_Reference_To_Formals (Designator); Check_Eliminated (Designator); - Analyze_Aspect_Specifications (N, Designator, AS); + Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N)); end Analyze_Abstract_Subprogram_Declaration; ---------------------------------------- @@ -2168,7 +2167,7 @@ package body Sem_Ch6 is -- why, to be investigated further??? Set_Has_Delayed_Freeze (Spec_Id); - Insert_Actions (N, Freeze_Entity (Spec_Id, Loc)); + Insert_Actions (N, Freeze_Entity (Spec_Id, N)); end if; end if; @@ -2700,7 +2699,6 @@ package body Sem_Ch6 is procedure Analyze_Subprogram_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - AS : constant List_Id := Aspect_Specifications (N); Scop : constant Entity_Id := Current_Scope; Designator : Entity_Id; Form : Node_Id; @@ -2710,9 +2708,9 @@ package body Sem_Ch6 is begin -- For a null procedure, capture the profile before analysis, for - -- expansion at the freeze point and at each point of call. - -- The body will only be used if the procedure has preconditions. - -- In that case the body is analyzed at the freeze point. + -- expansion at the freeze point and at each point of call. The body + -- will only be used if the procedure has preconditions. In that case + -- the body is analyzed at the freeze point. if Nkind (Specification (N)) = N_Procedure_Specification and then Null_Present (Specification (N)) @@ -2897,7 +2895,7 @@ package body Sem_Ch6 is Write_Eol; end if; - Analyze_Aspect_Specifications (N, Designator, AS); + Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N)); end Analyze_Subprogram_Declaration; -------------------------------------- @@ -8825,7 +8823,6 @@ package body Sem_Ch6 is ------------------------- procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); Decl : Node_Id; Formal : Entity_Id; T : Entity_Id; @@ -8939,7 +8936,7 @@ package body Sem_Ch6 is if Present (First_Stmt) then Insert_List_Before_And_Analyze (First_Stmt, - Freeze_Entity (Defining_Identifier (Decl), Loc)); + Freeze_Entity (Defining_Identifier (Decl), N)); end if; if Nkind (N) = N_Accept_Statement diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index fc20f72cbf0..e3555525118 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -751,7 +751,6 @@ package body Sem_Ch7 is procedure Analyze_Package_Declaration (N : Node_Id) is Id : constant Node_Id := Defining_Entity (N); - AS : constant List_Id := Aspect_Specifications (N); PF : Boolean; -- True when in the context of a declared pure library unit @@ -846,7 +845,8 @@ package body Sem_Ch7 is Write_Eol; end if; - <<Leave>> Analyze_Aspect_Specifications (N, Id, AS); + <<Leave>> + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Package_Declaration; ----------------------------------- @@ -1417,7 +1417,6 @@ package body Sem_Ch7 is procedure Analyze_Private_Type_Declaration (N : Node_Id) is PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity); Id : constant Entity_Id := Defining_Identifier (N); - AS : constant List_Id := Aspect_Specifications (N); begin Generate_Definition (Id); @@ -1432,7 +1431,7 @@ package body Sem_Ch7 is New_Private_Type (N, Id, N); Set_Depends_On_Private (Id); - Analyze_Aspect_Specifications (N, Id, AS); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Private_Type_Declaration; ---------------------------------- diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 02f44836379..bcf38cd0a85 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -875,7 +875,6 @@ package body Sem_Ch9 is D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); Def_Id : constant Entity_Id := Defining_Identifier (N); Formals : constant List_Id := Parameter_Specifications (N); - AS : constant List_Id := Aspect_Specifications (N); begin Generate_Definition (Def_Id); @@ -907,7 +906,7 @@ package body Sem_Ch9 is end if; Generate_Reference_To_Formals (Def_Id); - Analyze_Aspect_Specifications (N, Def_Id, AS); + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); end Analyze_Entry_Declaration; --------------------------------------- @@ -1132,7 +1131,6 @@ package body Sem_Ch9 is procedure Analyze_Protected_Type_Declaration (N : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); - AS : constant List_Id := Aspect_Specifications (N); E : Entity_Id; T : Entity_Id; @@ -1260,7 +1258,8 @@ package body Sem_Ch9 is end if; end if; - <<Leave>> Analyze_Aspect_Specifications (N, Def_Id, AS); + <<Leave>> + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); end Analyze_Protected_Type_Declaration; --------------------- @@ -1665,7 +1664,6 @@ package body Sem_Ch9 is procedure Analyze_Single_Protected_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Node_Id := Defining_Identifier (N); - AS : constant List_Id := Aspect_Specifications (N); T : Entity_Id; T_Decl : Node_Id; O_Decl : Node_Id; @@ -1713,7 +1711,7 @@ package body Sem_Ch9 is -- disastrous result. Analyze_Protected_Type_Declaration (N); - Analyze_Aspect_Specifications (N, Id, AS); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Single_Protected_Declaration; ------------------------------------- @@ -1723,7 +1721,6 @@ package body Sem_Ch9 is procedure Analyze_Single_Task_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Node_Id := Defining_Identifier (N); - AS : constant List_Id := Aspect_Specifications (N); T : Entity_Id; T_Decl : Node_Id; O_Decl : Node_Id; @@ -1779,7 +1776,7 @@ package body Sem_Ch9 is -- disastrous result. Analyze_Task_Type_Declaration (N); - Analyze_Aspect_Specifications (N, Id, AS); + Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N)); end Analyze_Single_Task_Declaration; ----------------------- @@ -1952,7 +1949,6 @@ package body Sem_Ch9 is procedure Analyze_Task_Type_Declaration (N : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); - AS : constant List_Id := Aspect_Specifications (N); T : Entity_Id; begin @@ -2051,7 +2047,7 @@ package body Sem_Ch9 is end if; end if; - Analyze_Aspect_Specifications (N, Def_Id, AS); + Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N)); end Analyze_Task_Type_Declaration; ----------------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 6a613f97948..c7414b94d9a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -178,14 +178,6 @@ package body Sem_Prag is -- original one, following the renaming chain) is returned. Otherwise the -- entity is returned unchanged. Should be in Einfo??? - function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; - -- All the routines that check pragma arguments take either a pragma - -- argument association (in which case the expression of the argument - -- association is checked), or the expression directly. The function - -- Get_Pragma_Arg is a utility used to deal with these two cases. If Arg - -- is a pragma argument association node, then its expression is returned, - -- otherwise Arg is returned unchanged. - procedure rv; -- This is a dummy function called by the processing for pragma Reviewable. -- It is there for assisting front end debugging. By placing a Reviewable @@ -416,8 +408,9 @@ package body Sem_Prag is procedure Check_Duplicate_Pragma (E : Entity_Id); -- Check if a pragma of the same name as the current pragma is already - -- chained as a rep pragma to the given entity. if so give a message + -- chained as a rep pragma to the given entity. If so give a message -- about the duplicate, and then raise Pragma_Exit so does not return. + -- Also checks for delayed aspect specification node in the chain. procedure Check_Duplicated_Export_Name (Nam : Node_Id); -- Nam is an N_String_Literal node containing the external name set by @@ -1232,8 +1225,7 @@ package body Sem_Prag is ---------------------------- procedure Check_Duplicate_Pragma (E : Entity_Id) is - P : constant Node_Id := Get_Rep_Pragma (E, Pragma_Name (N)); - Arg : Node_Id; + P : Node_Id; begin -- Nothing to do if this pragma comes from an aspect specification, @@ -1247,27 +1239,21 @@ package body Sem_Prag is -- Otherwise current pragma may duplicate previous pragma or a -- previously given aspect specification for the same pragma. - if Present (P) then - - -- Make sure pragma is for this entity, and not for some parent - -- entity in the case of a derived type. + P := Get_Rep_Item_For_Entity (E, Pragma_Name (N)); - Arg := Get_Pragma_Arg (First (Pragma_Argument_Associations (P))); + if Present (P) then + Error_Msg_Name_1 := Pragma_Name (N); + Error_Msg_Sloc := Sloc (P); - if Nkind (Arg) = N_Identifier - and then Entity (Arg) = E + if Nkind (P) = N_Aspect_Specification + or else From_Aspect_Specification (P) then - Error_Msg_Name_1 := Pname; - Error_Msg_Sloc := Sloc (P); - - if From_Aspect_Specification (P) then - Error_Msg_NE ("aspect% for & previously specified#", N, E); - else - Error_Msg_NE ("pragma% for & duplicates pragma#", N, E); - end if; - - raise Pragma_Exit; + Error_Msg_NE ("aspect% for & previously specified#", N, E); + else + Error_Msg_NE ("pragma% for & duplicates pragma#", N, E); end if; + + raise Pragma_Exit; end if; end Check_Duplicate_Pragma; @@ -13358,19 +13344,6 @@ package body Sem_Prag is return Result; end Get_Base_Subprogram; - -------------------- - -- Get_Pragma_Arg -- - -------------------- - - function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is - begin - if Nkind (Arg) = N_Pragma_Argument_Association then - return Expression (Arg); - else - return Arg; - end if; - end Get_Pragma_Arg; - ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 3a5ffc23be1..5a144846821 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -32,8 +32,7 @@ pragma Style_Checks (All_Checks); -- No subprogram ordering check, due to logical grouping -with Aspects; use Aspects; -with Atree; use Atree; +with Atree; use Atree; package body Sinfo is @@ -264,6 +263,14 @@ package body Sinfo is return Flag11 (N); end Aspect_Cancel; + function Aspect_Rep_Item + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification); + return Node2 (N); + end Aspect_Rep_Item; + function Assignment_OK (N : Node_Id) return Boolean is begin @@ -1048,8 +1055,9 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind in N_Has_Entity - or else NT (N).Nkind = N_Freeze_Entity - or else NT (N).Nkind = N_Attribute_Definition_Clause); + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Freeze_Entity); return Node4 (N); end Entity; @@ -1400,13 +1408,6 @@ package body Sinfo is return Node2 (N); end Handler_List_Entry; - function Has_Aspect_Specifications - (N : Node_Id) return Boolean is - begin - pragma Assert (Permits_Aspect_Specifications (N)); - return Flag3 (N); - end Has_Aspect_Specifications; - function Has_Created_Identifier (N : Node_Id) return Boolean is begin @@ -1690,6 +1691,15 @@ package body Sinfo is return Flag16 (N); end Is_Controlling_Actual; + function Is_Delayed_Aspect + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Pragma); + return Flag14 (N); + end Is_Delayed_Aspect; + function Is_Dynamic_Coextension (N : Node_Id) return Boolean is begin @@ -2116,6 +2126,7 @@ package body Sinfo is (N : Node_Id) return Node_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Enumeration_Representation_Clause or else NT (N).Nkind = N_Pragma @@ -3212,6 +3223,14 @@ package body Sinfo is Set_Flag11 (N, Val); end Set_Aspect_Cancel; + procedure Set_Aspect_Rep_Item + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification); + Set_Node2 (N, Val); + end Set_Aspect_Rep_Item; + procedure Set_Assignment_OK (N : Node_Id; Val : Boolean := True) is begin @@ -3996,8 +4015,9 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind in N_Has_Entity - or else NT (N).Nkind = N_Freeze_Entity - or else NT (N).Nkind = N_Attribute_Definition_Clause); + or else NT (N).Nkind = N_Aspect_Specification + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Freeze_Entity); Set_Node4 (N, Val); -- semantic field, no parent set end Set_Entity; @@ -4339,13 +4359,6 @@ package body Sinfo is Set_Node2 (N, Val); end Set_Handler_List_Entry; - procedure Set_Has_Aspect_Specifications - (N : Node_Id; Val : Boolean := True) is - begin - pragma Assert (Permits_Aspect_Specifications (N)); - Set_Flag3 (N, Val); - end Set_Has_Aspect_Specifications; - procedure Set_Has_Created_Identifier (N : Node_Id; Val : Boolean := True) is begin @@ -4630,6 +4643,15 @@ package body Sinfo is Set_Flag16 (N, Val); end Set_Is_Controlling_Actual; + procedure Set_Is_Delayed_Aspect + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Pragma); + Set_Flag14 (N, Val); + end Set_Is_Delayed_Aspect; + procedure Set_Is_Dynamic_Coextension (N : Node_Id; Val : Boolean := True) is begin @@ -5056,6 +5078,7 @@ package body Sinfo is (N : Node_Id; Val : Node_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Aspect_Specification or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Enumeration_Representation_Clause or else NT (N).Nkind = N_Pragma @@ -5980,6 +6003,19 @@ package body Sinfo is end if; end End_Location; + -------------------- + -- Get_Pragma_Arg -- + -------------------- + + function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is + begin + if Nkind (Arg) = N_Pragma_Argument_Association then + return Expression (Arg); + else + return Arg; + end if; + end Get_Pragma_Arg; + ---------------------- -- Set_End_Location -- ---------------------- diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 04d892f29d2..ed14a866334 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -595,6 +595,10 @@ package Sinfo is -- aspect (i.e. turn if off), the generated pragma has the Aspect_Cancel -- flag set to indicate that the pragma operates in the opposite sense. + -- Aspect_Rep_Item (Node2-Sem) + -- Present in N_Aspect_Specification nodes. Points to the corresponding + -- pragma/attribute definition node used to process the aspect. + -- Assignment_OK (Flag15-Sem) -- This flag is set in a subexpression node for an object, indicating -- that the associated object can be modified, even if this would not @@ -1230,6 +1234,11 @@ package Sinfo is -- operand is of the component type of the result. Used in resolving -- concatenation nodes in instances. + -- Is_Delayed_Aspect (Flag14-Sem) + -- Present in N_Pragma and N_Attribute_Definition_Clause nodes which + -- come from aspect specifications, where the evaluation of the aspect + -- must be delayed to the freeze point. + -- Is_Controlling_Actual (Flag16-Sem) -- This flag is set on in an expression that is a controlling argument in -- a dispatching call. It is off in all other cases. See Sem_Disp for @@ -1456,9 +1465,10 @@ package Sinfo is -- details). -- Next_Rep_Item (Node5-Sem) - -- Present in pragma nodes and attribute definition nodes. Used to link - -- representation items that apply to an entity. See description of - -- First_Rep_Item field in Einfo for full details. + -- Present in pragma nodes, attribute definition nodes, enumeration rep + -- clauses, record rep clauses, aspect specification nodes. Used to link + -- representation items that apply to an entity. See full description of + -- First_Rep_Item field in Einfo for further details. -- Next_Use_Clause (Node3-Sem) -- While use clauses are active during semantic processing, they are @@ -2015,6 +2025,7 @@ package Sinfo is -- Next_Rep_Item (Node5-Sem) -- Pragma_Enabled (Flag5-Sem) -- From_Aspect_Specification (Flag13-Sem) + -- Is_Delayed_Aspect (Flag14-Sem) -- Import_Interface_Present (Flag16-Sem) -- Aspect_Cancel (Flag11-Sem) @@ -2123,9 +2134,6 @@ package Sinfo is -- Discriminant_Specifications (List4) (set to No_List if none) -- Type_Definition (Node3) -- Discr_Check_Funcs_Built (Flag11-Sem) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ---------------------------- -- 3.2.1 Type Definition -- @@ -2154,9 +2162,6 @@ package Sinfo is -- Subtype_Indication (Node5) -- Generic_Parent_Type (Node4-Sem) (set for an actual derived type). -- Exception_Junk (Flag8-Sem) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ------------------------------- -- 3.2.2 Subtype Indication -- @@ -2287,9 +2292,6 @@ package Sinfo is -- Exception_Junk (Flag8-Sem) -- Is_Subprogram_Descriptor (Flag16-Sem) -- Has_Init_Expression (Flag14) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ------------------------------------- -- 3.3.1 Defining Identifier List -- @@ -2862,9 +2864,6 @@ package Sinfo is -- Expression (Node3) (set to Empty if no default expression) -- More_Ids (Flag5) (set to False if no more identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ------------------------- -- 3.8.1 Variant Part -- @@ -4218,9 +4217,6 @@ package Sinfo is -- Body_To_Inline (Node3-Sem) -- Corresponding_Body (Node5-Sem) -- Parent_Spec (Node4-Sem) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ------------------------------------------ -- 6.1 Abstract Subprogram Declaration -- @@ -4232,9 +4228,6 @@ package Sinfo is -- N_Abstract_Subprogram_Declaration -- Sloc points to ABSTRACT -- Specification (Node1) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ----------------------------------- -- 6.1 Subprogram Specification -- @@ -4658,9 +4651,6 @@ package Sinfo is -- Corresponding_Body (Node5-Sem) -- Parent_Spec (Node4-Sem) -- Activation_Chain_Entity (Node3-Sem) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature -------------------------------- -- 7.1 Package Specification -- @@ -4727,9 +4717,6 @@ package Sinfo is -- Abstract_Present (Flag4) -- Tagged_Present (Flag15) -- Limited_Present (Flag17) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ---------------------------------------- -- 7.4 Private Extension Declaration -- @@ -4755,9 +4742,6 @@ package Sinfo is -- Synchronized_Present (Flag7) -- Subtype_Indication (Node5) -- Interface_List (List2) (set to No_List if none) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature --------------------- -- 8.4 Use Clause -- @@ -4915,9 +4899,6 @@ package Sinfo is -- Interface_List (List2) (set to No_List if none) -- Task_Definition (Node3) (set to Empty if not present) -- Corresponding_Body (Node5-Sem) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ---------------------------------- -- 9.1 Single Task Declaration -- @@ -4932,9 +4913,6 @@ package Sinfo is -- Defining_Identifier (Node1) -- Interface_List (List2) (set to No_List if none) -- Task_Definition (Node3) (set to Empty if not present) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature -------------------------- -- 9.1 Task Definition -- @@ -5007,9 +4985,6 @@ package Sinfo is -- Interface_List (List2) (set to No_List if none) -- Protected_Definition (Node3) -- Corresponding_Body (Node5-Sem) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature --------------------------------------- -- 9.4 Single Protected Declaration -- @@ -5026,9 +5001,6 @@ package Sinfo is -- Defining_Identifier (Node1) -- Interface_List (List2) (set to No_List if none) -- Protected_Definition (Node3) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ------------------------------- -- 9.4 Protected Definition -- @@ -5111,10 +5083,8 @@ package Sinfo is -- Corresponding_Body (Node5-Sem) -- Must_Override (Flag14) set if overriding indicator present -- Must_Not_Override (Flag15) set if not_overriding indicator present - -- Has_Aspect_Specifications (Flag3) -- Note: overriding indicator is an Ada 2005 feature - -- Note: Aspect_Specification is an Ada 2012 feature ----------------------------- -- 9.5.2 Accept statement -- @@ -5778,9 +5748,6 @@ package Sinfo is -- Renaming_Exception (Node2-Sem) -- More_Ids (Flag5) (set to False if no more identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ------------------------------------------ -- 11.2 Handled Sequence Of Statements -- @@ -5929,9 +5896,6 @@ package Sinfo is -- Corresponding_Body (Node5-Sem) -- Generic_Formal_Declarations (List2) from generic formal part -- Parent_Spec (Node4-Sem) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature --------------------------------------- -- 12.1 Generic Package Declaration -- @@ -5953,9 +5917,6 @@ package Sinfo is -- Generic_Formal_Declarations (List2) from generic formal part -- Parent_Spec (Node4-Sem) -- Activation_Chain_Entity (Node3-Sem) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ------------------------------- -- 12.1 Generic Formal Part -- @@ -5997,7 +5958,6 @@ package Sinfo is -- Parent_Spec (Node4-Sem) -- Instance_Spec (Node5-Sem) -- ABE_Is_Certain (Flag18-Sem) - -- Has_Aspect_Specifications (Flag3) -- N_Procedure_Instantiation -- Sloc points to PROCEDURE @@ -6010,7 +5970,6 @@ package Sinfo is -- Must_Override (Flag14) set if overriding indicator present -- Must_Not_Override (Flag15) set if not_overriding indicator present -- ABE_Is_Certain (Flag18-Sem) - -- Has_Aspect_Specifications (Flag3) -- N_Function_Instantiation -- Sloc points to FUNCTION @@ -6023,10 +5982,8 @@ package Sinfo is -- Must_Override (Flag14) set if overriding indicator present -- Must_Not_Override (Flag15) set if not_overriding indicator present -- ABE_Is_Certain (Flag18-Sem) - -- Has_Aspect_Specifications (Flag3) -- Note: overriding indicator is an Ada 2005 feature - -- Note: Aspect_Specification is an Ada 2012 feature ------------------------------- -- 12.3 Generic Actual Part -- @@ -6097,9 +6054,6 @@ package Sinfo is -- Default_Expression (Node5) (set to Empty if no default expression) -- More_Ids (Flag5) (set to False if no more identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ----------------------------------- -- 12.5 Formal Type Declaration -- @@ -6116,9 +6070,6 @@ package Sinfo is -- Discriminant_Specifications (List4) (set to No_List if no -- discriminant part) -- Unknown_Discriminants_Present (Flag13) set if (<>) discriminant - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature ---------------------------------- -- 12.5 Formal type definition -- @@ -6264,13 +6215,10 @@ package Sinfo is -- Specification (Node1) -- Default_Name (Node2) (set to Empty if no subprogram default) -- Box_Present (Flag15) - -- Has_Aspect_Specifications (Flag3) -- Note: if no subprogram default is present, then Name is set -- to Empty, and Box_Present is False. - -- Note: Aspect_Specification is an Ada 2012 feature - -------------------------------------------------- -- 12.6 Formal Abstract Subprogram Declaration -- -------------------------------------------------- @@ -6283,13 +6231,10 @@ package Sinfo is -- Specification (Node1) -- Default_Name (Node2) (set to Empty if no subprogram default) -- Box_Present (Flag15) - -- Has_Aspect_Specifications (Flag3) -- Note: if no subprogram default is present, then Name is set -- to Empty, and Box_Present is False. - -- Note: Aspect_Specification is an Ada 2012 feature - ------------------------------ -- 12.6 Subprogram Default -- ------------------------------ @@ -6326,9 +6271,6 @@ package Sinfo is -- Box_Present (Flag15) -- Instance_Spec (Node5-Sem) -- ABE_Is_Certain (Flag18-Sem) - -- Has_Aspect_Specifications (Flag3) - - -- Note: Aspect_Specification is an Ada 2012 feature -------------------------------------- -- 12.7 Formal Package Actual Part -- @@ -6417,6 +6359,7 @@ package Sinfo is -- From_At_Mod (Flag4-Sem) -- Check_Address_Alignment (Flag11-Sem) -- From_Aspect_Specification (Flag13-Sem) + -- Is_Delayed_Aspect (Flag14-Sem) -- Address_Warning_Posted (Flag18-Sem) -- Note: if From_Aspect_Specification is set, then Sloc points to the @@ -6457,8 +6400,11 @@ package Sinfo is -- N_Aspect_Specification -- Sloc points to aspect identifier -- Identifier (Node1) aspect identifier + -- Aspect_Rep_Item (Node2-Sem) -- Expression (Node3) Aspect_Definition (set to Empty if none) + -- Entity (Node4-Sem) entity to which the aspect applies -- Class_Present (Flag6) Set if 'Class present + -- Next_Rep_Item (Node5-Sem) -- Note: Aspect_Specification is an Ada 2012 feature @@ -7302,10 +7248,10 @@ package Sinfo is -------------------------- -- The following is the definition of the Node_Kind type. As previously - -- discussed, this is separated off to allow rearrangement of the order - -- to facilitate definition of subtype ranges. The comments show the - -- subtype classes which apply to each set of node kinds. The first - -- entry in the comment characterizes the following list of nodes. + -- discussed, this is separated off to allow rearrangement of the order to + -- facilitate definition of subtype ranges. The comments show the subtype + -- classes which apply to each set of node kinds. The first entry in the + -- comment characterizes the following list of nodes. type Node_Kind is ( N_Unused_At_Start, @@ -7317,7 +7263,6 @@ package Sinfo is N_Enumeration_Representation_Clause, N_Mod_Clause, N_Record_Representation_Clause, - N_Aspect_Specification, -- N_Representation_Clause, N_Has_Chars @@ -7621,6 +7566,7 @@ package Sinfo is N_Abstract_Subprogram_Declaration, N_Access_Definition, N_Access_To_Object_Definition, + N_Aspect_Specification, N_Case_Expression_Alternative, N_Case_Statement_Alternative, N_Compilation_Unit, @@ -7747,7 +7693,8 @@ package Sinfo is N_Expanded_Name .. N_Attribute_Reference; -- Nodes that have Entity fields - -- Warning: DOES NOT INCLUDE N_Freeze_Entity! + -- Warning: DOES NOT INCLUDE N_Freeze_Entity, N_Aspect_Specification, + -- or N_Attribute_Definition_Clause. subtype N_Has_Etype is Node_Kind range N_Error .. @@ -7942,6 +7889,9 @@ package Sinfo is function Aspect_Cancel (N : Node_Id) return Boolean; -- Flag11 + function Aspect_Rep_Item + (N : Node_Id) return Node_Id; -- Node2 + function Assignment_OK (N : Node_Id) return Boolean; -- Flag15 @@ -8296,9 +8246,6 @@ package Sinfo is function Handler_List_Entry (N : Node_Id) return Node_Id; -- Node2 - function Has_Aspect_Specifications - (N : Node_Id) return Boolean; -- Flag3 - function Has_Created_Identifier (N : Node_Id) return Boolean; -- Flag15 @@ -8395,6 +8342,9 @@ package Sinfo is function Is_Controlling_Actual (N : Node_Id) return Boolean; -- Flag16 + function Is_Delayed_Aspect + (N : Node_Id) return Boolean; -- Flag14 + function Is_Dynamic_Coextension (N : Node_Id) return Boolean; -- Flag18 @@ -8881,12 +8831,12 @@ package Sinfo is procedure Set_Array_Aggregate (N : Node_Id; Val : Node_Id); -- Node3 - procedure Set_Has_Aspect_Specifications - (N : Node_Id; Val : Boolean := True); -- Flag3 - procedure Set_Aspect_Cancel (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Aspect_Rep_Item + (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Assignment_OK (N : Node_Id; Val : Boolean := True); -- Flag15 @@ -9334,6 +9284,9 @@ package Sinfo is procedure Set_Is_Controlling_Actual (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Is_Delayed_Aspect + (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Is_Dynamic_Coextension (N : Node_Id; Val : Boolean := True); -- Flag18 @@ -9756,20 +9709,25 @@ package Sinfo is procedure Next_Rep_Item (N : in out Node_Id); procedure Next_Use_Clause (N : in out Node_Id); - -------------------------------------- - -- Logical Access to End_Span Field -- - -------------------------------------- + ------------------------------------------- + -- Miscellaneous Tree Access Subprograms -- + ------------------------------------------- function End_Location (N : Node_Id) return Source_Ptr; - -- N is an N_If_Statement or N_Case_Statement node, and this - -- function returns the location of the IF token in the END IF - -- sequence by translating the value of the End_Span field. + -- N is an N_If_Statement or N_Case_Statement node, and this function + -- returns the location of the IF token in the END IF sequence by + -- translating the value of the End_Span field. procedure Set_End_Location (N : Node_Id; S : Source_Ptr); - -- N is an N_If_Statement or N_Case_Statement node. This procedure - -- sets the End_Span field to correspond to the given value S. In - -- other words, End_Span is set to the difference between S and - -- Sloc (N), the starting location. + -- N is an N_If_Statement or N_Case_Statement node. This procedure sets + -- the End_Span field to correspond to the given value S. In other words, + -- End_Span is set to the difference between S and Sloc (N), the starting + -- location. + + function Get_Pragma_Arg (Arg : Node_Id) return Node_Id; + -- Given an argument to a pragma Arg, this function returns the expression + -- for the argument. This is Arg itself, or, in the case where Arg is a + -- pragma argument association node, the expression from this node. -------------------------------- -- Node_Kind Membership Tests -- @@ -11165,10 +11123,10 @@ package Sinfo is N_Aspect_Specification => (1 => True, -- Identifier (Node1) - 2 => False, -- unused + 2 => False, -- Aspect_Rep_Item (Node2-Sem) 3 => True, -- Expression (Node3) - 4 => False, -- unused - 5 => False), -- unused + 4 => False, -- Entity (Node4-Sem) + 5 => False), -- Next_Rep_Item (Node5-Sem) N_Enumeration_Representation_Clause => (1 => True, -- Identifier (Node1) @@ -11482,6 +11440,7 @@ package Sinfo is pragma Inline (Ancestor_Part); pragma Inline (Array_Aggregate); pragma Inline (Aspect_Cancel); + pragma Inline (Aspect_Rep_Item); pragma Inline (Assignment_OK); pragma Inline (Associated_Node); pragma Inline (At_End_Proc); @@ -11600,7 +11559,6 @@ package Sinfo is pragma Inline (Generic_Parent_Type); pragma Inline (Handled_Statement_Sequence); pragma Inline (Handler_List_Entry); - pragma Inline (Has_Aspect_Specifications); pragma Inline (Has_Created_Identifier); pragma Inline (Has_Dynamic_Length_Check); pragma Inline (Has_Dynamic_Range_Check); @@ -11633,6 +11591,7 @@ package Sinfo is pragma Inline (Is_Component_Left_Opnd); pragma Inline (Is_Component_Right_Opnd); pragma Inline (Is_Controlling_Actual); + pragma Inline (Is_Delayed_Aspect); pragma Inline (Is_Dynamic_Coextension); pragma Inline (Is_Elsif); pragma Inline (Is_Entry_Barrier_Function); @@ -11793,6 +11752,7 @@ package Sinfo is pragma Inline (Set_Ancestor_Part); pragma Inline (Set_Array_Aggregate); pragma Inline (Set_Aspect_Cancel); + pragma Inline (Set_Aspect_Rep_Item); pragma Inline (Set_Assignment_OK); pragma Inline (Set_Associated_Node); pragma Inline (Set_At_End_Proc); @@ -11910,7 +11870,6 @@ package Sinfo is pragma Inline (Set_Generic_Parent_Type); pragma Inline (Set_Handled_Statement_Sequence); pragma Inline (Set_Handler_List_Entry); - pragma Inline (Set_Has_Aspect_Specifications); pragma Inline (Set_Has_Created_Identifier); pragma Inline (Set_Has_Dynamic_Length_Check); pragma Inline (Set_Has_Init_Expression); @@ -11942,6 +11901,7 @@ package Sinfo is pragma Inline (Set_Is_Component_Left_Opnd); pragma Inline (Set_Is_Component_Right_Opnd); pragma Inline (Set_Is_Controlling_Actual); + pragma Inline (Set_Is_Delayed_Aspect); pragma Inline (Set_Is_Dynamic_Coextension); pragma Inline (Set_Is_Elsif); pragma Inline (Set_Is_Entry_Barrier_Function); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 74da13ff47d..ada95bcf784 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -184,10 +184,10 @@ package body Sprint is -- Print the given list with items separated by vertical "and" procedure Sprint_Aspect_Specifications (Node : Node_Id); - -- Node is a declaration node that accepts aspect specifications. This - -- procedure tests if aspect specifications are present, and if so prints - -- them, with a terminating semicolon. If no aspect specifications are - -- present, then a single semicolon is output. + -- Node is a declaration node that has aspect specifications (Has_Aspects + -- flag set True). It is called after outputting the terminating semicolon + -- for the related node. The effect is to remove the semicolon and print + -- the aspect specifications, followed by a terminating semicolon. procedure Sprint_Bar_List (List : List_Id); -- Print the given list with items separated by vertical bars @@ -631,40 +631,37 @@ package body Sprint is ---------------------------------- procedure Sprint_Aspect_Specifications (Node : Node_Id) is - AS : List_Id; + AS : constant List_Id := Aspect_Specifications (Node); A : Node_Id; begin - if Has_Aspect_Specifications (Node) then - AS := Aspect_Specifications (Node); - Indent := Indent + 2; - Write_Indent; - Write_Str ("with "); - Indent := Indent + 5; + Write_Erase_Char (';'); + Indent := Indent + 2; + Write_Indent; + Write_Str ("with "); + Indent := Indent + 5; - A := First (AS); - loop - Sprint_Node (Identifier (A)); + A := First (AS); + loop + Sprint_Node (Identifier (A)); - if Class_Present (A) then - Write_Str ("'Class"); - end if; + if Class_Present (A) then + Write_Str ("'Class"); + end if; - if Present (Expression (A)) then - Write_Str (" => "); - Sprint_Node (Expression (A)); - end if; + if Present (Expression (A)) then + Write_Str (" => "); + Sprint_Node (Expression (A)); + end if; - Next (A); + Next (A); - exit when No (A); - Write_Char (','); - Write_Indent; - end loop; - - Indent := Indent - 7; - end if; + exit when No (A); + Write_Char (','); + Write_Indent; + end loop; + Indent := Indent - 7; Write_Char (';'); end Sprint_Aspect_Specifications; @@ -864,8 +861,7 @@ package body Sprint is Write_Indent; Sprint_Node (Specification (Node)); Write_Str_With_Col_Check (" is "); - Write_Str_Sloc ("abstract"); - Sprint_Aspect_Specifications (Node); + Write_Str_Sloc ("abstract;"); when N_Accept_Alternative => Sprint_Node_List (Pragmas_Before (Node)); @@ -1274,7 +1270,7 @@ package body Sprint is Sprint_Node (Expression (Node)); end if; - Sprint_Aspect_Specifications (Node); + Write_Char (';'); end if; when N_Component_List => @@ -1503,7 +1499,7 @@ package body Sprint is end if; Write_Param_Specs (Node); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Entry_Index_Specification => Write_Str_With_Col_Check_Sloc ("for "); @@ -1549,7 +1545,7 @@ package body Sprint is Sprint_Node (Expression (Node)); end if; - Sprint_Aspect_Specifications (Node); + Write_Char (';'); end if; when N_Exception_Handler => @@ -1675,7 +1671,7 @@ package body Sprint is Sprint_Node (Default_Name (Node)); end if; - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Formal_Concrete_Subprogram_Declaration => Write_Indent_Str_Sloc ("with "); @@ -1688,7 +1684,7 @@ package body Sprint is Sprint_Node (Default_Name (Node)); end if; - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Formal_Discrete_Type_Definition => Write_Str_With_Col_Check_Sloc ("<>"); @@ -1736,7 +1732,7 @@ package body Sprint is Sprint_Node (Default_Expression (Node)); end if; - Sprint_Aspect_Specifications (Node); + Write_Char (';'); end if; when N_Formal_Ordinary_Fixed_Point_Definition => @@ -1747,8 +1743,7 @@ package body Sprint is Write_Id (Defining_Identifier (Node)); Write_Str_With_Col_Check (" is new "); Sprint_Node (Name (Node)); - Write_Str_With_Col_Check (" (<>)"); - Sprint_Aspect_Specifications (Node); + Write_Str_With_Col_Check (" (<>);"); when N_Formal_Private_Type_Definition => if Abstract_Present (Node) then @@ -1780,7 +1775,7 @@ package body Sprint is Write_Str_With_Col_Check (" is "); Sprint_Node (Formal_Type_Definition (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Free_Statement => Write_Indent_Str_Sloc ("free "); @@ -1821,7 +1816,7 @@ package body Sprint is Write_Discr_Specs (Node); Write_Str_With_Col_Check (" is "); Sprint_Node (Type_Definition (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Function_Call => Set_Debug_Sloc; @@ -1834,7 +1829,7 @@ package body Sprint is Write_Str_With_Col_Check (" is new "); Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Function_Specification => Write_Str_With_Col_Check_Sloc ("function "); @@ -1875,7 +1870,7 @@ package body Sprint is Sprint_Indented_List (Generic_Formal_Declarations (Node)); Write_Indent; Sprint_Node (Specification (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Generic_Package_Renaming_Declaration => Write_Indent_Str_Sloc ("generic package "); @@ -1897,7 +1892,7 @@ package body Sprint is Sprint_Indented_List (Generic_Formal_Declarations (Node)); Write_Indent; Sprint_Node (Specification (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Goto_Statement => Write_Indent_Str_Sloc ("goto "); @@ -2128,7 +2123,7 @@ package body Sprint is Sprint_Node (Expression (Node)); end if; - Sprint_Aspect_Specifications (Node); + Write_Char (';'); -- Handle implicit importation and implicit exportation of -- object declarations: @@ -2369,7 +2364,7 @@ package body Sprint is Extra_Blank_Line; Write_Indent; Sprint_Node_Sloc (Specification (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Package_Instantiation => Extra_Blank_Line; @@ -2378,7 +2373,7 @@ package body Sprint is Write_Str (" is new "); Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Package_Renaming_Declaration => Write_Indent_Str_Sloc ("package "); @@ -2479,8 +2474,7 @@ package body Sprint is Sprint_And_List (Interface_List (Node)); end if; - Write_Str_With_Col_Check (" with private"); - Sprint_Aspect_Specifications (Node); + Write_Str_With_Col_Check (" with private;"); when N_Private_Type_Declaration => Write_Indent_Str_Sloc ("type "); @@ -2502,8 +2496,7 @@ package body Sprint is Write_Str_With_Col_Check ("limited "); end if; - Write_Str_With_Col_Check ("private"); - Sprint_Aspect_Specifications (Node); + Write_Str_With_Col_Check ("private;"); when N_Push_Constraint_Error_Label => Write_Indent_Str ("%push_constraint_error_label ("); @@ -2566,7 +2559,7 @@ package body Sprint is Write_Str_With_Col_Check (" is new "); Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Procedure_Specification => Write_Str_With_Col_Check_Sloc ("procedure "); @@ -2613,7 +2606,7 @@ package body Sprint is Sprint_Node (Protected_Definition (Node)); Write_Id (Defining_Identifier (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Qualified_Expression => Sprint_Node (Subtype_Mark (Node)); @@ -2809,7 +2802,7 @@ package body Sprint is Write_Str (" is"); Sprint_Node (Protected_Definition (Node)); Write_Id (Defining_Identifier (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Single_Task_Declaration => Write_Indent_Str_Sloc ("task "); @@ -2820,7 +2813,7 @@ package body Sprint is Sprint_Node (Task_Definition (Node)); end if; - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Selected_Component => Sprint_Node (Prefix (Node)); @@ -2893,7 +2886,7 @@ package body Sprint is Write_Str_With_Col_Check (" is null"); end if; - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Subprogram_Info => Sprint_Node (Identifier (Node)); @@ -2918,7 +2911,7 @@ package body Sprint is end if; Sprint_Node (Subtype_Indication (Node)); - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Subtype_Indication => Sprint_Node_Sloc (Subtype_Mark (Node)); @@ -2981,7 +2974,7 @@ package body Sprint is Sprint_Node (Task_Definition (Node)); end if; - Sprint_Aspect_Specifications (Node); + Write_Char (';'); when N_Terminate_Alternative => Sprint_Node_List (Pragmas_Before (Node)); @@ -3144,6 +3137,10 @@ package body Sprint is end if; end case; + if Has_Aspects (Node) then + Sprint_Aspect_Specifications (Node); + end if; + if Nkind (Node) in N_Subexpr and then Do_Range_Check (Node) then diff --git a/gcc/ada/tree_gen.adb b/gcc/ada/tree_gen.adb index 901d373b300..d36e1f74a51 100644 --- a/gcc/ada/tree_gen.adb +++ b/gcc/ada/tree_gen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; with Atree; with Elists; with Fname; @@ -50,6 +51,7 @@ begin if Opt.Tree_Output then Osint.C.Tree_Create; Opt.Tree_Write; + Aspects.Tree_Write; Atree.Tree_Write; Elists.Tree_Write; Fname.Tree_Write; diff --git a/gcc/ada/tree_in.adb b/gcc/ada/tree_in.adb index da78a667294..60f7d45cb4e 100644 --- a/gcc/ada/tree_in.adb +++ b/gcc/ada/tree_in.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -29,6 +29,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; with Atree; with Csets; with Elists; @@ -50,6 +51,7 @@ procedure Tree_In (Desc : File_Descriptor) is begin Tree_IO.Tree_Read_Initialize (Desc); Opt.Tree_Read; + Aspects.Tree_Read; Atree.Tree_Read; Elists.Tree_Read; Fname.Tree_Read; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 2b49cb38748..82d0c86178a 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Csets; use Csets; with Debug; use Debug; @@ -1010,6 +1011,12 @@ package body Treepr is Print_Eol; end if; + if Has_Aspects (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Has_Aspects = True"); + Print_Eol; + end if; + if Has_Dynamic_Range_Check (N) then Print_Str (Prefix_Str_Char); Print_Str ("Has_Dynamic_Range_Check = True"); @@ -1099,7 +1106,10 @@ package body Treepr is when F_Field5 => Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty); - when F_Flag3 => Field_To_Be_Printed := Flag3 (N); + -- Flag3 is obsolete, so this probably gets removed ??? + + when F_Flag3 => Field_To_Be_Printed := Has_Aspects (N); + when F_Flag4 => Field_To_Be_Printed := Flag4 (N); when F_Flag5 => Field_To_Be_Printed := Flag5 (N); when F_Flag6 => Field_To_Be_Printed := Flag6 (N); @@ -1169,11 +1179,14 @@ package body Treepr is when F_Flag17 => Print_Flag (Flag17 (N)); when F_Flag18 => Print_Flag (Flag18 (N)); - -- Flag1,2,3 are no longer used + -- Flag1,2 are no longer used when F_Flag1 => raise Program_Error; when F_Flag2 => raise Program_Error; - when F_Flag3 => raise Program_Error; + + -- Not clear why we need the following ??? + + when F_Flag3 => Print_Flag (Has_Aspects (N)); end case; Print_Eol; @@ -1187,9 +1200,17 @@ package body Treepr is P := P + 1; end loop; end if; - end loop; + -- Print aspects if present + + if Has_Aspects (N) then + Print_Str (Prefix_Str_Char); + Print_Str ("Aspect_Specifications = "); + Print_Field (Union_Id (Aspect_Specifications (N))); + Print_Eol; + end if; + -- Print entity information for entities if Nkind (N) in N_Entity then @@ -1906,6 +1927,10 @@ package body Treepr is Visit_Descendent (Field4 (N)); Visit_Descendent (Field5 (N)); + if Has_Aspects (N) then + Visit_Descendent (Union_Id (Aspect_Specifications (N))); + end if; + -- Entity case else diff --git a/gcc/ada/xtreeprs.adb b/gcc/ada/xtreeprs.adb index 20f05f10a3e..416e5cbba80 100644 --- a/gcc/ada/xtreeprs.adb +++ b/gcc/ada/xtreeprs.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -252,9 +252,6 @@ begin -- Field3 '%' -- Field4 '&' -- Field5 "'" - -- Flag1 "(" - -- Flag2 ")" - -- Flag3 '*' -- Flag4 '+' -- Flag5 ',' -- Flag6 '-' |