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
-- --
------------------------------------------------------------------------------
-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;
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;
-----------------------------------
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
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;
-- 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;
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 --
-------------------
-------------
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
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;
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;
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);
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 --
---------------------
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);
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
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
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
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
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);
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
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
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
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
-- 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
-------------------------------------
-- 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
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);
-- 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 --
------------------------------
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);
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);
-- 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.
-- 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
Pflag1 => False,
Pflag2 => False,
In_List => False,
- Flag3 => False,
+ Has_Aspects => False,
Rewrite_Ins => False,
Analyzed => False,
Comes_From_Source => False,
Pflag1 => False,
Pflag2 => False,
In_List => False,
- Flag3 => False,
+ Has_Aspects => False,
Rewrite_Ins => False,
Analyzed => False,
Comes_From_Source => False,
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;
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;
#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)
#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)
#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)
#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)
#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)
-- 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
-- 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
-- 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
-- Is_Underlying_Record_View Flag246
-- OK_To_Rename Flag247
- -- (unused) Flag3
- -- (unused) Flag200
-- (unused) Flag232
-- (unused) Flag248
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
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);
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);
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 --
----------------------
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 --
--------------------
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));
-- 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.
-- 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
-- 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)
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;
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);
-- 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;
-- 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
-- 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 --
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);
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);
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
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
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;
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;
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);
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
(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,
-- 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);
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;
-- 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.
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
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
-- 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;
-- 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;
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;
end if;
if not Is_Frozen (E) then
- Flist := Freeze_Entity (E, Loc);
+ Flist := Freeze_Entity (E, After);
Process_Flist;
end if;
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
-------------------
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);
-- 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;
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,
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
else
Freeze_And_Append
- (Designated_Type (Etype (Comp)), Loc, Result);
+ (Designated_Type (Etype (Comp)), N, Result);
end if;
end if;
end;
then
Freeze_And_Append
(Designated_Type
- (Component_Type (Etype (Comp))), Loc, Result);
+ (Component_Type (Etype (Comp))), N, Result);
end if;
Prev := Comp;
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);
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;
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))
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;
-- 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
-- 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
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
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
-- 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))
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
-- 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
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
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))
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);
-- 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);
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);
end if;
end if;
- Freeze_And_Append (Etype (Formal), Loc, Result);
+ Freeze_And_Append (Etype (Formal), N, Result);
Next_Formal (Formal);
end loop;
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;
-- 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
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;
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
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);
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);
(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
-- --
-- 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- --
-- -- 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;
-------------------
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 --
-------------
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 --
----------
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;
-------------------
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
then
Gather_Components (Aggr_Type,
Component_List (Def_Node),
- Governed_By => Assoc_List,
+ Governed_By => Component_Associations (Aggr),
Into => Components,
Report_Errors => Errors);
-- 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));
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
-- 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
-- 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
-- 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));
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);
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;
--------------------------------
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;
end if;
end if;
- Analyze_Aspect_Specifications (N, Id, AS);
+ Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
end Analyze_Formal_Object_Declaration;
----------------------------------------------
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;
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;
---------------------------------
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
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;
-------------------------------------
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
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;
------------------------------------
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;
end if;
end if;
- Analyze_Aspect_Specifications (N, Id, AS);
+ Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
end Analyze_Generic_Package_Declaration;
--------------------------------------------
--------------------------------------------
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;
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;
-----------------------------------
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;
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 =>
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;
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)),
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 =>
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;
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
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);
-- Processing based on specific aspect
- case Get_Aspect_Id (Nam) is
+ case A_Id is
-- No_Aspect should be impossible
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 |
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.
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,
when Aspect_Warnings =>
- Ritem :=
+ -- Construct the pragma
+
+ Aitem :=
Make_Pragma (Sloc (Aspect),
Pragma_Argument_Associations => New_List (
Relocate_Node (Expr),
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
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>>
----------------------
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
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
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
-- 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.
-- 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,
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;
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;
--------------------------
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;
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;
----------------------------------
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;
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;
---------------------------
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;
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;
---------------------------------
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;
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;
--------------------------------
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
-- 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
-- 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);
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);
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;
----------------------------------------
-- 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;
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;
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))
Write_Eol;
end if;
- Analyze_Aspect_Specifications (N, Designator, AS);
+ Analyze_Aspect_Specifications (N, Designator, Aspect_Specifications (N));
end Analyze_Subprogram_Declaration;
--------------------------------------
-------------------------
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;
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
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
Write_Eol;
end if;
- <<Leave>> Analyze_Aspect_Specifications (N, Id, AS);
+ <<Leave>>
+ Analyze_Aspect_Specifications (N, Id, Aspect_Specifications (N));
end Analyze_Package_Declaration;
-----------------------------------
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);
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;
----------------------------------
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);
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;
---------------------------------------
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;
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;
---------------------
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;
-- 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;
-------------------------------------
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;
-- 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;
-----------------------
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
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;
-----------------------------------
-- 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
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
----------------------------
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,
-- 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;
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 --
----------------
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
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
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;
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
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
(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
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
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;
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
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
(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
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 --
----------------------
-- 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
-- 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
-- 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
-- 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)
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- 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 --
-- Parent_Spec (Node4-Sem)
-- Instance_Spec (Node5-Sem)
-- ABE_Is_Certain (Flag18-Sem)
- -- Has_Aspect_Specifications (Flag3)
-- N_Procedure_Instantiation
-- Sloc points to PROCEDURE
-- 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
-- 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 --
-- 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 --
-- 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 --
-- 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 --
--------------------------------------------------
-- 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 --
------------------------------
-- 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 --
-- 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
-- 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
--------------------------
-- 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,
N_Enumeration_Representation_Clause,
N_Mod_Clause,
N_Record_Representation_Clause,
- N_Aspect_Specification,
-- N_Representation_Clause, N_Has_Chars
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,
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 ..
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
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
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
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
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
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 --
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)
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);
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);
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);
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);
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);
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);
-- 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
----------------------------------
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;
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));
Sprint_Node (Expression (Node));
end if;
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
end if;
when N_Component_List =>
end if;
Write_Param_Specs (Node);
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
when N_Entry_Index_Specification =>
Write_Str_With_Col_Check_Sloc ("for ");
Sprint_Node (Expression (Node));
end if;
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
end if;
when N_Exception_Handler =>
Sprint_Node (Default_Name (Node));
end if;
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
when N_Formal_Concrete_Subprogram_Declaration =>
Write_Indent_Str_Sloc ("with ");
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 ("<>");
Sprint_Node (Default_Expression (Node));
end if;
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
end if;
when N_Formal_Ordinary_Fixed_Point_Definition =>
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
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 ");
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;
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 ");
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 ");
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 ");
Sprint_Node (Expression (Node));
end if;
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
-- Handle implicit importation and implicit exportation of
-- object declarations:
Extra_Blank_Line;
Write_Indent;
Sprint_Node_Sloc (Specification (Node));
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
when N_Package_Instantiation =>
Extra_Blank_Line;
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 ");
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 ");
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 (");
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 ");
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));
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 ");
Sprint_Node (Task_Definition (Node));
end if;
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
when N_Selected_Component =>
Sprint_Node (Prefix (Node));
Write_Str_With_Col_Check (" is null");
end if;
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
when N_Subprogram_Info =>
Sprint_Node (Identifier (Node));
end if;
Sprint_Node (Subtype_Indication (Node));
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
when N_Subtype_Indication =>
Sprint_Node_Sloc (Subtype_Mark (Node));
Sprint_Node (Task_Definition (Node));
end if;
- Sprint_Aspect_Specifications (Node);
+ Write_Char (';');
when N_Terminate_Alternative =>
Sprint_Node_List (Pragmas_Before (Node));
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
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+with Aspects;
with Atree;
with Elists;
with Fname;
if Opt.Tree_Output then
Osint.C.Tree_Create;
Opt.Tree_Write;
+ Aspects.Tree_Write;
Atree.Tree_Write;
Elists.Tree_Write;
Fname.Tree_Write;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
+with Aspects;
with Atree;
with Csets;
with Elists;
begin
Tree_IO.Tree_Read_Initialize (Desc);
Opt.Tree_Read;
+ Aspects.Tree_Read;
Atree.Tree_Read;
Elists.Tree_Read;
Fname.Tree_Read;
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Csets; use Csets;
with Debug; use Debug;
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");
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);
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;
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
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
-- --
-- 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- --
-- Field3 '%'
-- Field4 '&'
-- Field5 "'"
- -- Flag1 "("
- -- Flag2 ")"
- -- Flag3 '*'
-- Flag4 '+'
-- Flag5 ','
-- Flag6 '-'