+2013-09-10 Robert Dewar <dewar@adacore.com>
+
+ * aspects.ads (Delay_Type): New type (Aspect_Delay): New table.
+ * einfo.adb (Has_Delayed_Rep_Aspects): New flag
+ (May_Inherit_Delayed_Rep_Aspects): New flag (Rep_Clause): Removed
+ (use Get_Attribute_Representation_Clause).
+ * einfo.ads (Has_Delayed_Rep_Aspects): New flag
+ (May_Inherit_Delayed_Rep_Aspects): New flag
+ * freeze.adb: Minor reformatting
+ * sem_ch13.adb (Analyze_Aspect_Speficifications): Redo
+ handling of delayed evaluation, including optimizing some cases
+ and avoiding delays.
+ (Analyze_Aspects_At_Freeze_Point): Now
+ handled inheriting delayed rep aspects for type derivation case.
+ (Inherit_Delayed_Rep_Aspects): New procedure
+ * sem_ch13.ads (Analyze_Aspects_At_Freeze_Point): Now handled
+ inheriting delayed rep aspects for type derivation case.
+ * sem_ch3.adb (Build_Derived_Type): Set
+ May_Inherit_Derived_Rep_Aspects if parent type flag
+ Has_Delayed_Rep_Aspects is set
+
+2013-09-10 Robert Dewar <dewar@adacore.com>
+
+ * errout.adb (Finalize): Don't delete real errors with specific
+ warning control.
+
+2013-09-10 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Timed_Entry_Call,
+ Expand_N_Conditional_Entry_Call, Expand_N_Asynchronous_Select):
+ Handle properly a trigger that is a call to a primitive operation
+ of a type that implements a limited interface, if the type itself
+ is not limited.
+
2013-09-10 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, sinfo.ads, exp_ch9.adb, sem_prag.adb, sem_ch12.adb,
-- Given an aspect specification, return the corresponding aspect_id value.
-- If the name does not match any aspect, return No_Aspect.
+ ------------------------------------
+ -- Delaying Evaluation of Aspects --
+ ------------------------------------
+
+ -- The RM requires that all language defined aspects taking an expression
+ -- delay evaluation of the expression till the freeze point of the entity
+ -- to which the aspect applies. This allows forward references, and is of
+ -- use for example in connection with preconditions and postconditions
+ -- where the requirement of making all references in contracts to local
+ -- functions be backwards references would be onerous.
+
+ -- For consistency, even attributes like Size are delayed, so we can do:
+
+ -- type A is range 1 .. 10
+ -- with Size => Not_Defined_Yet;
+ -- ..
+ -- Not_Defined_Yet : constant := 64;
+
+ -- Resulting in A having a size of 64, which gets set when A is frozen.
+ -- Furthermore, we can have a situation like
+
+ -- type A is range 1 .. 10
+ -- with Size => Not_Defined_Yet;
+ -- ..
+ -- type B is new A;
+ -- ..
+ -- Not_Defined_Yet : constant := 64;
+
+ -- where the Size of A is considered to have been previously specified at
+ -- the point of derivation, even though the actual value of the size is
+ -- not known yet, and in this example B inherits the size value of 64.
+
+ -- Our normal implementation model (prior to Ada 2012) was simply to copy
+ -- inheritable attributes at the point of derivation. Then any subsequent
+ -- representation items apply either to the parent type, not affecting the
+ -- derived type, or to the derived type, not affecting the parent type.
+
+ -- To deal with the delayed aspect case, we use two flags. The first is
+ -- set on the parent type if it has delayed representation aspects. This
+ -- flag Has_Delayed_Rep_Aspects indicates that if we derive from this type
+ -- we have to worry about making sure we inherit any delayed types. The
+ -- second flag is set on a derived type. May_Have_Inherited_Rep_Aspects
+ -- is set if the parent type has Has_Delayed_Rep_Aspects set.
+
+ -- When we freeze a derived type, if the May_Have_Inherited_Rep_Aspects
+ -- flag is set, then we call Freeze.Inherit_Delayed_Rep_Aspects when
+ -- the derived type is frozen, which deals with the necessary copying of
+ -- information from the parent type, which must be frozen at that point
+ -- (since freezing the derived type first freezes the parent type).
+
+ -- The following shows which aspects are delayed. There are three cases:
+
+ type Delay_Type is
+ (Always_Delay,
+ -- This aspect is not a representation aspect that can be inherited and
+ -- is always delayed, as required by the language definition.
+
+ Never_Delay,
+ -- There are two cases. There are language defined attributes like
+ -- Convention where the "expression" is simply an uninterprted
+ -- identifier, and there is no issue of evaluating it and thus no
+ -- issue of delaying the evaluation. The second case is implementation
+ -- defined attributes where we have decided that we don't want to
+ -- allow delays (and for our own attributes we can do what we like!)
+
+ Rep_Aspect);
+ -- These are the cases of representation aspects that are in general
+ -- delayed, and where there is a potential issue of derived types that
+ -- inherit delayed representation values
+
+ -- Note: even if this table indicates that an aspect is delayed, we never
+ -- delay Boolean aspects that have a missing expression (taken as True),
+ -- or expressions for delayed rep items that consist of an integer literal
+ -- (most cases of Size etc. in practice), since in these cases we know we
+ -- can get the value of the expression without delay. Note that we still
+ -- need to delay Boolean aspects that are specifically set to True:
+
+ -- type R is array (0 .. 31) of Boolean
+ -- with Pack => True;
+ -- True : constant Boolean := False;
+
+ -- This is nonsense, but we need to make it work and result in R not
+ -- being packed, and if we have something like:
+
+ -- type R is array (0 .. 31) of Boolean
+ -- with Pack => True;
+ -- RR : R;
+ -- True : constant Boolean := False;
+
+ -- This is illegal because the visibility of True changes after the freeze
+ -- point, which is not allowed, and we need the delay mechanism to properly
+ -- diagnose this error.
+
+ Aspect_Delay : constant array (Aspect_Id) of Delay_Type :=
+ (No_Aspect => Always_Delay,
+ Aspect_Address => Always_Delay,
+ Aspect_All_Calls_Remote => Always_Delay,
+ Aspect_Asynchronous => Always_Delay,
+ Aspect_Attach_Handler => Always_Delay,
+ Aspect_Compiler_Unit => Always_Delay,
+ Aspect_Constant_Indexing => Always_Delay,
+ Aspect_Contract_Cases => Always_Delay,
+ Aspect_CPU => Always_Delay,
+ Aspect_Default_Iterator => Always_Delay,
+ Aspect_Default_Value => Always_Delay,
+ Aspect_Default_Component_Value => Always_Delay,
+ Aspect_Depends => Always_Delay,
+ Aspect_Discard_Names => Always_Delay,
+ Aspect_Dispatching_Domain => Always_Delay,
+ Aspect_Dynamic_Predicate => Always_Delay,
+ Aspect_Elaborate_Body => Always_Delay,
+ Aspect_External_Name => Always_Delay,
+ Aspect_External_Tag => Always_Delay,
+ Aspect_Export => Always_Delay,
+ Aspect_Favor_Top_Level => Always_Delay,
+ Aspect_Global => Always_Delay,
+ Aspect_Implicit_Dereference => Always_Delay,
+ Aspect_Import => Always_Delay,
+ Aspect_Independent => Always_Delay,
+ Aspect_Independent_Components => Always_Delay,
+ Aspect_Inline => Always_Delay,
+ Aspect_Inline_Always => Always_Delay,
+ Aspect_Input => Always_Delay,
+ Aspect_Interrupt_Handler => Always_Delay,
+ Aspect_Interrupt_Priority => Always_Delay,
+ Aspect_Invariant => Always_Delay,
+ Aspect_Iterator_Element => Always_Delay,
+ Aspect_Link_Name => Always_Delay,
+ Aspect_Lock_Free => Always_Delay,
+ Aspect_No_Return => Always_Delay,
+ Aspect_Output => Always_Delay,
+ Aspect_Persistent_BSS => Always_Delay,
+ Aspect_Post => Always_Delay,
+ Aspect_Postcondition => Always_Delay,
+ Aspect_Pre => Always_Delay,
+ Aspect_Precondition => Always_Delay,
+ Aspect_Predicate => Always_Delay,
+ Aspect_Preelaborable_Initialization => Always_Delay,
+ Aspect_Preelaborate => Always_Delay,
+ Aspect_Preelaborate_05 => Always_Delay,
+ Aspect_Priority => Always_Delay,
+ Aspect_Pure => Always_Delay,
+ Aspect_Pure_05 => Always_Delay,
+ Aspect_Pure_12 => Always_Delay,
+ Aspect_Pure_Function => Always_Delay,
+ Aspect_Read => Always_Delay,
+ Aspect_Relative_Deadline => Always_Delay,
+ Aspect_Remote_Access_Type => Always_Delay,
+ Aspect_Remote_Call_Interface => Always_Delay,
+ Aspect_Remote_Types => Always_Delay,
+ Aspect_Shared => Always_Delay,
+ Aspect_Shared_Passive => Always_Delay,
+ Aspect_Simple_Storage_Pool => Always_Delay,
+ Aspect_Simple_Storage_Pool_Type => Always_Delay,
+ Aspect_Static_Predicate => Always_Delay,
+ Aspect_Storage_Pool => Always_Delay,
+ Aspect_Stream_Size => Always_Delay,
+ Aspect_Suppress => Always_Delay,
+ Aspect_Suppress_Debug_Info => Always_Delay,
+ Aspect_Type_Invariant => Always_Delay,
+ Aspect_Unchecked_Union => Always_Delay,
+ Aspect_Universal_Aliasing => Always_Delay,
+ Aspect_Universal_Data => Always_Delay,
+ Aspect_Unmodified => Always_Delay,
+ Aspect_Unreferenced => Always_Delay,
+ Aspect_Unreferenced_Objects => Always_Delay,
+ Aspect_Unsuppress => Always_Delay,
+ Aspect_Variable_Indexing => Always_Delay,
+ Aspect_Write => Always_Delay,
+
+ Aspect_Abstract_State => Never_Delay,
+ Aspect_Ada_2005 => Never_Delay,
+ Aspect_Ada_2012 => Never_Delay,
+ Aspect_Convention => Never_Delay,
+ Aspect_Dimension => Never_Delay,
+ Aspect_Dimension_System => Never_Delay,
+ Aspect_SPARK_Mode => Never_Delay,
+ Aspect_Synchronization => Never_Delay,
+ Aspect_Test_Case => Never_Delay,
+ Aspect_Warnings => Never_Delay,
+
+ Aspect_Alignment => Rep_Aspect,
+ Aspect_Atomic => Rep_Aspect,
+ Aspect_Atomic_Components => Rep_Aspect,
+ Aspect_Bit_Order => Rep_Aspect,
+ Aspect_Component_Size => Rep_Aspect,
+ Aspect_Machine_Radix => Rep_Aspect,
+ Aspect_Object_Size => Rep_Aspect,
+ Aspect_Pack => Rep_Aspect,
+ Aspect_Scalar_Storage_Order => Rep_Aspect,
+ Aspect_Size => Rep_Aspect,
+ Aspect_Small => Rep_Aspect,
+ Aspect_Storage_Size => Rep_Aspect,
+ Aspect_Value_Size => Rep_Aspect,
+ Aspect_Volatile => Rep_Aspect,
+ Aspect_Volatile_Components => Rep_Aspect);
+
---------------------------------------------------
-- Handling of Aspect Specifications in the Tree --
---------------------------------------------------
-- Has_Static_Predicate_Aspect Flag259
-- Has_Loop_Entry_Attributes Flag260
- -- (unused) Flag261
- -- (unused) Flag262
+ -- Has_Delayed_Rep_Aspects Flag261
+ -- May_Inherit_Delayed_Rep_Aspects Flag262
+
-- (unused) Flag263
-- (unused) Flag264
-- (unused) Flag265
-- Determine whether abstract state State has a particular property denoted
-- by the name Prop_Nam.
- function Rep_Clause (Id : E; Rep_Name : Name_Id) return N;
- -- Returns the attribute definition clause for Id whose name is Rep_Name.
- -- Returns Empty if no matching attribute definition clause found for Id.
-
---------------
-- Float_Rep --
---------------
return False;
end Has_Property;
- ----------------
- -- Rep_Clause --
- ----------------
-
- function Rep_Clause (Id : E; Rep_Name : Name_Id) return N is
- Ritem : Node_Id;
-
- begin
- Ritem := First_Rep_Item (Id);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Attribute_Definition_Clause
- and then Chars (Ritem) = Rep_Name
- then
- return Ritem;
- else
- Next_Rep_Item (Ritem);
- end if;
- end loop;
-
- return Empty;
- end Rep_Clause;
-
--------------------------------
-- Attribute Access Functions --
--------------------------------
return Flag18 (Id);
end Has_Delayed_Freeze;
+ function Has_Delayed_Rep_Aspects (Id : E) return B is
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+ return Flag261 (Id);
+ end Has_Delayed_Rep_Aspects;
+
function Has_Discriminants (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
return Flag168 (Id);
end Materialize_Entity;
+ function May_Inherit_Delayed_Rep_Aspects (Id : E) return B is
+ begin
+ return Flag262 (Id);
+ end May_Inherit_Delayed_Rep_Aspects;
+
function Mechanism (Id : E) return M is
begin
pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id));
Set_Flag18 (Id, V);
end Set_Has_Delayed_Freeze;
+ procedure Set_Has_Delayed_Rep_Aspects (Id : E; V : B := True) is
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+ Set_Flag261 (Id, V);
+ end Set_Has_Delayed_Rep_Aspects;
+
procedure Set_Has_Discriminants (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
Set_Flag168 (Id, V);
end Set_Materialize_Entity;
+ procedure Set_May_Inherit_Delayed_Rep_Aspects (Id : E; V : B := True) is
+ begin
+ Set_Flag262 (Id, V);
+ end Set_May_Inherit_Delayed_Rep_Aspects;
+
procedure Set_Mechanism (Id : E; V : M) is
begin
pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id));
function Address_Clause (Id : E) return N is
begin
- return Rep_Clause (Id, Name_Address);
+ return Get_Attribute_Definition_Clause (Id, Attribute_Address);
end Address_Clause;
---------------
function Alignment_Clause (Id : E) return N is
begin
- return Rep_Clause (Id, Name_Alignment);
+ return Get_Attribute_Definition_Clause (Id, Attribute_Alignment);
end Alignment_Clause;
-------------------
function Size_Clause (Id : E) return N is
begin
- return Rep_Clause (Id, Name_Size);
+ return Get_Attribute_Definition_Clause (Id, Attribute_Size);
end Size_Clause;
------------------------
function Stream_Size_Clause (Id : E) return N is
begin
- return Rep_Clause (Id, Name_Stream_Size);
+ return Get_Attribute_Definition_Clause (Id, Attribute_Stream_Size);
end Stream_Size_Clause;
------------------
W ("Has_Default_Aspect", Flag39 (Id));
W ("Has_Delayed_Aspects", Flag200 (Id));
W ("Has_Delayed_Freeze", Flag18 (Id));
+ W ("Has_Delayed_Rep_Aspects", Flag261 (Id));
W ("Has_Discriminants", Flag5 (Id));
W ("Has_Dispatch_Table", Flag220 (Id));
W ("Has_Dynamic_Predicate_Aspect", Flag258 (Id));
W ("Low_Bound_Tested", Flag205 (Id));
W ("Machine_Radix_10", Flag84 (Id));
W ("Materialize_Entity", Flag168 (Id));
+ W ("May_Inherit_Delayed_Rep_Aspects", Flag262 (Id));
W ("Must_Be_On_Byte_Boundary", Flag183 (Id));
W ("Must_Have_Preelab_Init", Flag208 (Id));
W ("Needs_Debug_Info", Flag147 (Id));
-- apsect. If this flag is set, then a corresponding aspect specification
-- node will be present on the rep item chain for the entity.
+-- Has_Delayed_Rep_Aspects (Flag261)
+-- Defined in all type and subtypes. This flag is set if there is at
+-- least one aspect for a representation characteristic that has to be
+-- delayed and is one of the characteristics that may be inherited by
+-- types derived from this type if not overridden. If this flag is set,
+-- then types derived from this type have May_Inherit_Delayed_Rep_Aspects
+-- set, signalling that Freeze.Inhert_Delayed_Rep_Aspects must be called
+-- at the freeze point of the derived type.
+
-- Has_Discriminants (Flag5)
-- Defined in all types and subtypes. For types that are allowed to have
-- discriminants (record types and subtypes, task types and subtypes,
-- Has_Size_Clause (Flag29)
-- Defined in entities for types and objects. Set if a size clause is
--- Defined for the entity. Used to prevent multiple Size clauses for a
+-- defined for the entity. Used to prevent multiple Size clauses for a
-- given entity. Note that it is always initially cleared for a derived
-- type, even though the Size for such a type is inherited from a Size
-- clause given for the parent type.
-- Types can have unknown discriminants either from their declaration or
-- through type derivation. The use of this flag exactly meets the spec
-- in RM 3.7(26). Note that all class-wide types are considered to have
--- unknown discriminants. Note that both Has_Discriminants and
+-- unknown discriminants. Note that both flags Has_Discriminants and
-- Has_Unknown_Discriminants may be true for a type. Class-wide types and
-- their subtypes have unknown discriminants and can have declared ones
-- as well. Private types declared with unknown discriminants may have a
-- containing the renamed address should be allocated. This is needed so
-- that the debugger can find the entity.
+-- May_Inherit_Delayed_Rep_Aspects (Flag262)
+-- Defined in all entities for types and subtypes. Set if the type is
+-- derived from a type which has delayed rep aspects (marked by the flag
+-- Has_Delayed_Rep_Aspects being set). In this case, at the freeze point
+-- for the derived type we know that the parent type is frozen, and if
+-- a given attribute has not been set for the derived type, we copy the
+-- value from the parent type. See Freeze.Inherit_Delayed_Rep_Aspects.
+
-- Mechanism (Uint8) (returned as Mechanism_Type)
-- Defined in functions and non-generic formal parameters. Indicates
-- the mechanism to be used for the function return or for the formal
-- Has_Constrained_Partial_View (Flag187)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_Default_Aspect (Flag39) (base type only)
+ -- Has_Delayed_Rep_Aspects (Flag261)
-- Has_Discriminants (Flag5)
-- Has_Dynamic_Predicate_Aspect (Flag258)
-- Has_Independent_Components (Flag34) (base type only)
-- Is_Volatile (Flag16)
-- Itype_Printed (Flag202) (itypes only)
-- Known_To_Have_Preelab_Init (Flag207)
+ -- May_Inherit_Delayed_Rep_Aspects (Flag262)
-- Must_Be_On_Byte_Boundary (Flag183)
-- Must_Have_Preelab_Init (Flag208)
-- Optimize_Alignment_Space (Flag241)
function Has_Default_Aspect (Id : E) return B;
function Has_Delayed_Aspects (Id : E) return B;
function Has_Delayed_Freeze (Id : E) return B;
+ function Has_Delayed_Rep_Aspects (Id : E) return B;
function Has_Discriminants (Id : E) return B;
function Has_Dispatch_Table (Id : E) return B;
function Has_Dynamic_Predicate_Aspect (Id : E) return B;
function Machine_Radix_10 (Id : E) return B;
function Master_Id (Id : E) return E;
function Materialize_Entity (Id : E) return B;
+ function May_Inherit_Delayed_Rep_Aspects (Id : E) return B;
function Mechanism (Id : E) return M;
function Modulus (Id : E) return U;
function Must_Be_On_Byte_Boundary (Id : E) return B;
procedure Set_Has_Default_Aspect (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_Delayed_Rep_Aspects (Id : E; V : B := True);
procedure Set_Has_Discriminants (Id : E; V : B := True);
procedure Set_Has_Dispatch_Table (Id : E; V : B := True);
procedure Set_Has_Dynamic_Predicate_Aspect (Id : E; V : B := True);
procedure Set_Machine_Radix_10 (Id : E; V : B := True);
procedure Set_Master_Id (Id : E; V : E);
procedure Set_Materialize_Entity (Id : E; V : B := True);
+ procedure Set_May_Inherit_Delayed_Rep_Aspects (Id : E; V : B := True);
procedure Set_Mechanism (Id : E; V : M);
procedure Set_Modulus (Id : E; V : U);
procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True);
pragma Inline (Has_Default_Aspect);
pragma Inline (Has_Delayed_Aspects);
pragma Inline (Has_Delayed_Freeze);
+ pragma Inline (Has_Delayed_Rep_Aspects);
pragma Inline (Has_Discriminants);
pragma Inline (Has_Dispatch_Table);
pragma Inline (Has_Dynamic_Predicate_Aspect);
pragma Inline (Machine_Radix_10);
pragma Inline (Master_Id);
pragma Inline (Materialize_Entity);
+ pragma Inline (May_Inherit_Delayed_Rep_Aspects);
pragma Inline (Mechanism);
pragma Inline (Modulus);
pragma Inline (Must_Be_On_Byte_Boundary);
pragma Inline (Set_Has_Default_Aspect);
pragma Inline (Set_Has_Delayed_Aspects);
pragma Inline (Set_Has_Delayed_Freeze);
+ pragma Inline (Set_Has_Delayed_Rep_Aspects);
pragma Inline (Set_Has_Discriminants);
pragma Inline (Set_Has_Dispatch_Table);
pragma Inline (Set_Has_Dynamic_Predicate_Aspect);
pragma Inline (Set_Machine_Radix_10);
pragma Inline (Set_Master_Id);
pragma Inline (Set_Materialize_Entity);
+ pragma Inline (Set_May_Inherit_Delayed_Rep_Aspects);
pragma Inline (Set_Mechanism);
pragma Inline (Set_Modulus);
pragma Inline (Set_Must_Be_On_Byte_Boundary);
CE : Error_Msg_Object renames Errors.Table (Cur);
begin
- if not CE.Deleted
+ if (CE.Warn and not CE.Deleted)
and then
(Warning_Specifically_Suppressed (CE.Sptr, CE.Text)
or else
-- build record declaration. N is the type declaration, Ctyp is the
-- concurrent entity (task type or protected type).
+ function Build_Dispatching_Tag_Check
+ (K : Entity_Id;
+ N : Node_Id) return Node_Id;
+ -- Utility to create the tree to check whether the dispatching call in
+ -- a timed entry call, a conditional entry call, or an asynchronous
+ -- transfer of control is a call to a primitive of a non-synchronized type.
+ -- K is the temporary that holds the tagged kind of the target object, and
+ -- N is the enclosing construct.
+
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
Limited_Present => True));
end Build_Corresponding_Record;
+ ---------------------------------
+ -- Build_Dispatching_Tag_Check --
+ ---------------------------------
+
+ function Build_Dispatching_Tag_Check
+ (K : Entity_Id;
+ N : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ begin
+ return
+ Make_Op_Or (Loc,
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Reference_To (K, Loc),
+ Right_Opnd => New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Reference_To (K, Loc),
+ Right_Opnd => New_Reference_To (RTE (RE_TK_Tagged), Loc)));
+ end Build_Dispatching_Tag_Check;
+
----------------------------------
-- Build_Entry_Count_Expression --
----------------------------------
-- U : Boolean;
-- begin
- -- if K = Ada.Tags.TK_Limited_Tagged then
+ -- if K = Ada.Tags.TK_Limited_Tagged
+ -- or else K = Ada.Tags.TK_Tagged
+ -- then
-- <dispatching-call>;
-- <triggering-statements>;
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
-- Generate:
- -- if K = Ada.Tags.TK_Limited_Tagged then
+ -- if K = Ada.Tags.TK_Limited_Tagged
+ -- or else K = Ada.Tags.TK_Tagged
+ -- then
-- Lim_Typ_Stmts
-- else
-- Conc_Typ_Stmts
Append_To (Stmts,
Make_Implicit_If_Statement (N,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Reference_To (K, Loc),
- Right_Opnd =>
- New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
-
- Then_Statements =>
- Lim_Typ_Stmts,
-
- Else_Statements =>
- Conc_Typ_Stmts));
+ Condition => Build_Dispatching_Tag_Check (K, N),
+ Then_Statements => Lim_Typ_Stmts,
+ Else_Statements => Conc_Typ_Stmts));
Rewrite (N,
Make_Block_Statement (Loc,
-- S : Integer;
-- begin
- -- if K = Ada.Tags.TK_Limited_Tagged then
+ -- if K = Ada.Tags.TK_Limited_Tagged
+ -- or else K = Ada.Tags.TK_Tagged
+ -- then
-- <dispatching-call>;
-- <triggering-statements>
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
-- Generate:
- -- if K = Ada.Tags.TK_Limited_Tagged then
+ -- if K = Ada.Tags.TK_Limited_Tagged
+ -- or else K = Ada.Tags.TK_Tagged
+ -- then
-- Lim_Typ_Stmts
-- else
-- Conc_Typ_Stmts
Append_To (Stmts,
Make_Implicit_If_Statement (N,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Reference_To (K, Loc),
- Right_Opnd =>
- New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
-
- Then_Statements =>
- Lim_Typ_Stmts,
-
- Else_Statements =>
- Conc_Typ_Stmts));
+ Condition => Build_Dispatching_Tag_Check (K, N),
+ Then_Statements => Lim_Typ_Stmts,
+ Else_Statements => Conc_Typ_Stmts));
Rewrite (N,
Make_Block_Statement (Loc,
-- S : Integer;
-- begin
- -- if K = Ada.Tags.TK_Limited_Tagged then
+ -- if K = Ada.Tags.TK_Limited_Tagged
+ -- or else K = Ada.Tags.TK_Tagged
+ -- then
-- <dispatching-call>;
-- <triggering-statements>
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
-- Generate:
- -- if K = Ada.Tags.TK_Limited_Tagged then
+ -- if K = Ada.Tags.TK_Limited_Tagged
+ -- or else K = Ada.Tags.TK_Tagged
+ -- then
-- Lim_Typ_Stmts
-- else
-- Conc_Typ_Stmts
Append_To (Stmts,
Make_Implicit_If_Statement (N,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => New_Reference_To (K, Loc),
- Right_Opnd =>
- New_Reference_To (RTE (RE_TK_Limited_Tagged), Loc)),
+ Condition => Build_Dispatching_Tag_Check (K, N),
Then_Statements => Lim_Typ_Stmts,
Else_Statements => Conc_Typ_Stmts));
or else (Chars (Comp) /= Name_uParent
and then Is_Controlled (Etype (Comp)))
or else (Is_Protected_Type (Etype (Comp))
- and then Present
- (Corresponding_Record_Type
- (Etype (Comp)))
- and then Has_Controlled_Component
- (Corresponding_Record_Type
- (Etype (Comp)))))
+ and then
+ Present
+ (Corresponding_Record_Type
+ (Etype (Comp)))
+ and then
+ Has_Controlled_Component
+ (Corresponding_Record_Type
+ (Etype (Comp)))))
then
Set_Has_Controlled_Component (Rec);
end if;
-- Add checks to detect proper initialization of scalars that may appear
-- as subprogram parameters.
- if Is_Subprogram (E)
- and then Check_Validity_Of_Parameters
- then
+ if Is_Subprogram (E) and then Check_Validity_Of_Parameters then
Apply_Parameter_Validity_Checks (E);
end if;
-- then the only purpose of the Import pragma is to suppress
-- implicit initialization.
- if Is_Imported (E)
- and then No (Address_Clause (E))
- then
+ if Is_Imported (E) and then No (Address_Clause (E)) then
Set_Is_Public (E);
end if;
-- expects 8-bit sizes for these cases.
if (Convention (E) = Convention_C
- or else
+ or else
Convention (E) = Convention_CPP)
and then Is_Enumeration_Type (Etype (E))
and then not Is_Character_Type (Etype (E))
-- enclosing statement sequence.
if Ekind_In (E, E_Constant, E_Variable)
- and then not Has_Delayed_Freeze (E)
+ and then not Has_Delayed_Freeze (E)
then
declare
Init_Stmts : constant Node_Id :=
-- This routine analyzes an Aspect_Default_[Component_]Value denoted by
-- the aspect specification node ASN.
+ procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id);
+ -- As discussed in the spec of Aspects (see Aspect_Delay declaration),
+ -- a derived type can inherit aspects from its parent which have been
+ -- specified at the time of the derivation using an aspect, as in:
+ --
+ -- type A is range 1 .. 10
+ -- with Size => Not_Defined_Yet;
+ -- ..
+ -- type B is new A;
+ -- ..
+ -- Not_Defined_Yet : constant := 64;
+ --
+ -- In this example, the Size of A is considered to be specified prior
+ -- to the derivation, and thus inherited, even though the value is not
+ -- known at the time of derivation. To deal with this, we use two entity
+ -- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A
+ -- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in
+ -- the derived type (B here). If this flag is set when the derived type
+ -- is frozen, then this procedure is called to ensure proper inheritance
+ -- of all delayed aspects from the paren type. The derived type is E,
+ -- the argument to Analyze_Aspects_At_Freeze_Point. ASN is the first
+ -- aspect specification node in the Rep_Item chain for the parent type.
+
procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
-- Given an aspect specification node ASN whose expression is an
-- optional Boolean, this routines creates the corresponding pragma
end if;
end Analyze_Aspect_Default_Value;
+ ---------------------------------
+ -- Inherit_Delayed_Rep_Aspects --
+ ---------------------------------
+
+ procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is
+ P : constant Entity_Id := Entity (ASN);
+ -- Entithy for parent type
+
+ N : Node_Id;
+ -- Item from Rep_Item chain
+
+ A : Aspect_Id;
+
+ begin
+ -- Loop through delayed aspects for the parent type
+
+ N := ASN;
+ while Present (N) loop
+ if Nkind (N) = N_Aspect_Specification then
+ exit when Entity (N) /= P;
+
+ if Is_Delayed_Aspect (N) then
+ A := Get_Aspect_Id (Chars (Identifier (N)));
+
+ -- Process delayed rep aspect. For Boolean attributes it is
+ -- not possible to cancel an attribute once set (the attempt
+ -- to use an aspect with xxx => False is an error) for a
+ -- derived type. So for those cases, we do not have to check
+ -- if a clause has been given for the derived type, since it
+ -- is harmless to set it again if it is already set.
+
+ case A is
+
+ -- Alignment
+
+ when Aspect_Alignment =>
+ if not Has_Alignment_Clause (E) then
+ Set_Alignment (E, Alignment (P));
+ end if;
+
+ -- Atomic
+
+ when Aspect_Atomic =>
+ if Is_Atomic (P) then
+ Set_Is_Atomic (E);
+ end if;
+
+ -- Atomic_Components
+
+ when Aspect_Atomic_Components =>
+ if Has_Atomic_Components (P) then
+ Set_Has_Atomic_Components (Base_Type (E));
+ end if;
+
+ -- Bit_Order
+
+ when Aspect_Bit_Order =>
+ if Is_Record_Type (E)
+ and then No (Get_Attribute_Definition_Clause
+ (E, Attribute_Bit_Order))
+ and then Reverse_Bit_Order (P)
+ then
+ Set_Reverse_Bit_Order (Base_Type (E));
+ end if;
+
+ -- Component_Size
+
+ when Aspect_Component_Size =>
+ if Is_Array_Type (E)
+ and then not Has_Component_Size_Clause (E)
+ then
+ Set_Component_Size
+ (Base_Type (E), Component_Size (P));
+ end if;
+
+ -- Machine_Radix
+
+ when Aspect_Machine_Radix =>
+ if Is_Decimal_Fixed_Point_Type (E)
+ and then not Has_Machine_Radix_Clause (E)
+ then
+ Set_Machine_Radix_10 (E, Machine_Radix_10 (P));
+ end if;
+
+ -- Object_Size (also Size which also sets Object_Size)
+
+ when Aspect_Object_Size | Aspect_Size =>
+ if not Has_Size_Clause (E)
+ and then
+ No (Get_Attribute_Definition_Clause
+ (E, Attribute_Object_Size))
+ then
+ Set_Esize (E, Esize (P));
+ end if;
+
+ -- Pack
+
+ when Aspect_Pack =>
+ if not Is_Packed (E) then
+ Set_Is_Packed (Base_Type (E));
+
+ if Is_Bit_Packed_Array (P) then
+ Set_Is_Bit_Packed_Array (Base_Type (E));
+ Set_Packed_Array_Type (E, Packed_Array_Type (P));
+ end if;
+ end if;
+
+ -- Scalar_Storage_Order
+
+ when Aspect_Scalar_Storage_Order =>
+ if (Is_Record_Type (E) or else Is_Array_Type (E))
+ and then No (Get_Attribute_Definition_Clause
+ (E, Attribute_Scalar_Storage_Order))
+ and then Reverse_Storage_Order (P)
+ then
+ Set_Reverse_Storage_Order (Base_Type (E));
+ end if;
+
+ -- Small
+
+ when Aspect_Small =>
+ if Is_Fixed_Point_Type (E)
+ and then not Has_Small_Clause (E)
+ then
+ Set_Small_Value (E, Small_Value (P));
+ end if;
+
+ -- Storage_Size
+
+ when Aspect_Storage_Size =>
+ if (Is_Access_Type (E) or else Is_Task_Type (E))
+ and then not Has_Storage_Size_Clause (E)
+ then
+ Set_Storage_Size_Variable
+ (Base_Type (E), Storage_Size_Variable (P));
+ end if;
+
+ -- Value_Size
+
+ when Aspect_Value_Size =>
+
+ -- Value_Size is never inherited, it is either set by
+ -- default, or it is explicitly set for the derived
+ -- type. So nothing to do here.
+
+ null;
+
+ -- Volatile
+
+ when Aspect_Volatile =>
+ if Is_Volatile (P) then
+ Set_Is_Volatile (E);
+ end if;
+
+ -- Volatile_Components
+
+ when Aspect_Volatile_Components =>
+ if Has_Volatile_Components (P) then
+ Set_Has_Volatile_Components (Base_Type (E));
+ end if;
+
+ -- That should be all the Rep Aspects
+
+ when others =>
+ pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect);
+ null;
+
+ end case;
+ end if;
+ end if;
+
+ N := Next_Rep_Item (N);
+ end loop;
+ end Inherit_Delayed_Rep_Aspects;
+
-------------------------------------
-- Make_Pragma_From_Boolean_Aspect --
-------------------------------------
-- Fall through means we are canceling an inherited aspect
Error_Msg_Name_1 := A_Name;
- Error_Msg_NE ("derived type& inherits aspect%, cannot cancel",
- Expr,
- E);
+ Error_Msg_NE
+ ("derived type& inherits aspect%, cannot cancel", Expr, E);
end Check_False_Aspect_For_Derived_Type;
-- Start of processing for Make_Pragma_From_Boolean_Aspect
begin
+ -- Note that we know Expr is present, because for a missing Expr
+ -- argument, we knew it was True and did not need to delay the
+ -- evaluation to the freeze point.
+
if Is_False (Static_Boolean (Expr)) then
Check_False_Aspect_For_Derived_Type;
ASN := First_Rep_Item (E);
while Present (ASN) loop
- if Nkind (ASN) = N_Aspect_Specification
- and then Entity (ASN) = E
- and then Is_Delayed_Aspect (ASN)
- then
- A_Id := Get_Aspect_Id (ASN);
+ if Nkind (ASN) = N_Aspect_Specification then
+ exit when Entity (ASN) /= E;
- case A_Id is
+ if Is_Delayed_Aspect (ASN) then
+ A_Id := Get_Aspect_Id (ASN);
+
+ case A_Id is
- -- For aspects whose expression is an optional Boolean, make
- -- the corresponding pragma at the freezing point.
+ -- For aspects whose expression is an optional Boolean, make
+ -- the corresponding pragma at the freezing point.
when Boolean_Aspects |
Library_Unit_Aspects =>
Make_Pragma_From_Boolean_Aspect (ASN);
- -- Special handling for aspects that don't correspond to
- -- pragmas/attributes.
+ -- Special handling for aspects that don't correspond to
+ -- pragmas/attributes.
when Aspect_Default_Value |
Aspect_Default_Component_Value =>
Analyze_Aspect_Default_Value (ASN);
- -- Ditto for iterator aspects, because the corresponding
- -- attributes may not have been analyzed yet.
+ -- Ditto for iterator aspects, because the corresponding
+ -- attributes may not have been analyzed yet.
when Aspect_Constant_Indexing |
Aspect_Variable_Indexing |
when others =>
null;
- end case;
+ end case;
- Ritem := Aspect_Rep_Item (ASN);
+ Ritem := Aspect_Rep_Item (ASN);
- if Present (Ritem) then
- Analyze (Ritem);
+ if Present (Ritem) then
+ Analyze (Ritem);
+ end if;
end if;
end if;
Next_Rep_Item (ASN);
end loop;
+
+ -- This is where we inherit delayed rep aspects from our parent. Note
+ -- that if we fell out of the above loop with ASN non-empty, it means
+ -- we hit an aspect for an entity other than E, and it must be the
+ -- type from which we were derived.
+
+ if May_Inherit_Delayed_Rep_Aspects (E) then
+ Inherit_Delayed_Rep_Aspects (ASN);
+ end if;
end Analyze_Aspects_At_Freeze_Point;
-----------------------------------
A_Id : constant Aspect_Id := Get_Aspect_Id (Nam);
Anod : Node_Id;
- Delay_Required : Boolean := True;
+ Delay_Required : Boolean;
-- Set False if delay is not required
Eloc : Source_Ptr := No_Location;
Set_Entity (Id, New_Copy_Tree (Expr));
+ -- Set Delay_Required as appropriate to aspect
+
+ case Aspect_Delay (A_Id) is
+ when Always_Delay =>
+ Delay_Required := True;
+
+ when Never_Delay =>
+ Delay_Required := False;
+
+ when Rep_Aspect =>
+
+ -- If expression has the form of an integer literal, then
+ -- do not delay, since we know the value cannot change.
+ -- This optimization catches most rep clause cases.
+
+ if (Present (Expr) and then Nkind (Expr) = N_Integer_Literal)
+ or else (A_Id in Boolean_Aspects and then No (Expr))
+ then
+ Delay_Required := False;
+ else
+ Delay_Required := True;
+ Set_Has_Delayed_Rep_Aspects (E);
+ end if;
+ end case;
+
-- Processing based on specific aspect
case A_Id is
-- Indexing aspects apply only to tagged type
if (A_Id = Aspect_Constant_Indexing
- or else A_Id = Aspect_Variable_Indexing)
+ or else
+ A_Id = Aspect_Variable_Indexing)
and then not (Is_Type (E)
and then Is_Tagged_Type (E))
then
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Implemented);
- -- No delay is required since the only values are: By_Entry
- -- | By_Protected_Procedure | By_Any | Optional which don't
- -- get analyzed anyway.
-
- Delay_Required := False;
-
-- Attach Handler
when Aspect_Attach_Handler =>
Make_Aitem_Pragma
(Pragma_Argument_Associations => Arg_List,
Pragma_Name => P_Name);
-
- -- Convention is a static name, and must be associated
- -- with the entity at once.
-
- Delay_Required := False;
end;
-- CPU, Interrupt_Priority, Priority
Expression => New_Occurrence_Of (E, Loc))),
Pragma_Name => Chars (Id));
- -- We don't have to play the delay game here, since the only
- -- values are ON/OFF which don't get analyzed anyway.
-
- Delay_Required := False;
-
-- Case 2c: Aspects corresponding to pragmas with three
-- arguments.
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Abstract_State);
- Delay_Required := False;
-- Depends
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_SPARK_Mode);
- Delay_Required := False;
-- Relative_Deadline
Make_Aitem_Pragma
(Pragma_Argument_Associations => Args,
Pragma_Name => Nam);
-
- Delay_Required := False;
end Test_Case;
-- Contract_Cases
else
-- Set the Uses_Lock_Free flag to True if there is no
- -- expression or if the expression is True. ??? The
+ -- expression or if the expression is True. The
-- evaluation of this aspect should be delayed to the
- -- freeze point.
+ -- freeze point (why???)
if No (Expr)
or else Is_True (Static_Boolean (Expr))
if No (A) then
Error_Msg_N
("missing Convention aspect for Export/Import",
- Aspect);
+ Aspect);
end if;
end;
goto Continue;
end if;
- -- This requires special handling in the case of a package
- -- declaration, the pragma needs to be inserted in the list
- -- of declarations for the associated package. There is no
- -- issue of visibility delay for these aspects.
+ -- Library unit aspects require special handling in the case
+ -- of a package declaration, the pragma needs to be inserted
+ -- in the list of declarations for the associated package.
+ -- There is no issue of visibility delay for these aspects.
if A_Id in Library_Unit_Aspects
and then
goto Continue;
end if;
- -- Special handling when the aspect has no expression. In
- -- this case the value is considered to be True. Thus, we
- -- simply insert the pragma, no delay is required.
+ -- Cases where we do not delay, includes all cases where
+ -- the expression is missing other than the above cases.
- if No (Expr) then
+ if not Delay_Required or else No (Expr) then
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent)),
Pragma_Name => Chars (Id));
-
Delay_Required := False;
-- In general cases, the corresponding pragma/attribute
-- definition clause will be inserted later at the freezing
- -- point.
+ -- point, and we do not need to build it now
else
Aitem := Empty;
-- The evaluation of the aspect is delayed to the freezing point.
-- The pragma or attribute clause if there is one is then attached
- -- to the aspect specification which is placed in the rep item
- -- list.
+ -- to the aspect specification which is put in the rep item list.
if Delay_Required then
if Present (Aitem) then
when Boolean_Aspects |
Library_Unit_Aspects =>
+
T := Standard_Boolean;
-- Aspects corresponding to attribute definition clauses
-------------------------------------
procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
+
function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep_Item : Node_Id) return Boolean;
-- This routine checks if Rep_Item is either a pragma or an aspect
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
-- in these two expressions are the same, by seeing if the two expressions
-- are fully conformant, and if not, issue appropriate error messages.
- -- Quite an awkward procedure, but this is an awkard requirement!
+ -- Quite an awkward approach, but this is an awkard requirement!
procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id);
- -- Analyze all the delayed aspects for entity E at freezing point
+ -- Analyze all the delayed aspects for entity E at freezing point. This
+ -- includes dealing with inheriting delayed aspects from the parent type
+ -- in the case where a derived type is frozen.
procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id);
-- Performs the processing described above at the freeze point, ASN is the
Parent_Type : Entity_Id;
Derived_Type : Entity_Id;
Derive_Subps : Boolean := True);
- -- Subsidiary procedure for Build_Derived_Type and
- -- Analyze_Private_Extension_Declaration used for tagged and untagged
- -- record types. All parameters are as in Build_Derived_Type except that
- -- N, in addition to being an N_Full_Type_Declaration node, can also be an
+ -- Subsidiary procedure used for tagged and untagged record types
+ -- by Build_Derived_Type and Analyze_Private_Extension_Declaration.
+ -- All parameters are as in Build_Derived_Type except that N, in
+ -- addition to being an N_Full_Type_Declaration node, can also be an
-- N_Private_Extension_Declaration node. See the definition of this routine
- -- for much more info. Derive_Subps indicates whether subprograms should
- -- be derived from the parent type. The only case where Derive_Subps is
- -- False is for an implicit derived full type for a type derived from a
- -- private type (see Build_Derived_Type).
+ -- for much more info. Derive_Subps indicates whether subprograms should be
+ -- derived from the parent type. The only case where Derive_Subps is False
+ -- is for an implicit derived full type for a type derived from a private
+ -- type (see Build_Derived_Type).
procedure Build_Discriminal (Discrim : Entity_Id);
-- Create the discriminal corresponding to discriminant Discrim, that is
Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
end if;
+ -- If the parent type has delayed rep aspects, then mark the derived
+ -- type as possibly inheriting a delayed rep aspect.
+
+ if Has_Delayed_Rep_Aspects (Parent_Type) then
+ Set_May_Inherit_Delayed_Rep_Aspects (Derived_Type);
+ end if;
+
+ -- Type dependent processing
+
case Ekind (Parent_Type) is
when Numeric_Kind =>
Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type);
raise Program_Error;
end case;
+ -- Nothing more to do if some error occurred
+
if Etype (Derived_Type) = Any_Type then
return;
end if;
-- if necessary.
Set_Has_Delayed_Freeze (Derived_Type);
+
if Derive_Subps then
Derive_Subprograms (Parent_Type, Derived_Type);
end if;
projects / thirdparty / gcc.git / commitdiff
