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