Skip to content

R
riscv-gcc-1
Commit 1d571f3b by Arnaud Charlet
Options

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
parent 1735e55d
Showing with 343 additions and 144 deletions
gcc/ada/einfo.adb
......@@ -386,7 +386,6 @@ package body Einfo is
-- Vax_Float Flag151
-- Entry_Accepted Flag152
-- Is_Psected Flag153
-- Has_Per_Object_Constraint Flag154
-- Has_Private_Declaration Flag155
-- Referenced Flag156
......@@ -421,7 +420,7 @@ package body Einfo is
-- Has_Xref_Entry Flag182
-- Must_Be_On_Byte_Boundary Flag183
-- Note: there are no unused flags currently!
-- (unused) Flag153
--------------------------------
-- Attribute Access Functions --
......@@ -1587,11 +1586,6 @@ package body Einfo is
return Flag53 (Id);
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
begin
pragma Assert (Nkind (Id) in N_Entity);
......@@ -3547,11 +3541,6 @@ package body Einfo is
Set_Flag53 (Id, V);
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
begin
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
-- (the mechanism for describing non-specified stored discriminants)
----------------------------------------
-- Has_Completely_Hidden_Discriminant --
----------------------------------------
function Has_Completely_Hidden_Discriminant (Id : E) return Boolean is
Ent : Entity_Id := Id;
......@@ -4813,7 +4806,6 @@ package body Einfo is
pragma Assert (Ekind (Id) = E_Discriminant);
while Present (Ent) and then Ekind (Ent) = E_Discriminant loop
if Is_Completely_Hidden (Ent) then
return True;
end if;
......@@ -4921,9 +4913,8 @@ package body Einfo is
-------------------------------------
function Get_Attribute_Definition_Clause
(E : Entity_Id;
Id : Attribute_Id)
return Node_Id
(E : Entity_Id;
Id : Attribute_Id) return Node_Id
is
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
N : Node_Id;
Typ : Entity_Id;
N : Node_Id;
begin
N := First_Rep_Item (E);
while Present (N) loop
if Nkind (N) = N_Pragma and then Chars (N) = Nam then
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);
return N;
end if;
Next_Rep_Item (N);
end loop;
return Empty;
......@@ -5010,6 +4977,18 @@ package body Einfo is
return False;
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 --
-----------------
......@@ -5020,8 +4999,8 @@ package body Einfo is
begin
pragma Assert (Is_Concurrent_Type (Id));
Ent := First_Entity (Id);
Ent := First_Entity (Id);
while Present (Ent) loop
if Is_Entry (Ent) then
Result := True;
......@@ -5089,6 +5068,15 @@ package body Einfo is
end loop;
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 --
------------------------------
......@@ -5127,7 +5115,6 @@ package body Einfo is
begin
Item := First_Rep_Item (Id);
while Present (Item) loop
if Nkind (Item) = N_Pragma
and then Get_Pragma_Id (Chars (Item)) = Pragma_Inline_Always
......@@ -5206,9 +5193,10 @@ package body Einfo is
else
declare
C : Entity_Id := First_Component (Btype);
C : Entity_Id;
begin
C := First_Component (Btype);
while Present (C) loop
if Is_By_Reference_Type (Etype (C))
or else Is_Volatile (Etype (C))
......@@ -5376,9 +5364,10 @@ package body Einfo is
else
declare
C : E := First_Component (Btype);
C : E;
begin
C := First_Component (Btype);
while Present (C) loop
if Is_Limited_Type (Etype (C)) then
return True;
......@@ -5464,9 +5453,10 @@ package body Einfo is
else
declare
C : Entity_Id := First_Component (Btype);
C : Entity_Id;
begin
C := First_Component (Btype);
while Present (C) loop
if Is_Return_By_Reference_Type (Etype (C)) then
return True;
......@@ -5529,7 +5519,6 @@ package body Einfo is
begin
Comp_Id := Next_Entity (Id);
while Present (Comp_Id) loop
exit when Ekind (Comp_Id) = E_Component;
Comp_Id := Next_Entity (Comp_Id);
......@@ -5664,7 +5653,6 @@ package body Einfo is
else
N := 0;
T := First_Index (Id);
while Present (T) loop
N := N + 1;
T := Next (T);
......@@ -5685,7 +5673,6 @@ package body Einfo is
begin
N := 0;
Discr := First_Discriminant (Id);
while Present (Discr) loop
N := N + 1;
Discr := Next_Discriminant (Discr);
......@@ -5704,9 +5691,9 @@ package body Einfo is
begin
pragma Assert (Is_Concurrent_Type (Id));
N := 0;
Ent := First_Entity (Id);
while Present (Ent) loop
if Is_Entry (Ent) then
N := N + 1;
......@@ -5729,7 +5716,6 @@ package body Einfo is
begin
N := 0;
Formal := First_Formal (Id);
while Present (Formal) loop
N := N + 1;
Formal := Next_Formal (Formal);
......@@ -5747,6 +5733,16 @@ package body Einfo is
return Ekind (Id);
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 --
---------------
......@@ -5804,9 +5800,10 @@ package body Einfo is
-----------------
function Scope_Depth (Id : E) return Uint is
Scop : Entity_Id := Id;
Scop : Entity_Id;
begin
Scop := Id;
while Is_Record_Type (Scop) loop
Scop := Scope (Scop);
end loop;
......@@ -6246,7 +6243,6 @@ package body Einfo is
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Psected", Flag153 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
W ("Is_Remote_Call_Interface", Flag62 (Id));
......@@ -6372,14 +6368,13 @@ package body Einfo is
Index : E;
begin
Write_Attribute (" Component Type ",
Component_Type (Id));
Write_Attribute
(" Component Type ", Component_Type (Id));
Write_Eol;
Write_Str (Prefix);
Write_Str (" Indices ");
Index := First_Index (Id);
while Present (Index) loop
Write_Attribute (" ", Etype (Index));
Index := Next_Index (Index);
......
gcc/ada/einfo.ads
......@@ -2191,10 +2191,6 @@ package Einfo is
-- Is_Protected_Type (synthesized)
-- 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)
-- Present in all entities. Set to indicate that an entity defined in
-- one compilation unit can be referenced from other compilation units.
......@@ -4167,7 +4163,6 @@ package Einfo is
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
-- Is_Psected (Flag153)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
-- Never_Set_In_Source (Flag115)
......@@ -4746,7 +4741,6 @@ package Einfo is
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
-- Is_Psected (Flag153)
-- Is_Shared_Passive (Flag60)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
......@@ -5186,7 +5180,6 @@ package Einfo is
function Is_Preelaborated (Id : E) return B;
function Is_Private_Composite (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_Pure (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_Private_Composite (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_Pure (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)
renames Proc_Next_Stored_Discriminant;
-------------------------------
-- Miscellaneous Subprograms --
-------------------------------
----------------------------------------------
-- Subprograms for Accessing Rep Item Chain --
----------------------------------------------
procedure Append_Entity (Id : Entity_Id; V : Entity_Id);
-- Add an entity to the list of entities declared in the scope V
-- The First_Rep_Item field of every entity points to a linked list
-- (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;
-- 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
-- the value returned is the N_Pragma node, otherwise Empty is returned.
function Get_Attribute_Definition_Clause
(E : Entity_Id;
Id : Attribute_Id)
return Node_Id;
function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean;
-- Searches the Rep_Item chain for the given entity E, for an instance
-- of representation pragma with the given name Nam. If found then True
-- 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
-- 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.
-- found, True is returned, otherwise False indicates that no matching
-- 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;
-- 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_Type);
pragma Inline (Is_Protected_Type);
pragma Inline (Is_Psected);
pragma Inline (Is_Public);
pragma Inline (Is_Pure);
pragma Inline (Is_Real_Type);
......@@ -6499,7 +6520,6 @@ package Einfo is
pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Psected);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Remote_Call_Interface);
......
gcc/ada/exp_attr.adb
......@@ -138,6 +138,11 @@ package body Exp_Attr is
-- defining it, is returned. In both cases, inheritance of representation
-- 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;
-- Utility for array attributes, returns true on packed constrained
-- 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
-- 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,
Unchecked_Convert_To (Etype (N),
Unchecked_Convert_To (Base_Type (Etype (N)),
Make_Function_Call (Loc,
Name => Fnm,
Parameter_Associations => Args)));
......@@ -909,12 +916,9 @@ package body Exp_Attr is
if Pent = Standard_Standard
or else Pent = Standard_ASCII
then
Name_Buffer (1 .. Verbose_Library_Version'Length) :=
Verbose_Library_Version;
Name_Len := Verbose_Library_Version'Length;
Rewrite (N,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
Strval => Verbose_Library_Version));
-- All other cases
......@@ -1804,9 +1808,7 @@ package body Exp_Attr is
-- from which it is derived. The extra conversion is required
-- for the derived case.
Prag :=
Get_Rep_Pragma
(Implementation_Base_Type (P_Type), Name_Stream_Convert);
Prag := Get_Stream_Convert_Pragma (P_Type);
if Present (Prag) then
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
-- required for the derived case.
Prag :=
Get_Rep_Pragma
(Implementation_Base_Type (P_Type), Name_Stream_Convert);
Prag := Get_Stream_Convert_Pragma (P_Type);
if Present (Prag) then
Arg3 :=
......@@ -2795,9 +2795,7 @@ package body Exp_Attr is
-- where Itemx is the expression of the type conversion (i.e.
-- the actual object), and typex is the type of Itemx.
Prag :=
Get_Rep_Pragma
(Implementation_Base_Type (P_Type), Name_Stream_Convert);
Prag := Get_Stream_Convert_Pragma (P_Type);
if Present (Prag) then
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
-- required for the derived case.
Prag :=
Get_Rep_Pragma
(Implementation_Base_Type (P_Type), Name_Stream_Convert);
Prag := Get_Stream_Convert_Pragma (P_Type);
if Present (Prag) then
Arg3 :=
......@@ -4326,6 +4322,46 @@ package body Exp_Attr is
return Etype (Indx);
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 --
---------------------------------
......
gcc/ada/exp_ch3.adb
......@@ -57,7 +57,6 @@ with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Stringt; use Stringt;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
......@@ -1118,15 +1117,10 @@ package body Exp_Ch3 is
-- This is just a workaround that must be improved later???
if With_Default_Init then
declare
S : String_Id;
Null_String : Node_Id;
begin
Start_String;
S := End_String;
Null_String := Make_String_Literal (Loc, Strval => S);
Append_To (Args, Null_String);
end;
Append_To (Args,
Make_String_Literal (Loc,
Strval => ""));
else
Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
Decl := Last (Decls);
......
gcc/ada/exp_intr.adb
......@@ -110,21 +110,18 @@ package body Exp_Intr is
Loc : constant Source_Ptr := Sloc (N);
P : Node_Id;
E : Entity_Id;
S : String_Id;
begin
-- Climb up parents to see if we are in exception handler
P := Parent (N);
loop
-- Case of not in exception handler
-- Case of not in exception handler, replace by null string
if No (P) then
Start_String;
S := End_String;
Rewrite (N,
Make_String_Literal (Loc,
Strval => S));
Strval => ""));
exit;
-- Case of in exception handler
......
gcc/ada/exp_prag.adb
......@@ -58,22 +58,31 @@ package body Exp_Prag is
function Arg1 (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_Assert (N : Node_Id);
procedure Expand_Pragma_Common_Object (N : Node_Id);
procedure Expand_Pragma_Import (N : Node_Id);
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
procedure Expand_Pragma_Inspection_Point (N : Node_Id);
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
procedure Expand_Pragma_Psect_Object (N : Node_Id);
----------
-- Arg1 --
----------
function Arg1 (N : Node_Id) return Node_Id is
Arg : constant Node_Id := First (Pragma_Argument_Associations (N));
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;
----------
......@@ -81,8 +90,23 @@ package body Exp_Prag is
----------
function Arg2 (N : Node_Id) return Node_Id is
Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
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;
---------------------
......@@ -105,6 +129,9 @@ package body Exp_Prag is
when Pragma_Assert =>
Expand_Pragma_Assert (N);
when Pragma_Common_Object =>
Expand_Pragma_Common_Object (N);
when Pragma_Export_Exception =>
Expand_Pragma_Import_Export_Exception (N);
......@@ -120,6 +147,9 @@ package body Exp_Prag is
when Pragma_Interrupt_Priority =>
Expand_Pragma_Interrupt_Priority (N);
when Pragma_Psect_Object =>
Expand_Pragma_Psect_Object (N);
-- All other pragmas need no expander action
when others => null;
......@@ -195,7 +225,7 @@ package body Exp_Prag is
procedure Expand_Pragma_Assert (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Cond : constant Node_Id := Expression (Arg1 (N));
Cond : constant Node_Id := Arg1 (N);
Msg : String_Id;
begin
......@@ -222,7 +252,7 @@ package body Exp_Prag is
-- First, we need to prepare the character literal
if Present (Arg2 (N)) then
Msg := Strval (Expr_Value_S (Expression (Arg2 (N))));
Msg := Strval (Expr_Value_S (Arg2 (N)));
else
Build_Location_String (Loc);
Msg := String_From_Name_Buffer;
......@@ -265,6 +295,114 @@ package body Exp_Prag is
end if;
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 --
--------------------------
......@@ -281,7 +419,7 @@ package body Exp_Prag is
-- seen (i.e. this elaboration cannot be deferred to the freeze point).
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;
Init_Call : Node_Id;
......@@ -340,7 +478,7 @@ package body Exp_Prag is
end if;
declare
Id : constant Entity_Id := Entity (Expression (Arg1 (N)));
Id : constant Entity_Id := Entity (Arg1 (N));
Call : constant Node_Id := Register_Exception_Call (Id);
Loc : constant Source_Ptr := Sloc (N);
......@@ -579,4 +717,16 @@ package body Exp_Prag is
end if;
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;
gcc/ada/freeze.adb
......@@ -2235,17 +2235,17 @@ package body Freeze is
-- inherited the indication from elsewhere (e.g. an address
-- 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
Present (Get_Rep_Pragma (E, Name_Atomic_Components))
Has_Rep_Pragma (E, Name_Atomic_Components)
then
Error_Msg_N
("stand alone atomic constant must be " &
"imported ('R'M 'C.6(13))", E);
elsif Present (Get_Rep_Pragma (E, Name_Volatile))
elsif Has_Rep_Pragma (E, Name_Volatile)
or else
Present (Get_Rep_Pragma (E, Name_Volatile_Components))
Has_Rep_Pragma (E, Name_Volatile_Components)
then
Error_Msg_N
("stand alone volatile constant must be " &
......
gcc/ada/sem_attr.adb
......@@ -1232,7 +1232,7 @@ package body Sem_Attr is
if Is_Limited_Type (P_Type)
and then Comes_From_Source (N)
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
Error_Msg_Name_1 := Aname;
Error_Msg_NE
......@@ -3480,22 +3480,21 @@ package body Sem_Attr is
when Attribute_Target_Name => Target_Name : declare
TN : constant String := Sdefault.Target_Name.all;
TL : Integer := TN'Last;
TL : Natural;
begin
Check_Standard_Prefix;
Check_E0;
Start_String;
TL := TN'Last;
if TN (TL) = '/' or else TN (TL) = '\' then
TL := TL - 1;
end if;
Store_String_Chars (TN (TN'First .. TL));
Rewrite (N,
Make_String_Literal (Loc,
Strval => End_String));
Strval => TN (TN'First .. TL)));
Analyze_And_Resolve (N, Standard_String);
end Target_Name;
......
gcc/ada/sem_ch13.adb
......@@ -3411,16 +3411,6 @@ package body Sem_Ch13 is
end if;
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 --
------------------------
......
gcc/ada/sem_ch13.ads
......@@ -90,11 +90,6 @@ package Sem_Ch13 is
-- 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.
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;
-- Called at the start of processing a representation clause or a
-- representation pragma. Used to check that the representation item
......
gcc/ada/tbuild.adb
......@@ -35,6 +35,7 @@ with Rident; use Rident;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Uintp; use Uintp;
package body Tbuild is
......@@ -334,6 +335,22 @@ package body Tbuild is
UI_From_Int (RT_Exception_Code'Pos (Reason)));
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 --
---------------------------
......
gcc/ada/tbuild.ads
......@@ -156,6 +156,12 @@ package Tbuild is
-- A convenient form of Make_Raise_Storage_Error where the Reason
-- 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
(Loc : Source_Ptr;
Check : Name_Id;
......
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