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> 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, * sem_ch3.adb, sinfo.ads, exp_ch9.adb, sem_prag.adb, sem_ch12.adb,
exp_ch4.adb, sprint.adb: Minor reformatting. exp_ch4.adb, sprint.adb: Minor reformatting.
......
gcc/ada/einfo.adb
...@@ -548,8 +548,9 @@ package body Einfo is ...@@ -548,8 +548,9 @@ package body Einfo is
-- Has_Static_Predicate_Aspect Flag259 -- Has_Static_Predicate_Aspect Flag259
-- Has_Loop_Entry_Attributes Flag260 -- Has_Loop_Entry_Attributes Flag260
-- (unused) Flag261 -- Has_Delayed_Rep_Aspects Flag261
-- (unused) Flag262 -- May_Inherit_Delayed_Rep_Aspects Flag262
-- (unused) Flag263 -- (unused) Flag263
-- (unused) Flag264 -- (unused) Flag264
-- (unused) Flag265 -- (unused) Flag265
...@@ -589,10 +590,6 @@ package body Einfo is ...@@ -589,10 +590,6 @@ package body Einfo is
-- Determine whether abstract state State has a particular property denoted -- Determine whether abstract state State has a particular property denoted
-- by the name Prop_Nam. -- 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 -- -- Float_Rep --
--------------- ---------------
...@@ -638,28 +635,6 @@ package body Einfo is ...@@ -638,28 +635,6 @@ package body Einfo is
return False; return False;
end Has_Property; 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 -- -- Attribute Access Functions --
-------------------------------- --------------------------------
...@@ -1380,6 +1355,12 @@ package body Einfo is ...@@ -1380,6 +1355,12 @@ package body Einfo is
return Flag18 (Id); return Flag18 (Id);
end Has_Delayed_Freeze; 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 function Has_Discriminants (Id : E) return B is
begin begin
pragma Assert (Nkind (Id) in N_Entity); pragma Assert (Nkind (Id) in N_Entity);
...@@ -2421,6 +2402,11 @@ package body Einfo is ...@@ -2421,6 +2402,11 @@ package body Einfo is
return Flag168 (Id); return Flag168 (Id);
end Materialize_Entity; 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 function Mechanism (Id : E) return M is
begin begin
pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id)); pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id));
...@@ -3978,6 +3964,12 @@ package body Einfo is ...@@ -3978,6 +3964,12 @@ package body Einfo is
Set_Flag18 (Id, V); Set_Flag18 (Id, V);
end Set_Has_Delayed_Freeze; 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 procedure Set_Has_Discriminants (Id : E; V : B := True) is
begin begin
pragma Assert (Nkind (Id) in N_Entity); pragma Assert (Nkind (Id) in N_Entity);
...@@ -5063,6 +5055,11 @@ package body Einfo is ...@@ -5063,6 +5055,11 @@ package body Einfo is
Set_Flag168 (Id, V); Set_Flag168 (Id, V);
end Set_Materialize_Entity; 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 procedure Set_Mechanism (Id : E; V : M) is
begin begin
pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id)); pragma Assert (Ekind (Id) = E_Function or else Is_Formal (Id));
...@@ -5969,7 +5966,7 @@ package body Einfo is ...@@ -5969,7 +5966,7 @@ package body Einfo is
function Address_Clause (Id : E) return N is function Address_Clause (Id : E) return N is
begin begin
return Rep_Clause (Id, Name_Address); return Get_Attribute_Definition_Clause (Id, Attribute_Address);
end Address_Clause; end Address_Clause;
--------------- ---------------
...@@ -5994,7 +5991,7 @@ package body Einfo is ...@@ -5994,7 +5991,7 @@ package body Einfo is
function Alignment_Clause (Id : E) return N is function Alignment_Clause (Id : E) return N is
begin begin
return Rep_Clause (Id, Name_Alignment); return Get_Attribute_Definition_Clause (Id, Attribute_Alignment);
end Alignment_Clause; end Alignment_Clause;
------------------- -------------------
...@@ -7627,7 +7624,7 @@ package body Einfo is ...@@ -7627,7 +7624,7 @@ package body Einfo is
function Size_Clause (Id : E) return N is function Size_Clause (Id : E) return N is
begin begin
return Rep_Clause (Id, Name_Size); return Get_Attribute_Definition_Clause (Id, Attribute_Size);
end Size_Clause; end Size_Clause;
------------------------ ------------------------
...@@ -7636,7 +7633,7 @@ package body Einfo is ...@@ -7636,7 +7633,7 @@ package body Einfo is
function Stream_Size_Clause (Id : E) return N is function Stream_Size_Clause (Id : E) return N is
begin begin
return Rep_Clause (Id, Name_Stream_Size); return Get_Attribute_Definition_Clause (Id, Attribute_Stream_Size);
end Stream_Size_Clause; end Stream_Size_Clause;
------------------ ------------------
...@@ -7895,6 +7892,7 @@ package body Einfo is ...@@ -7895,6 +7892,7 @@ package body Einfo is
W ("Has_Default_Aspect", Flag39 (Id)); W ("Has_Default_Aspect", Flag39 (Id));
W ("Has_Delayed_Aspects", Flag200 (Id)); W ("Has_Delayed_Aspects", Flag200 (Id));
W ("Has_Delayed_Freeze", Flag18 (Id)); W ("Has_Delayed_Freeze", Flag18 (Id));
W ("Has_Delayed_Rep_Aspects", Flag261 (Id));
W ("Has_Discriminants", Flag5 (Id)); W ("Has_Discriminants", Flag5 (Id));
W ("Has_Dispatch_Table", Flag220 (Id)); W ("Has_Dispatch_Table", Flag220 (Id));
W ("Has_Dynamic_Predicate_Aspect", Flag258 (Id)); W ("Has_Dynamic_Predicate_Aspect", Flag258 (Id));
...@@ -8070,6 +8068,7 @@ package body Einfo is ...@@ -8070,6 +8068,7 @@ package body Einfo is
W ("Low_Bound_Tested", Flag205 (Id)); W ("Low_Bound_Tested", Flag205 (Id));
W ("Machine_Radix_10", Flag84 (Id)); W ("Machine_Radix_10", Flag84 (Id));
W ("Materialize_Entity", Flag168 (Id)); W ("Materialize_Entity", Flag168 (Id));
W ("May_Inherit_Delayed_Rep_Aspects", Flag262 (Id));
W ("Must_Be_On_Byte_Boundary", Flag183 (Id)); W ("Must_Be_On_Byte_Boundary", Flag183 (Id));
W ("Must_Have_Preelab_Init", Flag208 (Id)); W ("Must_Have_Preelab_Init", Flag208 (Id));
W ("Needs_Debug_Info", Flag147 (Id)); W ("Needs_Debug_Info", Flag147 (Id));
......
gcc/ada/einfo.ads
...@@ -1473,6 +1473,15 @@ package Einfo is ...@@ -1473,6 +1473,15 @@ package Einfo is
-- apsect. If this flag is set, then a corresponding aspect specification -- apsect. If this flag is set, then a corresponding aspect specification
-- node will be present on the rep item chain for the entity. -- 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) -- Has_Discriminants (Flag5)
-- Defined in all types and subtypes. For types that are allowed to have -- Defined in all types and subtypes. For types that are allowed to have
-- discriminants (record types and subtypes, task types and subtypes, -- discriminants (record types and subtypes, task types and subtypes,
...@@ -1796,7 +1805,7 @@ package Einfo is ...@@ -1796,7 +1805,7 @@ package Einfo is
-- Has_Size_Clause (Flag29) -- Has_Size_Clause (Flag29)
-- Defined in entities for types and objects. Set if a size clause is -- 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 -- 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 -- type, even though the Size for such a type is inherited from a Size
-- clause given for the parent type. -- clause given for the parent type.
...@@ -1880,7 +1889,7 @@ package Einfo is ...@@ -1880,7 +1889,7 @@ package Einfo is
-- Types can have unknown discriminants either from their declaration or -- Types can have unknown discriminants either from their declaration or
-- through type derivation. The use of this flag exactly meets the spec -- 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 -- 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 -- Has_Unknown_Discriminants may be true for a type. Class-wide types and
-- their subtypes have unknown discriminants and can have declared ones -- their subtypes have unknown discriminants and can have declared ones
-- as well. Private types declared with unknown discriminants may have a -- as well. Private types declared with unknown discriminants may have a
...@@ -3073,6 +3082,14 @@ package Einfo is ...@@ -3073,6 +3082,14 @@ package Einfo is
-- containing the renamed address should be allocated. This is needed so -- containing the renamed address should be allocated. This is needed so
-- that the debugger can find the entity. -- 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) -- Mechanism (Uint8) (returned as Mechanism_Type)
-- Defined in functions and non-generic formal parameters. Indicates -- Defined in functions and non-generic formal parameters. Indicates
-- the mechanism to be used for the function return or for the formal -- the mechanism to be used for the function return or for the formal
...@@ -5009,6 +5026,7 @@ package Einfo is ...@@ -5009,6 +5026,7 @@ package Einfo is
-- Has_Constrained_Partial_View (Flag187) -- Has_Constrained_Partial_View (Flag187)
-- Has_Controlled_Component (Flag43) (base type only) -- Has_Controlled_Component (Flag43) (base type only)
-- Has_Default_Aspect (Flag39) (base type only) -- Has_Default_Aspect (Flag39) (base type only)
-- Has_Delayed_Rep_Aspects (Flag261)
-- Has_Discriminants (Flag5) -- Has_Discriminants (Flag5)
-- Has_Dynamic_Predicate_Aspect (Flag258) -- Has_Dynamic_Predicate_Aspect (Flag258)
-- Has_Independent_Components (Flag34) (base type only) -- Has_Independent_Components (Flag34) (base type only)
...@@ -5048,6 +5066,7 @@ package Einfo is ...@@ -5048,6 +5066,7 @@ package Einfo is
-- Is_Volatile (Flag16) -- Is_Volatile (Flag16)
-- Itype_Printed (Flag202) (itypes only) -- Itype_Printed (Flag202) (itypes only)
-- Known_To_Have_Preelab_Init (Flag207) -- Known_To_Have_Preelab_Init (Flag207)
-- May_Inherit_Delayed_Rep_Aspects (Flag262)
-- Must_Be_On_Byte_Boundary (Flag183) -- Must_Be_On_Byte_Boundary (Flag183)
-- Must_Have_Preelab_Init (Flag208) -- Must_Have_Preelab_Init (Flag208)
-- Optimize_Alignment_Space (Flag241) -- Optimize_Alignment_Space (Flag241)
...@@ -6286,6 +6305,7 @@ package Einfo is ...@@ -6286,6 +6305,7 @@ package Einfo is
function Has_Default_Aspect (Id : E) return B; function Has_Default_Aspect (Id : E) return B;
function Has_Delayed_Aspects (Id : E) return B; function Has_Delayed_Aspects (Id : E) return B;
function Has_Delayed_Freeze (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_Discriminants (Id : E) return B;
function Has_Dispatch_Table (Id : E) return B; function Has_Dispatch_Table (Id : E) return B;
function Has_Dynamic_Predicate_Aspect (Id : E) return B; function Has_Dynamic_Predicate_Aspect (Id : E) return B;
...@@ -6471,6 +6491,7 @@ package Einfo is ...@@ -6471,6 +6491,7 @@ package Einfo is
function Machine_Radix_10 (Id : E) return B; function Machine_Radix_10 (Id : E) return B;
function Master_Id (Id : E) return E; function Master_Id (Id : E) return E;
function Materialize_Entity (Id : E) return B; function Materialize_Entity (Id : E) return B;
function May_Inherit_Delayed_Rep_Aspects (Id : E) return B;
function Mechanism (Id : E) return M; function Mechanism (Id : E) return M;
function Modulus (Id : E) return U; function Modulus (Id : E) return U;
function Must_Be_On_Byte_Boundary (Id : E) return B; function Must_Be_On_Byte_Boundary (Id : E) return B;
...@@ -6896,6 +6917,7 @@ package Einfo is ...@@ -6896,6 +6917,7 @@ package Einfo is
procedure Set_Has_Default_Aspect (Id : E; V : B := True); procedure Set_Has_Default_Aspect (Id : E; V : B := True);
procedure Set_Has_Delayed_Aspects (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_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_Discriminants (Id : E; V : B := True);
procedure Set_Has_Dispatch_Table (Id : E; V : B := True); procedure Set_Has_Dispatch_Table (Id : E; V : B := True);
procedure Set_Has_Dynamic_Predicate_Aspect (Id : E; V : B := True); procedure Set_Has_Dynamic_Predicate_Aspect (Id : E; V : B := True);
...@@ -7086,6 +7108,7 @@ package Einfo is ...@@ -7086,6 +7108,7 @@ package Einfo is
procedure Set_Machine_Radix_10 (Id : E; V : B := True); procedure Set_Machine_Radix_10 (Id : E; V : B := True);
procedure Set_Master_Id (Id : E; V : E); procedure Set_Master_Id (Id : E; V : E);
procedure Set_Materialize_Entity (Id : E; V : B := True); 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_Mechanism (Id : E; V : M);
procedure Set_Modulus (Id : E; V : U); procedure Set_Modulus (Id : E; V : U);
procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True); procedure Set_Must_Be_On_Byte_Boundary (Id : E; V : B := True);
...@@ -7603,6 +7626,7 @@ package Einfo is ...@@ -7603,6 +7626,7 @@ package Einfo is
pragma Inline (Has_Default_Aspect); pragma Inline (Has_Default_Aspect);
pragma Inline (Has_Delayed_Aspects); pragma Inline (Has_Delayed_Aspects);
pragma Inline (Has_Delayed_Freeze); pragma Inline (Has_Delayed_Freeze);
pragma Inline (Has_Delayed_Rep_Aspects);
pragma Inline (Has_Discriminants); pragma Inline (Has_Discriminants);
pragma Inline (Has_Dispatch_Table); pragma Inline (Has_Dispatch_Table);
pragma Inline (Has_Dynamic_Predicate_Aspect); pragma Inline (Has_Dynamic_Predicate_Aspect);
...@@ -7832,6 +7856,7 @@ package Einfo is ...@@ -7832,6 +7856,7 @@ package Einfo is
pragma Inline (Machine_Radix_10); pragma Inline (Machine_Radix_10);
pragma Inline (Master_Id); pragma Inline (Master_Id);
pragma Inline (Materialize_Entity); pragma Inline (Materialize_Entity);
pragma Inline (May_Inherit_Delayed_Rep_Aspects);
pragma Inline (Mechanism); pragma Inline (Mechanism);
pragma Inline (Modulus); pragma Inline (Modulus);
pragma Inline (Must_Be_On_Byte_Boundary); pragma Inline (Must_Be_On_Byte_Boundary);
...@@ -8061,6 +8086,7 @@ package Einfo is ...@@ -8061,6 +8086,7 @@ package Einfo is
pragma Inline (Set_Has_Default_Aspect); pragma Inline (Set_Has_Default_Aspect);
pragma Inline (Set_Has_Delayed_Aspects); pragma Inline (Set_Has_Delayed_Aspects);
pragma Inline (Set_Has_Delayed_Freeze); pragma Inline (Set_Has_Delayed_Freeze);
pragma Inline (Set_Has_Delayed_Rep_Aspects);
pragma Inline (Set_Has_Discriminants); pragma Inline (Set_Has_Discriminants);
pragma Inline (Set_Has_Dispatch_Table); pragma Inline (Set_Has_Dispatch_Table);
pragma Inline (Set_Has_Dynamic_Predicate_Aspect); pragma Inline (Set_Has_Dynamic_Predicate_Aspect);
...@@ -8250,6 +8276,7 @@ package Einfo is ...@@ -8250,6 +8276,7 @@ package Einfo is
pragma Inline (Set_Machine_Radix_10); pragma Inline (Set_Machine_Radix_10);
pragma Inline (Set_Master_Id); pragma Inline (Set_Master_Id);
pragma Inline (Set_Materialize_Entity); pragma Inline (Set_Materialize_Entity);
pragma Inline (Set_May_Inherit_Delayed_Rep_Aspects);
pragma Inline (Set_Mechanism); pragma Inline (Set_Mechanism);
pragma Inline (Set_Modulus); pragma Inline (Set_Modulus);
pragma Inline (Set_Must_Be_On_Byte_Boundary); pragma Inline (Set_Must_Be_On_Byte_Boundary);
......
gcc/ada/errout.adb
...@@ -1302,7 +1302,7 @@ package body Errout is ...@@ -1302,7 +1302,7 @@ package body Errout is
CE : Error_Msg_Object renames Errors.Table (Cur); CE : Error_Msg_Object renames Errors.Table (Cur);
begin begin
if not CE.Deleted if (CE.Warn and not CE.Deleted)
and then and then
(Warning_Specifically_Suppressed (CE.Sptr, CE.Text) (Warning_Specifically_Suppressed (CE.Sptr, CE.Text)
or else or else
......
gcc/ada/exp_ch9.adb
...@@ -136,6 +136,15 @@ package body Exp_Ch9 is ...@@ -136,6 +136,15 @@ package body Exp_Ch9 is
-- build record declaration. N is the type declaration, Ctyp is the -- build record declaration. N is the type declaration, Ctyp is the
-- concurrent entity (task type or protected type). -- 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 function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id; (Concurrent_Type : Node_Id;
Component_List : List_Id; Component_List : List_Id;
...@@ -1298,6 +1307,26 @@ package body Exp_Ch9 is ...@@ -1298,6 +1307,26 @@ package body Exp_Ch9 is
Limited_Present => True)); Limited_Present => True));
end Build_Corresponding_Record; 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 -- -- Build_Entry_Count_Expression --
---------------------------------- ----------------------------------
...@@ -6607,7 +6636,9 @@ package body Exp_Ch9 is ...@@ -6607,7 +6636,9 @@ package body Exp_Ch9 is
-- U : Boolean; -- U : Boolean;
-- begin -- 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>; -- <dispatching-call>;
-- <triggering-statements>; -- <triggering-statements>;
...@@ -7206,7 +7237,9 @@ package body Exp_Ch9 is ...@@ -7206,7 +7237,9 @@ package body Exp_Ch9 is
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall));
-- Generate: -- 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 -- Lim_Typ_Stmts
-- else -- else
-- Conc_Typ_Stmts -- Conc_Typ_Stmts
...@@ -7214,18 +7247,9 @@ package body Exp_Ch9 is ...@@ -7214,18 +7247,9 @@ package body Exp_Ch9 is
Append_To (Stmts, Append_To (Stmts,
Make_Implicit_If_Statement (N, Make_Implicit_If_Statement (N,
Condition => Condition => Build_Dispatching_Tag_Check (K, N),
Make_Op_Eq (Loc, Then_Statements => Lim_Typ_Stmts,
Left_Opnd => Else_Statements => Conc_Typ_Stmts));
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));
Rewrite (N, Rewrite (N,
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
...@@ -7665,7 +7689,9 @@ package body Exp_Ch9 is ...@@ -7665,7 +7689,9 @@ package body Exp_Ch9 is
-- S : Integer; -- S : Integer;
-- begin -- 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>; -- <dispatching-call>;
-- <triggering-statements> -- <triggering-statements>
...@@ -7891,7 +7917,9 @@ package body Exp_Ch9 is ...@@ -7891,7 +7917,9 @@ package body Exp_Ch9 is
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk));
-- Generate: -- 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 -- Lim_Typ_Stmts
-- else -- else
-- Conc_Typ_Stmts -- Conc_Typ_Stmts
...@@ -7899,18 +7927,9 @@ package body Exp_Ch9 is ...@@ -7899,18 +7927,9 @@ package body Exp_Ch9 is
Append_To (Stmts, Append_To (Stmts,
Make_Implicit_If_Statement (N, Make_Implicit_If_Statement (N,
Condition => Condition => Build_Dispatching_Tag_Check (K, N),
Make_Op_Eq (Loc, Then_Statements => Lim_Typ_Stmts,
Left_Opnd => Else_Statements => Conc_Typ_Stmts));
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));
Rewrite (N, Rewrite (N,
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
...@@ -11951,7 +11970,9 @@ package body Exp_Ch9 is ...@@ -11951,7 +11970,9 @@ package body Exp_Ch9 is
-- S : Integer; -- S : Integer;
-- begin -- 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>; -- <dispatching-call>;
-- <triggering-statements> -- <triggering-statements>
...@@ -12394,7 +12415,9 @@ package body Exp_Ch9 is ...@@ -12394,7 +12415,9 @@ package body Exp_Ch9 is
Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call)); Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
-- Generate: -- 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 -- Lim_Typ_Stmts
-- else -- else
-- Conc_Typ_Stmts -- Conc_Typ_Stmts
...@@ -12402,11 +12425,7 @@ package body Exp_Ch9 is ...@@ -12402,11 +12425,7 @@ package body Exp_Ch9 is
Append_To (Stmts, Append_To (Stmts,
Make_Implicit_If_Statement (N, Make_Implicit_If_Statement (N,
Condition => Condition => Build_Dispatching_Tag_Check (K, N),
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, Then_Statements => Lim_Typ_Stmts,
Else_Statements => Conc_Typ_Stmts)); Else_Statements => Conc_Typ_Stmts));
......
gcc/ada/freeze.adb
...@@ -2463,12 +2463,14 @@ package body Freeze is ...@@ -2463,12 +2463,14 @@ package body Freeze is
or else (Chars (Comp) /= Name_uParent or else (Chars (Comp) /= Name_uParent
and then Is_Controlled (Etype (Comp))) and then Is_Controlled (Etype (Comp)))
or else (Is_Protected_Type (Etype (Comp)) or else (Is_Protected_Type (Etype (Comp))
and then Present and then
(Corresponding_Record_Type Present
(Etype (Comp))) (Corresponding_Record_Type
and then Has_Controlled_Component (Etype (Comp)))
(Corresponding_Record_Type and then
(Etype (Comp))))) Has_Controlled_Component
(Corresponding_Record_Type
(Etype (Comp)))))
then then
Set_Has_Controlled_Component (Rec); Set_Has_Controlled_Component (Rec);
end if; end if;
...@@ -2731,9 +2733,7 @@ package body Freeze is ...@@ -2731,9 +2733,7 @@ package body Freeze is
-- Add checks to detect proper initialization of scalars that may appear -- Add checks to detect proper initialization of scalars that may appear
-- as subprogram parameters. -- as subprogram parameters.
if Is_Subprogram (E) if Is_Subprogram (E) and then Check_Validity_Of_Parameters then
and then Check_Validity_Of_Parameters
then
Apply_Parameter_Validity_Checks (E); Apply_Parameter_Validity_Checks (E);
end if; end if;
...@@ -3263,9 +3263,7 @@ package body Freeze is ...@@ -3263,9 +3263,7 @@ package body Freeze is
-- then the only purpose of the Import pragma is to suppress -- then the only purpose of the Import pragma is to suppress
-- implicit initialization. -- implicit initialization.
if Is_Imported (E) if Is_Imported (E) and then No (Address_Clause (E)) then
and then No (Address_Clause (E))
then
Set_Is_Public (E); Set_Is_Public (E);
end if; end if;
...@@ -3275,7 +3273,7 @@ package body Freeze is ...@@ -3275,7 +3273,7 @@ package body Freeze is
-- expects 8-bit sizes for these cases. -- expects 8-bit sizes for these cases.
if (Convention (E) = Convention_C if (Convention (E) = Convention_C
or else or else
Convention (E) = Convention_CPP) Convention (E) = Convention_CPP)
and then Is_Enumeration_Type (Etype (E)) and then Is_Enumeration_Type (Etype (E))
and then not Is_Character_Type (Etype (E)) and then not Is_Character_Type (Etype (E))
...@@ -3349,7 +3347,7 @@ package body Freeze is ...@@ -3349,7 +3347,7 @@ package body Freeze is
-- enclosing statement sequence. -- enclosing statement sequence.
if Ekind_In (E, E_Constant, E_Variable) if Ekind_In (E, E_Constant, E_Variable)
and then not Has_Delayed_Freeze (E) and then not Has_Delayed_Freeze (E)
then then
declare declare
Init_Stmts : constant Node_Id := Init_Stmts : constant Node_Id :=
......
gcc/ada/sem_ch13.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -305,10 +305,12 @@ package Sem_Ch13 is ...@@ -305,10 +305,12 @@ package Sem_Ch13 is
-- in these two expressions are the same, by seeing if the two expressions -- in these two expressions are the same, by seeing if the two expressions
-- are fully conformant, and if not, issue appropriate error messages. -- 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); 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); procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id);
-- Performs the processing described above at the freeze point, ASN is the -- 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 ...@@ -169,15 +169,15 @@ package body Sem_Ch3 is
Parent_Type : Entity_Id; Parent_Type : Entity_Id;
Derived_Type : Entity_Id; Derived_Type : Entity_Id;
Derive_Subps : Boolean := True); Derive_Subps : Boolean := True);
-- Subsidiary procedure for Build_Derived_Type and -- Subsidiary procedure used for tagged and untagged record types
-- Analyze_Private_Extension_Declaration used for tagged and untagged -- by Build_Derived_Type and Analyze_Private_Extension_Declaration.
-- record types. All parameters are as in Build_Derived_Type except that -- All parameters are as in Build_Derived_Type except that N, in
-- N, in addition to being an N_Full_Type_Declaration node, can also be an -- addition to being an N_Full_Type_Declaration node, can also be an
-- N_Private_Extension_Declaration node. See the definition of this routine -- N_Private_Extension_Declaration node. See the definition of this routine
-- for much more info. Derive_Subps indicates whether subprograms should -- for much more info. Derive_Subps indicates whether subprograms should be
-- be derived from the parent type. The only case where Derive_Subps is -- derived from the parent type. The only case where Derive_Subps is False
-- False is for an implicit derived full type for a type derived from a -- is for an implicit derived full type for a type derived from a private
-- private type (see Build_Derived_Type). -- type (see Build_Derived_Type).
procedure Build_Discriminal (Discrim : Entity_Id); procedure Build_Discriminal (Discrim : Entity_Id);
-- Create the discriminal corresponding to discriminant Discrim, that is -- Create the discriminal corresponding to discriminant Discrim, that is
...@@ -8184,6 +8184,15 @@ package body Sem_Ch3 is ...@@ -8184,6 +8184,15 @@ package body Sem_Ch3 is
Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type)); Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
end if; 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 case Ekind (Parent_Type) is
when Numeric_Kind => when Numeric_Kind =>
Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type); Build_Derived_Numeric_Type (N, Parent_Type, Derived_Type);
...@@ -8226,6 +8235,8 @@ package body Sem_Ch3 is ...@@ -8226,6 +8235,8 @@ package body Sem_Ch3 is
raise Program_Error; raise Program_Error;
end case; end case;
-- Nothing more to do if some error occurred
if Etype (Derived_Type) = Any_Type then if Etype (Derived_Type) = Any_Type then
return; return;
end if; end if;
...@@ -8235,6 +8246,7 @@ package body Sem_Ch3 is ...@@ -8235,6 +8246,7 @@ package body Sem_Ch3 is
-- if necessary. -- if necessary.
Set_Has_Delayed_Freeze (Derived_Type); Set_Has_Delayed_Freeze (Derived_Type);
if Derive_Subps then if Derive_Subps then
Derive_Subprograms (Parent_Type, Derived_Type); Derive_Subprograms (Parent_Type, Derived_Type);
end if; 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