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

einfo.ads, einfo.adb: Remove Is_Psected flag, no longer used 

* einfo.ads, einfo.adb: Remove Is_Psected flag, no longer used
	(Has_Rep_Pragma): New function
	(Has_Attribute_Definition_Clause): New function
	(Record_Rep_Pragma): Moved here from sem_ch13.adb
	(Get_Rep_Pragma): Remove junk kludge for Stream_Convert pragma

	* sem_ch13.ads, sem_ch13.adb (Record_Rep_Pragma): Moved to einfo.adb

	* exp_prag.adb: (Expand_Pragma_Common_Object): New procedure
	(Expand_Pragma_Psect_Object): New procedure
	These procedures contain the revised and cleaned up processing for
	these two pragmas. This processing was formerly in Sem_Prag, but
	is more appropriately moved here. The cleanup involves making sure
	that the pragmas are properly attached to the tree, and that no
	nodes are improperly shared.

	* sem_prag.adb: Move expansion of Common_Object and Psect_Object
	pragmas to Exp_Prag, which is more appropriate.
	Attach these two pragmas to the Rep_Item chain Use Rep_Item chain to
	check for duplicates Remove use of Is_Psected flag, no longer needed.
	Use new Make_String_Literal function with string.

	* exp_attr.adb (Expand_Fpt_Attribute): The floating-point attributes
	that are functions return universal values, that have to be converted
	to the context type.
	Use new Make_String_Literal function with string.
	(Get_Stream_Convert_Pragma): New function, replaces the use of
	Get_Rep_Pragma, which had to be kludged to work in this case.

	* freeze.adb: Use new Has_Rep_Pragma function

	* exp_intr.adb, exp_ch3.adb, sem_attr.adb: Use new Make_String_Literal
	function with string.
	Use new Has_Rep_Pragma function.

	* tbuild.ads, tbuild.adb (Make_String_Literal): New function, takes
	string argument.

From-SVN: r90904
This commit is contained in:
Arnaud Charlet 2004-11-19 11:56:37 +01:00
parent 1735e55db9
commit 1d571f3b00
13 changed files with 373 additions and 296 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

113
gcc/ada/einfo.adb
View File

@ -386,7 +386,6 @@ package body Einfo is
-- Vax_Float Flag151 -- Vax_Float Flag151
-- Entry_Accepted Flag152 -- Entry_Accepted Flag152
-- Is_Psected Flag153
-- Has_Per_Object_Constraint Flag154 -- Has_Per_Object_Constraint Flag154
-- Has_Private_Declaration Flag155 -- Has_Private_Declaration Flag155
-- Referenced Flag156 -- Referenced Flag156
@ -421,7 +420,7 @@ package body Einfo is
-- Has_Xref_Entry Flag182 -- Has_Xref_Entry Flag182
-- Must_Be_On_Byte_Boundary Flag183 -- Must_Be_On_Byte_Boundary Flag183
-- Note: there are no unused flags currently! -- (unused) Flag153
-------------------------------- --------------------------------
-- Attribute Access Functions -- -- Attribute Access Functions --
@ -1587,11 +1586,6 @@ package body Einfo is
return Flag53 (Id); return Flag53 (Id);
end Is_Private_Descendant; end Is_Private_Descendant;
function Is_Psected (Id : E) return B is
begin
return Flag153 (Id);
end Is_Psected;
function Is_Public (Id : E) return B is function Is_Public (Id : E) return B is
begin begin
pragma Assert (Nkind (Id) in N_Entity); pragma Assert (Nkind (Id) in N_Entity);
@ -3547,11 +3541,6 @@ package body Einfo is
Set_Flag53 (Id, V); Set_Flag53 (Id, V);
end Set_Is_Private_Descendant; end Set_Is_Private_Descendant;
procedure Set_Is_Psected (Id : E; V : B := True) is
begin
Set_Flag153 (Id, V);
end Set_Is_Psected;
procedure Set_Is_Public (Id : E; V : B := True) is procedure Set_Is_Public (Id : E; V : B := True) is
begin begin
pragma Assert (Nkind (Id) in N_Entity); pragma Assert (Nkind (Id) in N_Entity);
@ -4806,6 +4795,10 @@ package body Einfo is
-- Scans the Discriminants to see whether any are Completely_Hidden -- Scans the Discriminants to see whether any are Completely_Hidden
-- (the mechanism for describing non-specified stored discriminants) -- (the mechanism for describing non-specified stored discriminants)
----------------------------------------
-- Has_Completely_Hidden_Discriminant --
----------------------------------------
function Has_Completely_Hidden_Discriminant (Id : E) return Boolean is function Has_Completely_Hidden_Discriminant (Id : E) return Boolean is
Ent : Entity_Id := Id; Ent : Entity_Id := Id;
@ -4813,7 +4806,6 @@ package body Einfo is
pragma Assert (Ekind (Id) = E_Discriminant); pragma Assert (Ekind (Id) = E_Discriminant);
while Present (Ent) and then Ekind (Ent) = E_Discriminant loop while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
if Is_Completely_Hidden (Ent) then if Is_Completely_Hidden (Ent) then
return True; return True;
end if; end if;
@ -4921,9 +4913,8 @@ package body Einfo is
------------------------------------- -------------------------------------
function Get_Attribute_Definition_Clause function Get_Attribute_Definition_Clause
(E : Entity_Id; (E : Entity_Id;
Id : Attribute_Id) Id : Attribute_Id) return Node_Id
return Node_Id
is is
N : Node_Id; N : Node_Id;
@ -4947,40 +4938,16 @@ package body Einfo is
-------------------- --------------------
function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is
N : Node_Id; N : Node_Id;
Typ : Entity_Id;
begin begin
N := First_Rep_Item (E); N := First_Rep_Item (E);
while Present (N) loop while Present (N) loop
if Nkind (N) = N_Pragma and then Chars (N) = Nam then if Nkind (N) = N_Pragma and then Chars (N) = Nam then
return N;
if Nam = Name_Stream_Convert then
-- For tagged types this pragma is not inherited, so we
-- must verify that it is defined for the given type and
-- not an ancestor.
Typ := Entity (Expression
(First (Pragma_Argument_Associations (N))));
if not Is_Tagged_Type (E)
or else E = Typ
or else (Is_Private_Type (Typ)
and then E = Full_View (Typ))
then
return N;
else
Next_Rep_Item (N);
end if;
else
return N;
end if;
else
Next_Rep_Item (N);
end if; end if;
Next_Rep_Item (N);
end loop; end loop;
return Empty; return Empty;
@ -5010,6 +4977,18 @@ package body Einfo is
return False; return False;
end Has_Attach_Handler; end Has_Attach_Handler;
-------------------------------------
-- Has_Attribute_Definition_Clause --
-------------------------------------
function Has_Attribute_Definition_Clause
(E : Entity_Id;
Id : Attribute_Id) return Boolean
is
begin
return Present (Get_Attribute_Definition_Clause (E, Id));
end Has_Attribute_Definition_Clause;
----------------- -----------------
-- Has_Entries -- -- Has_Entries --
----------------- -----------------
@ -5020,8 +4999,8 @@ package body Einfo is
begin begin
pragma Assert (Is_Concurrent_Type (Id)); pragma Assert (Is_Concurrent_Type (Id));
Ent := First_Entity (Id);
Ent := First_Entity (Id);
while Present (Ent) loop while Present (Ent) loop
if Is_Entry (Ent) then if Is_Entry (Ent) then
Result := True; Result := True;
@ -5089,6 +5068,15 @@ package body Einfo is
end loop; end loop;
end Has_Private_Ancestor; end Has_Private_Ancestor;
--------------------
-- Has_Rep_Pragma --
--------------------
function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean is
begin
return Present (Get_Rep_Pragma (E, Nam));
end Has_Rep_Pragma;
------------------------------ ------------------------------
-- Implementation_Base_Type -- -- Implementation_Base_Type --
------------------------------ ------------------------------
@ -5127,7 +5115,6 @@ package body Einfo is
begin begin
Item := First_Rep_Item (Id); Item := First_Rep_Item (Id);
while Present (Item) loop while Present (Item) loop
if Nkind (Item) = N_Pragma if Nkind (Item) = N_Pragma
and then Get_Pragma_Id (Chars (Item)) = Pragma_Inline_Always and then Get_Pragma_Id (Chars (Item)) = Pragma_Inline_Always
@ -5206,9 +5193,10 @@ package body Einfo is
else else
declare declare
C : Entity_Id := First_Component (Btype); C : Entity_Id;
begin begin
C := First_Component (Btype);
while Present (C) loop while Present (C) loop
if Is_By_Reference_Type (Etype (C)) if Is_By_Reference_Type (Etype (C))
or else Is_Volatile (Etype (C)) or else Is_Volatile (Etype (C))
@ -5376,9 +5364,10 @@ package body Einfo is
else else
declare declare
C : E := First_Component (Btype); C : E;
begin begin
C := First_Component (Btype);
while Present (C) loop while Present (C) loop
if Is_Limited_Type (Etype (C)) then if Is_Limited_Type (Etype (C)) then
return True; return True;
@ -5464,9 +5453,10 @@ package body Einfo is
else else
declare declare
C : Entity_Id := First_Component (Btype); C : Entity_Id;
begin begin
C := First_Component (Btype);
while Present (C) loop while Present (C) loop
if Is_Return_By_Reference_Type (Etype (C)) then if Is_Return_By_Reference_Type (Etype (C)) then
return True; return True;
@ -5529,7 +5519,6 @@ package body Einfo is
begin begin
Comp_Id := Next_Entity (Id); Comp_Id := Next_Entity (Id);
while Present (Comp_Id) loop while Present (Comp_Id) loop
exit when Ekind (Comp_Id) = E_Component; exit when Ekind (Comp_Id) = E_Component;
Comp_Id := Next_Entity (Comp_Id); Comp_Id := Next_Entity (Comp_Id);
@ -5664,7 +5653,6 @@ package body Einfo is
else else
N := 0; N := 0;
T := First_Index (Id); T := First_Index (Id);
while Present (T) loop while Present (T) loop
N := N + 1; N := N + 1;
T := Next (T); T := Next (T);
@ -5685,7 +5673,6 @@ package body Einfo is
begin begin
N := 0; N := 0;
Discr := First_Discriminant (Id); Discr := First_Discriminant (Id);
while Present (Discr) loop while Present (Discr) loop
N := N + 1; N := N + 1;
Discr := Next_Discriminant (Discr); Discr := Next_Discriminant (Discr);
@ -5704,9 +5691,9 @@ package body Einfo is
begin begin
pragma Assert (Is_Concurrent_Type (Id)); pragma Assert (Is_Concurrent_Type (Id));
N := 0; N := 0;
Ent := First_Entity (Id); Ent := First_Entity (Id);
while Present (Ent) loop while Present (Ent) loop
if Is_Entry (Ent) then if Is_Entry (Ent) then
N := N + 1; N := N + 1;
@ -5729,7 +5716,6 @@ package body Einfo is
begin begin
N := 0; N := 0;
Formal := First_Formal (Id); Formal := First_Formal (Id);
while Present (Formal) loop while Present (Formal) loop
N := N + 1; N := N + 1;
Formal := Next_Formal (Formal); Formal := Next_Formal (Formal);
@ -5747,6 +5733,16 @@ package body Einfo is
return Ekind (Id); return Ekind (Id);
end Parameter_Mode; end Parameter_Mode;
---------------------
-- Record_Rep_Item --
---------------------
procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is
begin
Set_Next_Rep_Item (N, First_Rep_Item (E));
Set_First_Rep_Item (E, N);
end Record_Rep_Item;
--------------- ---------------
-- Root_Type -- -- Root_Type --
--------------- ---------------
@ -5804,9 +5800,10 @@ package body Einfo is
----------------- -----------------
function Scope_Depth (Id : E) return Uint is function Scope_Depth (Id : E) return Uint is
Scop : Entity_Id := Id; Scop : Entity_Id;
begin begin
Scop := Id;
while Is_Record_Type (Scop) loop while Is_Record_Type (Scop) loop
Scop := Scope (Scop); Scop := Scope (Scop);
end loop; end loop;
@ -6246,7 +6243,6 @@ package body Einfo is
W ("Is_Preelaborated", Flag59 (Id)); W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id)); W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Psected", Flag153 (Id));
W ("Is_Public", Flag10 (Id)); W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id)); W ("Is_Pure", Flag44 (Id));
W ("Is_Remote_Call_Interface", Flag62 (Id)); W ("Is_Remote_Call_Interface", Flag62 (Id));
@ -6372,14 +6368,13 @@ package body Einfo is
Index : E; Index : E;
begin begin
Write_Attribute (" Component Type ", Write_Attribute
Component_Type (Id)); (" Component Type ", Component_Type (Id));
Write_Eol; Write_Eol;
Write_Str (Prefix); Write_Str (Prefix);
Write_Str (" Indices "); Write_Str (" Indices ");
Index := First_Index (Id); Index := First_Index (Id);
while Present (Index) loop while Present (Index) loop
Write_Attribute (" ", Etype (Index)); Write_Attribute (" ", Etype (Index));
Index := Next_Index (Index); Index := Next_Index (Index);

62
gcc/ada/einfo.ads
View File

@ -2191,10 +2191,6 @@ package Einfo is
-- Is_Protected_Type (synthesized) -- Is_Protected_Type (synthesized)
-- Applies to all entities, true for protected types and subtypes -- Applies to all entities, true for protected types and subtypes
-- Is_Psected (Flag153)
-- Present in entities for objects, true if a valid Psect_Object
-- pragma applies to the object. Used to detect duplicate pragmas.
-- Is_Public (Flag10) -- Is_Public (Flag10)
-- Present in all entities. Set to indicate that an entity defined in -- Present in all entities. Set to indicate that an entity defined in
-- one compilation unit can be referenced from other compilation units. -- one compilation unit can be referenced from other compilation units.
@ -4167,7 +4163,6 @@ package Einfo is
-- Has_Volatile_Components (Flag87) -- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85) -- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124) -- Is_Eliminated (Flag124)
-- Is_Psected (Flag153)
-- Is_True_Constant (Flag163) -- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16) -- Is_Volatile (Flag16)
-- Never_Set_In_Source (Flag115) -- Never_Set_In_Source (Flag115)
@ -4746,7 +4741,6 @@ package Einfo is
-- Has_Volatile_Components (Flag87) -- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85) -- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124) -- Is_Eliminated (Flag124)
-- Is_Psected (Flag153)
-- Is_Shared_Passive (Flag60) -- Is_Shared_Passive (Flag60)
-- Is_True_Constant (Flag163) -- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16) -- Is_Volatile (Flag16)
@ -5186,7 +5180,6 @@ package Einfo is
function Is_Preelaborated (Id : E) return B; function Is_Preelaborated (Id : E) return B;
function Is_Private_Composite (Id : E) return B; function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B; function Is_Private_Descendant (Id : E) return B;
function Is_Psected (Id : E) return B;
function Is_Public (Id : E) return B; function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B; function Is_Pure (Id : E) return B;
function Is_Remote_Call_Interface (Id : E) return B; function Is_Remote_Call_Interface (Id : E) return B;
@ -5662,7 +5655,6 @@ package Einfo is
procedure Set_Is_Preelaborated (Id : E; V : B := True); procedure Set_Is_Preelaborated (Id : E; V : B := True);
procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Psected (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True);
procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True); procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True);
@ -5868,26 +5860,56 @@ package Einfo is
procedure Next_Stored_Discriminant (N : in out Node_Id) procedure Next_Stored_Discriminant (N : in out Node_Id)
renames Proc_Next_Stored_Discriminant; renames Proc_Next_Stored_Discriminant;
------------------------------- ----------------------------------------------
-- Miscellaneous Subprograms -- -- Subprograms for Accessing Rep Item Chain --
------------------------------- ----------------------------------------------
procedure Append_Entity (Id : Entity_Id; V : Entity_Id); -- The First_Rep_Item field of every entity points to a linked list
-- Add an entity to the list of entities declared in the scope V -- (linked through Next_Rep_Item) of representation pragmas and
-- attribute definition clauses that apply to the item. Note that
-- in the case of types, it is assumed that any such rep items for
-- a base type also apply to all subtypes. This is implemented by
-- having the chain for subtypes link onto the chain for the base
-- type, so that any new entries for the subtype are added at the
-- start of the chain.
function Get_Attribute_Definition_Clause
(E : Entity_Id;
Id : Attribute_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for an instance
-- of an attribute definition clause with the given attibute Id Id. If
-- found, the value returned is the N_Attribute_Definition_Clause node,
-- otherwise Empty is returned.
function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id; function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id;
-- Searches the Rep_Item chain for the given entity E, for an instance -- Searches the Rep_Item chain for the given entity E, for an instance
-- of a representation pragma with the given name Nam. If found then -- of a representation pragma with the given name Nam. If found then
-- the value returned is the N_Pragma node, otherwise Empty is returned. -- the value returned is the N_Pragma node, otherwise Empty is returned.
function Get_Attribute_Definition_Clause function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean;
(E : Entity_Id; -- Searches the Rep_Item chain for the given entity E, for an instance
Id : Attribute_Id) -- of representation pragma with the given name Nam. If found then True
return Node_Id; -- is returned, otherwise False indicates that no matching entry was found.
function Has_Attribute_Definition_Clause
(E : Entity_Id;
Id : Attribute_Id) return Boolean;
-- Searches the Rep_Item chain for a given entity E, for an instance -- Searches the Rep_Item chain for a given entity E, for an instance
-- of an attribute definition clause with the given attibute Id Id. If -- of an attribute definition clause with the given attibute Id Id. If
-- found, the value returned is the N_Attribute_Definition_Clause node, -- found, True is returned, otherwise False indicates that no matching
-- otherwise Empty is returned. -- entry was found.
procedure Record_Rep_Item (E : Entity_Id; N : Node_Id);
-- N is the node for either a representation pragma or an attribute
-- definition clause that applies to entity E. This procedure links
-- the node N onto the Rep_Item chain for entity E.
-------------------------------
-- Miscellaneous Subprograms --
-------------------------------
procedure Append_Entity (Id : Entity_Id; V : Entity_Id);
-- Add an entity to the list of entities declared in the scope V
function Is_Entity_Name (N : Node_Id) return Boolean; function Is_Entity_Name (N : Node_Id) return Boolean;
-- Test if the node N is the name of an entity (i.e. is an identifier, -- Test if the node N is the name of an entity (i.e. is an identifier,
@ -6183,7 +6205,6 @@ package Einfo is
pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Type); pragma Inline (Is_Private_Type);
pragma Inline (Is_Protected_Type); pragma Inline (Is_Protected_Type);
pragma Inline (Is_Psected);
pragma Inline (Is_Public); pragma Inline (Is_Public);
pragma Inline (Is_Pure); pragma Inline (Is_Pure);
pragma Inline (Is_Real_Type); pragma Inline (Is_Real_Type);
@ -6499,7 +6520,6 @@ package Einfo is
pragma Inline (Set_Is_Preelaborated); pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant); pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Psected);
pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure); pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Remote_Call_Interface); pragma Inline (Set_Is_Remote_Call_Interface);

70
gcc/ada/exp_attr.adb
View File

@ -138,6 +138,11 @@ package body Exp_Attr is
-- defining it, is returned. In both cases, inheritance of representation -- defining it, is returned. In both cases, inheritance of representation
-- aspects is thus taken into account. -- aspects is thus taken into account.
function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
-- Given a type, find a corresponding stream convert pragma that applies to
-- the implementation base type of this type (Typ). If found, return the
-- pragma node, otherwise return Empty if no pragma is found.
function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean; function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
-- Utility for array attributes, returns true on packed constrained -- Utility for array attributes, returns true on packed constrained
-- arrays, and on access to same. -- arrays, and on access to same.
@ -297,9 +302,11 @@ package body Exp_Attr is
-- The generated call is given the provided set of parameters, and then -- The generated call is given the provided set of parameters, and then
-- wrapped in a conversion which converts the result to the target type -- wrapped in a conversion which converts the result to the target type
-- We use the base type as the target because a range check may be
-- required.
Rewrite (N, Rewrite (N,
Unchecked_Convert_To (Etype (N), Unchecked_Convert_To (Base_Type (Etype (N)),
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Fnm, Name => Fnm,
Parameter_Associations => Args))); Parameter_Associations => Args)));
@ -909,12 +916,9 @@ package body Exp_Attr is
if Pent = Standard_Standard if Pent = Standard_Standard
or else Pent = Standard_ASCII or else Pent = Standard_ASCII
then then
Name_Buffer (1 .. Verbose_Library_Version'Length) :=
Verbose_Library_Version;
Name_Len := Verbose_Library_Version'Length;
Rewrite (N, Rewrite (N,
Make_String_Literal (Loc, Make_String_Literal (Loc,
Strval => String_From_Name_Buffer)); Strval => Verbose_Library_Version));
-- All other cases -- All other cases
@ -1804,9 +1808,7 @@ package body Exp_Attr is
-- from which it is derived. The extra conversion is required -- from which it is derived. The extra conversion is required
-- for the derived case. -- for the derived case.
Prag := Prag := Get_Stream_Convert_Pragma (P_Type);
Get_Rep_Pragma
(Implementation_Base_Type (P_Type), Name_Stream_Convert);
if Present (Prag) then if Present (Prag) then
Arg2 := Next (First (Pragma_Argument_Associations (Prag))); Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
@ -2380,9 +2382,7 @@ package body Exp_Attr is
-- it is derived to type strmtyp. The conversion to acttyp is -- it is derived to type strmtyp. The conversion to acttyp is
-- required for the derived case. -- required for the derived case.
Prag := Prag := Get_Stream_Convert_Pragma (P_Type);
Get_Rep_Pragma
(Implementation_Base_Type (P_Type), Name_Stream_Convert);
if Present (Prag) then if Present (Prag) then
Arg3 := Arg3 :=
@ -2795,9 +2795,7 @@ package body Exp_Attr is
-- where Itemx is the expression of the type conversion (i.e. -- where Itemx is the expression of the type conversion (i.e.
-- the actual object), and typex is the type of Itemx. -- the actual object), and typex is the type of Itemx.
Prag := Prag := Get_Stream_Convert_Pragma (P_Type);
Get_Rep_Pragma
(Implementation_Base_Type (P_Type), Name_Stream_Convert);
if Present (Prag) then if Present (Prag) then
Arg2 := Next (First (Pragma_Argument_Associations (Prag))); Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
@ -4017,9 +4015,7 @@ package body Exp_Attr is
-- it is derived to type strmtyp. The conversion to acttyp is -- it is derived to type strmtyp. The conversion to acttyp is
-- required for the derived case. -- required for the derived case.
Prag := Prag := Get_Stream_Convert_Pragma (P_Type);
Get_Rep_Pragma
(Implementation_Base_Type (P_Type), Name_Stream_Convert);
if Present (Prag) then if Present (Prag) then
Arg3 := Arg3 :=
@ -4326,6 +4322,46 @@ package body Exp_Attr is
return Etype (Indx); return Etype (Indx);
end Get_Index_Subtype; end Get_Index_Subtype;
-------------------------------
-- Get_Stream_Convert_Pragma --
-------------------------------
function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
Typ : Entity_Id;
N : Node_Id;
begin
-- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
-- that a stream convert pragma for a tagged type is not inherited from
-- its parent. Probably what is wrong here is that it is basically
-- incorrect to consider a stream convert pragma to be a representation
-- pragma at all ???
N := First_Rep_Item (Implementation_Base_Type (T));
while Present (N) loop
if Nkind (N) = N_Pragma and then Chars (N) = Name_Stream_Convert then
-- For tagged types this pragma is not inherited, so we
-- must verify that it is defined for the given type and
-- not an ancestor.
Typ :=
Entity (Expression (First (Pragma_Argument_Associations (N))));
if not Is_Tagged_Type (T)
or else T = Typ
or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
then
return N;
end if;
end if;
Next_Rep_Item (N);
end loop;
return Empty;
end Get_Stream_Convert_Pragma;
--------------------------------- ---------------------------------
-- Is_Constrained_Packed_Array -- -- Is_Constrained_Packed_Array --
--------------------------------- ---------------------------------

14
gcc/ada/exp_ch3.adb
View File

@ -57,7 +57,6 @@ with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Stand; use Stand; with Stand; use Stand;
with Stringt; use Stringt;
with Snames; use Snames; with Snames; use Snames;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Ttypes; use Ttypes; with Ttypes; use Ttypes;
@ -1118,15 +1117,10 @@ package body Exp_Ch3 is
-- This is just a workaround that must be improved later??? -- This is just a workaround that must be improved later???
if With_Default_Init then if With_Default_Init then
declare Append_To (Args,
S : String_Id; Make_String_Literal (Loc,
Null_String : Node_Id; Strval => ""));
begin
Start_String;
S := End_String;
Null_String := Make_String_Literal (Loc, Strval => S);
Append_To (Args, Null_String);
end;
else else
Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type); Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
Decl := Last (Decls); Decl := Last (Decls);

7
gcc/ada/exp_intr.adb
View File

@ -110,21 +110,18 @@ package body Exp_Intr is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
P : Node_Id; P : Node_Id;
E : Entity_Id; E : Entity_Id;
S : String_Id;
begin begin
-- Climb up parents to see if we are in exception handler -- Climb up parents to see if we are in exception handler
P := Parent (N); P := Parent (N);
loop loop
-- Case of not in exception handler -- Case of not in exception handler, replace by null string
if No (P) then if No (P) then
Start_String;
S := End_String;
Rewrite (N, Rewrite (N,
Make_String_Literal (Loc, Make_String_Literal (Loc,
Strval => S)); Strval => ""));
exit; exit;
-- Case of in exception handler -- Case of in exception handler

164
gcc/ada/exp_prag.adb
View File

@ -58,22 +58,31 @@ package body Exp_Prag is
function Arg1 (N : Node_Id) return Node_Id; function Arg1 (N : Node_Id) return Node_Id;
function Arg2 (N : Node_Id) return Node_Id; function Arg2 (N : Node_Id) return Node_Id;
-- Obtain specified Pragma_Argument_Association -- Obtain specified pragma argument expression
procedure Expand_Pragma_Abort_Defer (N : Node_Id); procedure Expand_Pragma_Abort_Defer (N : Node_Id);
procedure Expand_Pragma_Assert (N : Node_Id); procedure Expand_Pragma_Assert (N : Node_Id);
procedure Expand_Pragma_Common_Object (N : Node_Id);
procedure Expand_Pragma_Import (N : Node_Id); procedure Expand_Pragma_Import (N : Node_Id);
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id);
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
procedure Expand_Pragma_Psect_Object (N : Node_Id);
---------- ----------
-- Arg1 -- -- Arg1 --
---------- ----------
function Arg1 (N : Node_Id) return Node_Id is function Arg1 (N : Node_Id) return Node_Id is
Arg : constant Node_Id := First (Pragma_Argument_Associations (N));
begin begin
return First (Pragma_Argument_Associations (N)); if Present (Arg)
and then Nkind (Arg) = N_Pragma_Argument_Association
then
return Expression (Arg);
else
return Arg;
end if;
end Arg1; end Arg1;
---------- ----------
@ -81,8 +90,23 @@ package body Exp_Prag is
---------- ----------
function Arg2 (N : Node_Id) return Node_Id is function Arg2 (N : Node_Id) return Node_Id is
Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
begin begin
return Next (Arg1 (N)); if No (Arg1) then
return Empty;
else
declare
Arg : constant Node_Id := Next (Arg1);
begin
if Present (Arg)
and then Nkind (Arg) = N_Pragma_Argument_Association
then
return Expression (Arg);
else
return Arg;
end if;
end;
end if;
end Arg2; end Arg2;
--------------------- ---------------------
@ -105,6 +129,9 @@ package body Exp_Prag is
when Pragma_Assert => when Pragma_Assert =>
Expand_Pragma_Assert (N); Expand_Pragma_Assert (N);
when Pragma_Common_Object =>
Expand_Pragma_Common_Object (N);
when Pragma_Export_Exception => when Pragma_Export_Exception =>
Expand_Pragma_Import_Export_Exception (N); Expand_Pragma_Import_Export_Exception (N);
@ -120,6 +147,9 @@ package body Exp_Prag is
when Pragma_Interrupt_Priority => when Pragma_Interrupt_Priority =>
Expand_Pragma_Interrupt_Priority (N); Expand_Pragma_Interrupt_Priority (N);
when Pragma_Psect_Object =>
Expand_Pragma_Psect_Object (N);
-- All other pragmas need no expander action -- All other pragmas need no expander action
when others => null; when others => null;
@ -195,7 +225,7 @@ package body Exp_Prag is
procedure Expand_Pragma_Assert (N : Node_Id) is procedure Expand_Pragma_Assert (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Cond : constant Node_Id := Expression (Arg1 (N)); Cond : constant Node_Id := Arg1 (N);
Msg : String_Id; Msg : String_Id;
begin begin
@ -222,7 +252,7 @@ package body Exp_Prag is
-- First, we need to prepare the character literal -- First, we need to prepare the character literal
if Present (Arg2 (N)) then if Present (Arg2 (N)) then
Msg := Strval (Expr_Value_S (Expression (Arg2 (N)))); Msg := Strval (Expr_Value_S (Arg2 (N)));
else else
Build_Location_String (Loc); Build_Location_String (Loc);
Msg := String_From_Name_Buffer; Msg := String_From_Name_Buffer;
@ -265,6 +295,114 @@ package body Exp_Prag is
end if; end if;
end Expand_Pragma_Assert; end Expand_Pragma_Assert;
---------------------------------
-- Expand_Pragma_Common_Object --
---------------------------------
-- Add series of pragmas to replicate semantic effect in DEC Ada
-- pragma Linker_Section (internal_name, external_name);
-- pragma Machine_Attribute (internal_name, "overlaid");
-- pragma Machine_Attribute (internal_name, "global");
-- pragma Machine_Attribute (internal_name, "initialize");
-- For now we do nothing with the size attribute ???
-- Really this expansion would be much better in the back end. The
-- front end should not need to know about target dependent, back end
-- dependent semantics ???
procedure Expand_Pragma_Common_Object (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Internal : constant Node_Id := Arg1 (N);
External : constant Node_Id := Arg2 (N);
Psect : Node_Id;
-- Psect value upper cased as string literal
Iloc : constant Source_Ptr := Sloc (Internal);
Eloc : constant Source_Ptr := Sloc (External);
Ploc : Source_Ptr;
begin
-- Acquire Psect value and fold to upper case
if Present (External) then
if Nkind (External) = N_String_Literal then
String_To_Name_Buffer (Strval (External));
else
Get_Name_String (Chars (External));
end if;
Set_All_Upper_Case;
Psect :=
Make_String_Literal (Eloc,
Strval => String_From_Name_Buffer);
else
Get_Name_String (Chars (Internal));
Set_All_Upper_Case;
Psect :=
Make_String_Literal (Iloc,
Strval => String_From_Name_Buffer);
end if;
Ploc := Sloc (Psect);
-- Insert pragmas
Insert_List_After_And_Analyze (N, New_List (
-- The Linker_Section pragma ensures the correct section
Make_Pragma (Loc,
Chars => Name_Linker_Section,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Iloc,
Expression => New_Copy_Tree (Internal)),
Make_Pragma_Argument_Association (Ploc,
Expression => New_Copy_Tree (Psect)))),
-- Machine_Attribute "overlaid" ensures that this section
-- overlays any other sections of the same name.
Make_Pragma (Loc,
Chars => Name_Machine_Attribute,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Iloc,
Expression => New_Copy_Tree (Internal)),
Make_Pragma_Argument_Association (Eloc,
Expression =>
Make_String_Literal (Sloc => Ploc,
Strval => "overlaid")))),
-- Machine_Attribute "global" ensures that section is visible
Make_Pragma (Loc,
Chars => Name_Machine_Attribute,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Iloc,
Expression => New_Copy_Tree (Internal)),
Make_Pragma_Argument_Association (Eloc,
Expression =>
Make_String_Literal (Sloc => Ploc,
Strval => "global")))),
-- Machine_Attribute "initialize" ensures section is demand zeroed
Make_Pragma (Loc,
Chars => Name_Machine_Attribute,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Iloc,
Expression => New_Copy_Tree (Internal)),
Make_Pragma_Argument_Association (Eloc,
Expression =>
Make_String_Literal (Sloc => Ploc,
Strval => "initialize"))))));
end Expand_Pragma_Common_Object;
-------------------------- --------------------------
-- Expand_Pragma_Import -- -- Expand_Pragma_Import --
-------------------------- --------------------------
@ -281,7 +419,7 @@ package body Exp_Prag is
-- seen (i.e. this elaboration cannot be deferred to the freeze point). -- seen (i.e. this elaboration cannot be deferred to the freeze point).
procedure Expand_Pragma_Import (N : Node_Id) is procedure Expand_Pragma_Import (N : Node_Id) is
Def_Id : constant Entity_Id := Entity (Expression (Arg2 (N))); Def_Id : constant Entity_Id := Entity (Arg2 (N));
Typ : Entity_Id; Typ : Entity_Id;
Init_Call : Node_Id; Init_Call : Node_Id;
@ -340,7 +478,7 @@ package body Exp_Prag is
end if; end if;
declare declare
Id : constant Entity_Id := Entity (Expression (Arg1 (N))); Id : constant Entity_Id := Entity (Arg1 (N));
Call : constant Node_Id := Register_Exception_Call (Id); Call : constant Node_Id := Register_Exception_Call (Id);
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
@ -579,4 +717,16 @@ package body Exp_Prag is
end if; end if;
end Expand_Pragma_Interrupt_Priority; end Expand_Pragma_Interrupt_Priority;
--------------------------------
-- Expand_Pragma_Psect_Object --
--------------------------------
-- Convert to Common_Object, and expand the resulting pragma
procedure Expand_Pragma_Psect_Object (N : Node_Id) is
begin
Set_Chars (N, Name_Common_Object);
Expand_Pragma_Common_Object (N);
end Expand_Pragma_Psect_Object;
end Exp_Prag; end Exp_Prag;

8
gcc/ada/freeze.adb
View File

@ -2235,17 +2235,17 @@ package body Freeze is
-- inherited the indication from elsewhere (e.g. an address -- inherited the indication from elsewhere (e.g. an address
-- clause, which is not good enough in RM terms!) -- clause, which is not good enough in RM terms!)
if Present (Get_Rep_Pragma (E, Name_Atomic)) if Has_Rep_Pragma (E, Name_Atomic)
or else or else
Present (Get_Rep_Pragma (E, Name_Atomic_Components)) Has_Rep_Pragma (E, Name_Atomic_Components)
then then
Error_Msg_N Error_Msg_N
("stand alone atomic constant must be " & ("stand alone atomic constant must be " &
"imported ('R'M 'C.6(13))", E); "imported ('R'M 'C.6(13))", E);
elsif Present (Get_Rep_Pragma (E, Name_Volatile)) elsif Has_Rep_Pragma (E, Name_Volatile)
or else or else
Present (Get_Rep_Pragma (E, Name_Volatile_Components)) Has_Rep_Pragma (E, Name_Volatile_Components)
then then
Error_Msg_N Error_Msg_N
("stand alone volatile constant must be " & ("stand alone volatile constant must be " &

11
gcc/ada/sem_attr.adb
View File

@ -1232,7 +1232,7 @@ package body Sem_Attr is
if Is_Limited_Type (P_Type) if Is_Limited_Type (P_Type)
and then Comes_From_Source (N) and then Comes_From_Source (N)
and then not Present (TSS (Btyp, Nam)) and then not Present (TSS (Btyp, Nam))
and then No (Get_Rep_Pragma (Btyp, Name_Stream_Convert)) and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
then then
Error_Msg_Name_1 := Aname; Error_Msg_Name_1 := Aname;
Error_Msg_NE Error_Msg_NE
@ -3480,22 +3480,21 @@ package body Sem_Attr is
when Attribute_Target_Name => Target_Name : declare when Attribute_Target_Name => Target_Name : declare
TN : constant String := Sdefault.Target_Name.all; TN : constant String := Sdefault.Target_Name.all;
TL : Integer := TN'Last; TL : Natural;
begin begin
Check_Standard_Prefix; Check_Standard_Prefix;
Check_E0; Check_E0;
Start_String;
TL := TN'Last;
if TN (TL) = '/' or else TN (TL) = '\' then if TN (TL) = '/' or else TN (TL) = '\' then
TL := TL - 1; TL := TL - 1;
end if; end if;
Store_String_Chars (TN (TN'First .. TL));
Rewrite (N, Rewrite (N,
Make_String_Literal (Loc, Make_String_Literal (Loc,
Strval => End_String)); Strval => TN (TN'First .. TL)));
Analyze_And_Resolve (N, Standard_String); Analyze_And_Resolve (N, Standard_String);
end Target_Name; end Target_Name;

10
gcc/ada/sem_ch13.adb
View File

@ -3411,16 +3411,6 @@ package body Sem_Ch13 is
end if; end if;
end New_Stream_Procedure; end New_Stream_Procedure;
---------------------
-- Record_Rep_Item --
---------------------
procedure Record_Rep_Item (T : Entity_Id; N : Node_Id) is
begin
Set_Next_Rep_Item (N, First_Rep_Item (T));
Set_First_Rep_Item (T, N);
end Record_Rep_Item;
------------------------ ------------------------
-- Rep_Item_Too_Early -- -- Rep_Item_Too_Early --
------------------------ ------------------------

5
gcc/ada/sem_ch13.ads
View File

@ -90,11 +90,6 @@ package Sem_Ch13 is
-- If the size is too small, and an error message is given, then both -- If the size is too small, and an error message is given, then both
-- Esize and RM_Size are reset to the allowed minimum value in T. -- Esize and RM_Size are reset to the allowed minimum value in T.
procedure Record_Rep_Item (T : Entity_Id; N : Node_Id);
-- N is the node for either a representation pragma or an attribute
-- definition clause that applies to type T. This procedure links
-- the node N onto the Rep_Item chain for the type T.
function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean; function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean;
-- Called at the start of processing a representation clause or a -- Called at the start of processing a representation clause or a
-- representation pragma. Used to check that the representation item -- representation pragma. Used to check that the representation item

182
gcc/ada/sem_prag.adb
View File

@ -875,13 +875,11 @@ package body Sem_Prag is
procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
Argx : constant Node_Id := Get_Pragma_Arg (Arg); Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin begin
if Nkind (Argx) /= N_String_Literal then if Nkind (Argx) /= N_String_Literal then
Error_Pragma_Arg Error_Pragma_Arg
("argument for pragma% must be string literal", Argx); ("argument for pragma% must be string literal", Argx);
end if; end if;
end Check_Arg_Is_String_Literal; end Check_Arg_Is_String_Literal;
------------------------------------------ ------------------------------------------
@ -917,7 +915,6 @@ package body Sem_Prag is
procedure Check_At_Most_N_Arguments (N : Nat) is procedure Check_At_Most_N_Arguments (N : Nat) is
Arg : Node_Id; Arg : Node_Id;
begin begin
if Arg_Count > N then if Arg_Count > N then
Arg := Arg1; Arg := Arg1;
@ -997,7 +994,6 @@ package body Sem_Prag is
procedure Check_First_Subtype (Arg : Node_Id) is procedure Check_First_Subtype (Arg : Node_Id) is
Argx : constant Node_Id := Get_Pragma_Arg (Arg); Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin begin
if not Is_First_Subtype (Entity (Argx)) then if not Is_First_Subtype (Entity (Argx)) then
Error_Pragma_Arg Error_Pragma_Arg
@ -1198,11 +1194,9 @@ package body Sem_Prag is
procedure Check_No_Identifiers is procedure Check_No_Identifiers is
Arg_Node : Node_Id; Arg_Node : Node_Id;
begin begin
if Arg_Count > 0 then if Arg_Count > 0 then
Arg_Node := Arg1; Arg_Node := Arg1;
while Present (Arg_Node) loop while Present (Arg_Node) loop
Check_No_Identifier (Arg_Node); Check_No_Identifier (Arg_Node);
Next (Arg_Node); Next (Arg_Node);
@ -1280,8 +1274,9 @@ package body Sem_Prag is
when N_Index_Or_Discriminant_Constraint => when N_Index_Or_Discriminant_Constraint =>
declare declare
IDC : Entity_Id := First (Constraints (Constr)); IDC : Entity_Id;
begin begin
IDC := First (Constraints (Constr));
while Present (IDC) loop while Present (IDC) loop
Check_Static_Constraint (IDC); Check_Static_Constraint (IDC);
Next (IDC); Next (IDC);
@ -1476,10 +1471,8 @@ package body Sem_Prag is
Comp := First (Component_Items (Clist)); Comp := First (Component_Items (Clist));
while Present (Comp) loop while Present (Comp) loop
Check_Component (Comp); Check_Component (Comp);
Next (Comp); Next (Comp);
end loop; end loop;
end Check_Variant; end Check_Variant;
@ -2280,9 +2273,12 @@ package body Sem_Prag is
("pragma% must designate an object", Arg_Internal); ("pragma% must designate an object", Arg_Internal);
end if; end if;
if Is_Psected (Def_Id) then if Has_Rep_Pragma (Def_Id, Name_Common_Object)
or else
Has_Rep_Pragma (Def_Id, Name_Psect_Object)
then
Error_Pragma_Arg Error_Pragma_Arg
("previous Psect_Object applies, pragma % not permitted", ("previous Common/Psect_Object applies, pragma % not permitted",
Arg_Internal); Arg_Internal);
end if; end if;
@ -2463,12 +2459,12 @@ package body Sem_Prag is
begin begin
Process_Extended_Import_Export_Internal_Arg (Arg_Internal); Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
Hom_Id := Entity (Arg_Internal);
Ent := Empty; Ent := Empty;
Ambiguous := False; Ambiguous := False;
-- Loop through homonyms (overloadings) of Hom_Id -- Loop through homonyms (overloadings) of the entity
Hom_Id := Entity (Arg_Internal);
while Present (Hom_Id) loop while Present (Hom_Id) loop
Def_Id := Get_Base_Subprogram (Hom_Id); Def_Id := Get_Base_Subprogram (Hom_Id);
@ -4064,7 +4060,6 @@ package body Sem_Prag is
else else
Bad_Class; Bad_Class;
end if; end if;
end Set_Mechanism_Value; end Set_Mechanism_Value;
--------------------------- ---------------------------
@ -8401,13 +8396,7 @@ package body Sem_Prag is
External : Node_Id renames Args (2); External : Node_Id renames Args (2);
Size : Node_Id renames Args (3); Size : Node_Id renames Args (3);
R_Internal : Node_Id; Def_Id : Entity_Id;
R_External : Node_Id;
MA : Node_Id;
Str : String_Id;
Def_Id : Entity_Id;
procedure Check_Too_Long (Arg : Node_Id); procedure Check_Too_Long (Arg : Node_Id);
-- Posts message if the argument is an identifier with more -- Posts message if the argument is an identifier with more
@ -8451,9 +8440,7 @@ package body Sem_Prag is
Gather_Associations (Names, Args); Gather_Associations (Names, Args);
Process_Extended_Import_Export_Internal_Arg (Internal); Process_Extended_Import_Export_Internal_Arg (Internal);
R_Internal := Relocate_Node (Internal); Def_Id := Entity (Internal);
Def_Id := Entity (R_Internal);
if Ekind (Def_Id) /= E_Constant if Ekind (Def_Id) /= E_Constant
and then Ekind (Def_Id) /= E_Variable and then Ekind (Def_Id) /= E_Variable
@ -8462,38 +8449,39 @@ package body Sem_Prag is
("pragma% must designate an object", Internal); ("pragma% must designate an object", Internal);
end if; end if;
Check_Too_Long (R_Internal); Check_Too_Long (Internal);
if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
Error_Pragma_Arg Error_Pragma_Arg
("cannot use pragma% for imported/exported object", ("cannot use pragma% for imported/exported object",
R_Internal); Internal);
end if; end if;
if Is_Concurrent_Type (Etype (R_Internal)) then if Is_Concurrent_Type (Etype (Internal)) then
Error_Pragma_Arg Error_Pragma_Arg
("cannot specify pragma % for task/protected object", ("cannot specify pragma % for task/protected object",
R_Internal); Internal);
end if; end if;
if Is_Psected (Def_Id) then if Has_Rep_Pragma (Def_Id, Name_Common_Object)
Error_Msg_N ("?duplicate Psect_Object pragma", N); or else
else Has_Rep_Pragma (Def_Id, Name_Psect_Object)
Set_Is_Psected (Def_Id); then
Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
end if; end if;
if Ekind (Def_Id) = E_Constant then if Ekind (Def_Id) = E_Constant then
Error_Pragma_Arg Error_Pragma_Arg
("cannot specify pragma % for a constant", R_Internal); ("cannot specify pragma % for a constant", Internal);
end if; end if;
if Is_Record_Type (Etype (R_Internal)) then if Is_Record_Type (Etype (Internal)) then
declare declare
Ent : Entity_Id; Ent : Entity_Id;
Decl : Entity_Id; Decl : Entity_Id;
begin begin
Ent := First_Entity (Etype (R_Internal)); Ent := First_Entity (Etype (Internal));
while Present (Ent) loop while Present (Ent) loop
Decl := Declaration_Node (Ent); Decl := Declaration_Node (Ent);
@ -8503,7 +8491,7 @@ package body Sem_Prag is
and then Warn_On_Export_Import and then Warn_On_Export_Import
then then
Error_Msg_N Error_Msg_N
("?object for pragma % has defaults", R_Internal); ("?object for pragma % has defaults", Internal);
exit; exit;
else else
@ -8517,120 +8505,13 @@ package body Sem_Prag is
Check_Too_Long (Size); Check_Too_Long (Size);
end if; end if;
-- Make Psect case-insensitive.
if Present (External) then if Present (External) then
Check_Too_Long (External); Check_Too_Long (External);
if Nkind (External) = N_String_Literal then
String_To_Name_Buffer (Strval (External));
else
Get_Name_String (Chars (External));
end if;
Set_All_Upper_Case;
Start_String;
Store_String_Chars (Name_Buffer (1 .. Name_Len));
Str := End_String;
R_External := Make_String_Literal
(Sloc => Sloc (External), Strval => Str);
else
Get_Name_String (Chars (Internal));
Set_All_Upper_Case;
Start_String;
Store_String_Chars (Name_Buffer (1 .. Name_Len));
Str := End_String;
R_External := Make_String_Literal
(Sloc => Sloc (Internal), Strval => Str);
end if; end if;
-- Transform into pragma Linker_Section, add attributes to -- If all error tests pass, link pragma on to the rep item chain
-- match what DEC Ada does. Ignore size for now?
Rewrite (N, Record_Rep_Item (Def_Id, N);
Make_Pragma
(Sloc (N),
Name_Linker_Section,
New_List
(Make_Pragma_Argument_Association
(Sloc => Sloc (R_Internal),
Expression => R_Internal),
Make_Pragma_Argument_Association
(Sloc => Sloc (R_External),
Expression => R_External))));
Analyze (N);
-- Add Machine_Attribute of "overlaid", so the section overlays
-- other sections of the same name.
Start_String;
Store_String_Chars ("overlaid");
Str := End_String;
MA :=
Make_Pragma
(Sloc (N),
Name_Machine_Attribute,
New_List
(Make_Pragma_Argument_Association
(Sloc => Sloc (R_Internal),
Expression => R_Internal),
Make_Pragma_Argument_Association
(Sloc => Sloc (R_External),
Expression =>
Make_String_Literal
(Sloc => Sloc (R_External),
Strval => Str))));
Analyze (MA);
-- Add Machine_Attribute of "global", so the section is visible
-- everywhere
Start_String;
Store_String_Chars ("global");
Str := End_String;
MA :=
Make_Pragma
(Sloc (N),
Name_Machine_Attribute,
New_List
(Make_Pragma_Argument_Association
(Sloc => Sloc (R_Internal),
Expression => R_Internal),
Make_Pragma_Argument_Association
(Sloc => Sloc (R_External),
Expression =>
Make_String_Literal
(Sloc => Sloc (R_External),
Strval => Str))));
Analyze (MA);
-- Add Machine_Attribute of "initialize", so the section is
-- demand zeroed.
Start_String;
Store_String_Chars ("initialize");
Str := End_String;
MA :=
Make_Pragma
(Sloc (N),
Name_Machine_Attribute,
New_List
(Make_Pragma_Argument_Association
(Sloc => Sloc (R_Internal),
Expression => R_Internal),
Make_Pragma_Argument_Association
(Sloc => Sloc (R_External),
Expression =>
Make_String_Literal
(Sloc => Sloc (R_External),
Strval => Str))));
Analyze (MA);
end Psect_Object; end Psect_Object;
---------- ----------
@ -9830,12 +9711,11 @@ package body Sem_Prag is
end if; end if;
Vpart := Variant_Part (Clist); Vpart := Variant_Part (Clist);
Variant := First (Variants (Vpart)); Variant := First (Variants (Vpart));
while Present (Variant) loop while Present (Variant) loop
Check_Variant (Variant); Check_Variant (Variant);
Next (Variant); Next (Variant);
end loop; end loop;
end if; end if;
@ -9921,7 +9801,6 @@ package body Sem_Prag is
Check_At_Least_N_Arguments (1); Check_At_Least_N_Arguments (1);
Arg_Node := Arg1; Arg_Node := Arg1;
while Present (Arg_Node) loop while Present (Arg_Node) loop
Check_No_Identifier (Arg_Node); Check_No_Identifier (Arg_Node);
@ -10117,9 +9996,9 @@ package body Sem_Prag is
if Is_Enumeration_Type (E) then if Is_Enumeration_Type (E) then
declare declare
Lit : Entity_Id := First_Literal (E); Lit : Entity_Id;
begin begin
Lit := First_Literal (E);
while Present (Lit) loop while Present (Lit) loop
Set_Warnings_Off (Lit); Set_Warnings_Off (Lit);
Next_Literal (Lit); Next_Literal (Lit);
@ -10201,10 +10080,9 @@ package body Sem_Prag is
Result : Entity_Id; Result : Entity_Id;
begin begin
Result := Def_Id;
-- Follow subprogram renaming chain -- Follow subprogram renaming chain
Result := Def_Id;
while Is_Subprogram (Result) while Is_Subprogram (Result)
and then and then
(Is_Generic_Instance (Result) (Is_Generic_Instance (Result)

17
gcc/ada/tbuild.adb
View File

@ -35,6 +35,7 @@ with Rident; use Rident;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Stringt; use Stringt;
with Uintp; use Uintp; with Uintp; use Uintp;
package body Tbuild is package body Tbuild is
@ -334,6 +335,22 @@ package body Tbuild is
UI_From_Int (RT_Exception_Code'Pos (Reason))); UI_From_Int (RT_Exception_Code'Pos (Reason)));
end Make_Raise_Storage_Error; end Make_Raise_Storage_Error;
-------------------------
-- Make_String_Literal --
-------------------------
function Make_String_Literal
(Sloc : Source_Ptr;
Strval : String) return Node_Id
is
begin
Start_String;
Store_String_Chars (Strval);
return
Make_String_Literal (Sloc,
Strval => End_String);
end Make_String_Literal;
--------------------------- ---------------------------
-- Make_Unsuppress_Block -- -- Make_Unsuppress_Block --
--------------------------- ---------------------------

6
gcc/ada/tbuild.ads
View File

@ -156,6 +156,12 @@ package Tbuild is
-- A convenient form of Make_Raise_Storage_Error where the Reason -- A convenient form of Make_Raise_Storage_Error where the Reason
-- is given simply as an enumeration value, rather than a Uint code. -- is given simply as an enumeration value, rather than a Uint code.
function Make_String_Literal
(Sloc : Source_Ptr;
Strval : String) return Node_Id;
-- A convenient form of Make_String_Literal, where the string value
-- is given as a normal string instead of a String_Id value.
function Make_Unsuppress_Block function Make_Unsuppress_Block
(Loc : Source_Ptr; (Loc : Source_Ptr;
Check : Name_Id; Check : Name_Id;