From 15e934bf713f8a57abdd0d93d17deac3340e5158 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 10 Sep 2013 16:54:41 +0200 Subject: [PATCH] [multiple changes] 2013-09-10 Robert Dewar * 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 * errout.adb (Finalize): Don't delete real errors with specific warning control. 2013-09-10 Ed Schonberg * 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. From-SVN: r202456 --- gcc/ada/ChangeLog | 34 +++++ gcc/ada/aspects.ads | 197 ++++++++++++++++++++++++++ gcc/ada/einfo.adb | 63 ++++----- gcc/ada/einfo.ads | 31 +++- gcc/ada/errout.adb | 2 +- gcc/ada/exp_ch9.adb | 89 +++++++----- gcc/ada/freeze.adb | 26 ++-- gcc/ada/sem_ch13.adb | 328 +++++++++++++++++++++++++++++++++++-------- gcc/ada/sem_ch13.ads | 8 +- gcc/ada/sem_ch3.adb | 28 ++-- 10 files changed, 655 insertions(+), 151 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 51352d1100d..21dadb27127 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2013-09-10 Robert Dewar + + * 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 + + * errout.adb (Finalize): Don't delete real errors with specific + warning control. + +2013-09-10 Ed Schonberg + + * 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 * sem_ch3.adb, sinfo.ads, exp_ch9.adb, sem_prag.adb, sem_ch12.adb, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 5a093af21cf..a7429d79119 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -459,6 +459,203 @@ package Aspects is -- 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 -- --------------------------------------------------- diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 687a5342af4..1da975d0a9e 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -548,8 +548,9 @@ package body Einfo is -- 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 @@ -589,10 +590,6 @@ package body Einfo is -- 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 -- --------------- @@ -638,28 +635,6 @@ package body Einfo is 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 -- -------------------------------- @@ -1380,6 +1355,12 @@ package body Einfo is 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); @@ -2421,6 +2402,11 @@ package body Einfo is 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)); @@ -3978,6 +3964,12 @@ package body Einfo is 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); @@ -5063,6 +5055,11 @@ package body Einfo is 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)); @@ -5969,7 +5966,7 @@ package body Einfo is 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; --------------- @@ -5994,7 +5991,7 @@ package body Einfo is 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; ------------------- @@ -7627,7 +7624,7 @@ package body Einfo is 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; ------------------------ @@ -7636,7 +7633,7 @@ package body Einfo is 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; ------------------ @@ -7895,6 +7892,7 @@ package body Einfo is 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)); @@ -8070,6 +8068,7 @@ package body Einfo is 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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 69a0d7e64a5..0449674d861 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1473,6 +1473,15 @@ package Einfo is -- 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, @@ -1796,7 +1805,7 @@ package Einfo is -- 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. @@ -1880,7 +1889,7 @@ package Einfo is -- 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 @@ -3073,6 +3082,14 @@ package Einfo is -- 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 @@ -5009,6 +5026,7 @@ package Einfo is -- 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) @@ -5048,6 +5066,7 @@ package Einfo is -- 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) @@ -6286,6 +6305,7 @@ package Einfo is 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; @@ -6471,6 +6491,7 @@ package Einfo is 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; @@ -6896,6 +6917,7 @@ package Einfo is 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); @@ -7086,6 +7108,7 @@ package Einfo is 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); @@ -7603,6 +7626,7 @@ package Einfo is 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); @@ -7832,6 +7856,7 @@ package Einfo is 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); @@ -8061,6 +8086,7 @@ package Einfo is 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); @@ -8250,6 +8276,7 @@ package Einfo is 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); diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 5e3e72381fd..b32f6a146f6 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -1302,7 +1302,7 @@ package body Errout is 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 diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index a296a8e8578..16e83091529 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -136,6 +136,15 @@ package body Exp_Ch9 is -- 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; @@ -1298,6 +1307,26 @@ package body Exp_Ch9 is 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 -- ---------------------------------- @@ -6607,7 +6636,9 @@ package body Exp_Ch9 is -- 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 -- ; -- ; @@ -7206,7 +7237,9 @@ package body Exp_Ch9 is 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 @@ -7214,18 +7247,9 @@ package body Exp_Ch9 is 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, @@ -7665,7 +7689,9 @@ package body Exp_Ch9 is -- 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 -- ; -- @@ -7891,7 +7917,9 @@ package body Exp_Ch9 is 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 @@ -7899,18 +7927,9 @@ package body Exp_Ch9 is 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, @@ -11951,7 +11970,9 @@ package body Exp_Ch9 is -- 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 -- ; -- @@ -12394,7 +12415,9 @@ package body Exp_Ch9 is 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 @@ -12402,11 +12425,7 @@ package body Exp_Ch9 is 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)); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8a5b927c570..58098be741d 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2463,12 +2463,14 @@ package body Freeze is 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; @@ -2731,9 +2733,7 @@ package body Freeze is -- 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; @@ -3263,9 +3263,7 @@ package body Freeze is -- 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; @@ -3275,7 +3273,7 @@ package body Freeze is -- 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)) @@ -3349,7 +3347,7 @@ package body Freeze is -- 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 := diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 5f3eb84ecaa..03d635f95b9 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -694,6 +694,29 @@ package body Sem_Ch13 is -- 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 @@ -753,6 +776,181 @@ package body Sem_Ch13 is 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 -- ------------------------------------- @@ -831,15 +1029,18 @@ package body Sem_Ch13 is -- 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; @@ -874,30 +1075,30 @@ package body Sem_Ch13 is 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); - -- For aspects whose expression is an optional Boolean, make - -- the corresponding pragma at the freezing point. + case A_Id is + + -- 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 | @@ -907,17 +1108,27 @@ package body Sem_Ch13 is 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; ----------------------------------- @@ -1046,7 +1257,7 @@ package body Sem_Ch13 is 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; @@ -1279,6 +1490,31 @@ package body Sem_Ch13 is 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 @@ -1318,7 +1554,8 @@ package body Sem_Ch13 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 @@ -1378,12 +1615,6 @@ package body Sem_Ch13 is 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 => @@ -1518,11 +1749,6 @@ package body Sem_Ch13 is 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 @@ -1562,11 +1788,6 @@ package body Sem_Ch13 is 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. @@ -1620,7 +1841,6 @@ package body Sem_Ch13 is Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), Pragma_Name => Name_Abstract_State); - Delay_Required := False; -- Depends @@ -1666,7 +1886,6 @@ package body Sem_Ch13 is Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), Pragma_Name => Name_SPARK_Mode); - Delay_Required := False; -- Relative_Deadline @@ -1910,8 +2129,6 @@ package body Sem_Ch13 is Make_Aitem_Pragma (Pragma_Argument_Associations => Args, Pragma_Name => Nam); - - Delay_Required := False; end Test_Case; -- Contract_Cases @@ -1950,9 +2167,9 @@ package body Sem_Ch13 is 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)) @@ -1984,17 +2201,17 @@ package body Sem_Ch13 is 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 @@ -2007,22 +2224,20 @@ package body Sem_Ch13 is 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; @@ -2188,8 +2403,7 @@ package body Sem_Ch13 is -- 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 @@ -7340,6 +7554,7 @@ package body Sem_Ch13 is when Boolean_Aspects | Library_Unit_Aspects => + T := Standard_Boolean; -- Aspects corresponding to attribute definition clauses @@ -8725,6 +8940,7 @@ package body Sem_Ch13 is ------------------------------------- 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 diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 611f3f1c617..0d95174c14a 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -305,10 +305,12 @@ package Sem_Ch13 is -- 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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 303e2f30132..36882bd8f04 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -169,15 +169,15 @@ package body Sem_Ch3 is 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 @@ -8184,6 +8184,15 @@ package body Sem_Ch3 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); @@ -8226,6 +8235,8 @@ package body Sem_Ch3 is raise Program_Error; end case; + -- Nothing more to do if some error occurred + if Etype (Derived_Type) = Any_Type then return; end if; @@ -8235,6 +8246,7 @@ package body Sem_Ch3 is -- if necessary. Set_Has_Delayed_Freeze (Derived_Type); + if Derive_Subps then Derive_Subprograms (Parent_Type, Derived_Type); end if;