* 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.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@90904 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 157 insertions, 7 deletions

diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index 1ffbf5bc18c..cbaef5b5a15 100644
--- a/gcc/ada/exp_prag.adb
+++ b/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;