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

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;