Skip to content

R
riscv-gcc-1
Commit 15e934bf by Arnaud Charlet
Options

[multiple changes] 

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
parent 573e5dd6
Showing with 186 additions and 95 deletions
gcc/ada/ChangeLog
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,
exp_ch4.adb, sprint.adb: Minor reformatting.
......
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));
......
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);
......
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
......
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
-- <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));
......
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 :=
......
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
......
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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment