OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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.

From-SVN: r202456
This commit is contained in:
Arnaud Charlet 2013-09-10 16:54:41 +02:00
parent 573e5dd6ac
commit 15e934bf71
10 changed files with 655 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
gcc/ada/ChangeLog
View File

@ -1,3 +1,37 @@
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,

197
gcc/ada/aspects.ads
View File

@ -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 --
---------------------------------------------------

63
gcc/ada/einfo.adb
View File

@ -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));

31
gcc/ada/einfo.ads
View File

@ -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);

2
gcc/ada/errout.adb
View File

@ -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

89
gcc/ada/exp_ch9.adb
View File

@ -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
-- <dispatching-call>;
-- <triggering-statements>;
@ -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
-- <dispatching-call>;
-- <triggering-statements>
@ -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
-- <dispatching-call>;
-- <triggering-statements>
@ -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));

26
gcc/ada/freeze.adb
View File

@ -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 :=

328
gcc/ada/sem_ch13.adb
View File

@ -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

8
gcc/ada/sem_ch13.ads
View File

@ -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

28
gcc/ada/sem_ch3.adb
View File

@ -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;