[multiple changes]

2015-05-26  Gary Dismukes  <dismukes@adacore.com>

	* einfo.ads, sem_util.adb, sem_ch4.adb: Minor reformatting.

2015-05-26  Robert Dewar  <dewar@adacore.com>

	* exp_unst.adb, exp_unst.ads: Change to using Subps table index for
	making AREC entity names unique.

2015-05-26  Ed Schonberg  <schonberg@adacore.com>

	* sem_cat.adb (Has_Stream_Attribute_Definition): If the type
	has aspect specifications, examine the corresponding list of
	representation items to determine whether there is a visible
	stream operation. The attribute definition clause generated from
	the aspect will be inserted at the freeze point of the type,
	which may be in the private part and not directly visible,
	but the aspect makes the operation available to a client.

From-SVN: r223663

7 files changed, 156 insertions, 114 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 92decca..ccdf46b 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,22 @@
+2015-05-26  Gary Dismukes  <dismukes@adacore.com>
+
+	* einfo.ads, sem_util.adb, sem_ch4.adb: Minor reformatting.
+
+2015-05-26  Robert Dewar  <dewar@adacore.com>
+
+	* exp_unst.adb, exp_unst.ads: Change to using Subps table index for
+	making AREC entity names unique.
+
+2015-05-26  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_cat.adb (Has_Stream_Attribute_Definition): If the type
+	has aspect specifications, examine the corresponding list of
+	representation items to determine whether there is a visible
+	stream operation. The attribute definition clause generated from
+	the aspect will be inserted at the freeze point of the type,
+	which may be in the private part and not directly visible,
+	but the aspect makes the operation available to a client.
+
 2015-05-26  Robert Dewar  <dewar@adacore.com>
 
 	* sem_util.adb: Minor code reorganization.
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 8676713..5a309f9 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1756,7 +1756,7 @@ package Einfo is
 --       Object_Size clauses for a given entity.
 
 --    Has_Out_Or_In_Out_Parameter (Flag110)
---       Present in subprograms, generic subprograms, entries and entry
+--       Present in subprograms, generic subprograms, entries, and entry
 --       families. Set if they have at least one OUT or IN OUT parameter
 --       (allowed for functions only in Ada 2012).
 
diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index 872a35f..c2a7243 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -124,8 +124,8 @@ package body Exp_Unst is
    -----------------------
 
    procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
-      function AREC_String (Lev : Pos) return String;
-      --  Given a level value, 1, 2, ... returns the string AREC, AREC2, ...
+      function AREC_Name (J : Pos; S : String) return Name_Id;
+      --  Returns name for string ARECjS, where j is the decimal value of j
 
       function Enclosing_Subp (Subp : SI_Type) return SI_Type;
       --  Subp is the index of a subprogram which has a Lev greater than 1.
@@ -137,34 +137,32 @@ package body Exp_Unst is
       --  function returns the level of nesting (Subp = 1, subprograms that
       --  are immediately nested within Subp = 2, etc).
 
+      function Img_Pos (N : Pos) return String;
+      --  Return image of N without leading blank
+
       function Subp_Index (Sub : Entity_Id) return SI_Type;
       --  Given the entity for a subprogram, return corresponding Subps index
 
-      function Suffixed_Name (Ent : Entity_Id) return Name_Id;
-      --  Given an entity Ent, return its name (Char (Ent)) suffixed with
-      --  two underscores and the entity number, to ensure a unique name.
-
-      function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id;
+      function Upref_Name
+        (Ent   : Entity_Id;
+         Index : Pos;
+         Clist : List_Id) return Name_Id;
       --  This function returns the name to be used in the activation record to
       --  reference the variable uplevel. Clist is the list of components that
-      --  have been created in the activation record so far. Normally this is
-      --  just a copy of the Chars field of the entity. The exception is when
-      --  the name has already been used, in which case we suffix the name with
-      --  the entity number to avoid duplication. This happens with declare
-      --  blocks and generic parameters at least.
+      --  have been created in the activation record so far. Normally the name
+      --  is just a copy of the Chars field of the entity. The exception is
+      --  when the name has already been used, in which case we suffix the name
+      --  with the index value Index to avoid duplication. This happens with
+      --  declare blocks and generic parameters at least.
 
-      -----------------
-      -- AREC_String --
-      -----------------
+      ---------------
+      -- AREC_Name --
+      ---------------
 
-      function AREC_String (Lev : Pos) return String is
+      function AREC_Name (J : Pos; S : String) return Name_Id is
       begin
-         if Lev > 9 then
-            return AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48);
-         else
-            return "AREC" & Character'Val (Lev + 48);
-         end if;
-      end AREC_String;
+         return Name_Find_Str ("AREC" & Img_Pos (J) & S);
+      end AREC_Name;
 
       --------------------
       -- Enclosing_Subp --
@@ -199,6 +197,27 @@ package body Exp_Unst is
          end loop;
       end Get_Level;
 
+      -------------
+      -- Img_Pos --
+      -------------
+
+      function Img_Pos (N : Pos) return String is
+         Buf : String (1 .. 20);
+         Ptr : Natural;
+         NV  : Nat;
+
+      begin
+         Ptr := Buf'Last;
+         NV := N;
+         while NV /= 0 loop
+            Buf (Ptr) := Character'Val (48 + NV mod 10);
+            Ptr := Ptr - 1;
+            NV := NV / 10;
+         end loop;
+
+         return Buf (Ptr + 1 .. Buf'Last);
+      end Img_Pos;
+
       ----------------
       -- Subp_Index --
       ----------------
@@ -209,23 +228,15 @@ package body Exp_Unst is
          return SI_Type (UI_To_Int (Subps_Index (Sub)));
       end Subp_Index;
 
-      -------------------
-      -- Suffixed_Name --
-      -------------------
-
-      function Suffixed_Name (Ent : Entity_Id) return Name_Id is
-      begin
-         Get_Name_String (Chars (Ent));
-         Add_Str_To_Name_Buffer ("__");
-         Add_Nat_To_Name_Buffer (Nat (Ent));
-         return Name_Enter;
-      end Suffixed_Name;
-
       ----------------
       -- Upref_Name --
       ----------------
 
-      function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id is
+      function Upref_Name
+        (Ent   : Entity_Id;
+         Index : Pos;
+         Clist : List_Id) return Name_Id
+      is
          C : Node_Id;
       begin
          C := First (Clist);
@@ -233,7 +244,8 @@ package body Exp_Unst is
             if No (C) then
                return Chars (Ent);
             elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
-               return Suffixed_Name (Ent);
+               return Name_Find_Str
+                        (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
             else
                Next (C);
             end if;
@@ -946,7 +958,6 @@ package body Exp_Unst is
          declare
             STJ : Subp_Entry renames Subps.Table (J);
             Loc : constant Source_Ptr := Sloc (STJ.Bod);
-            ARS : constant String     := AREC_String (STJ.Lev);
 
          begin
             --  First we create the ARECnF entity for the additional formal for
@@ -954,32 +965,26 @@ package body Exp_Unst is
 
             if STJ.Uplevel_Ref < STJ.Lev then
                STJ.ARECnF :=
-                 Make_Defining_Identifier (Loc,
-                   Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F"));
+                 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F"));
             end if;
 
             --  Define the AREC entities for the activation record if needed
 
             if STJ.Declares_AREC then
                STJ.ARECn   :=
-                 Make_Defining_Identifier (Loc, Name_Find_Str (ARS));
+                 Make_Defining_Identifier (Loc, AREC_Name (J, ""));
                STJ.ARECnT  :=
-                 Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "T"));
+                 Make_Defining_Identifier (Loc, AREC_Name (J, "T"));
                STJ.ARECnPT :=
-                 Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "PT"));
+                 Make_Defining_Identifier (Loc, AREC_Name (J, "PT"));
                STJ.ARECnP  :=
-                 Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "P"));
+                 Make_Defining_Identifier (Loc, AREC_Name (J, "P"));
 
                --  Define uplink component entity if inner nesting case
 
                if Present (STJ.ARECnF) then
-                  declare
-                     ARS1 : constant String := AREC_String (STJ.Lev - 1);
-                  begin
-                     STJ.ARECnU :=
-                       Make_Defining_Identifier (Loc,
-                         Chars => Name_Find_Str (ARS1 & "U"));
-                  end;
+                  STJ.ARECnU :=
+                    Make_Defining_Identifier (Loc, AREC_Name (J, "U"));
                end if;
             end if;
          end;
@@ -1103,22 +1108,15 @@ package body Exp_Unst is
                      --  List of new declarations we create
 
                   begin
-                     --  Suffix the ARECnT and ARECnPT names to make sure that
-                     --  they are unique when Cprint moves the declarations to
-                     --  the outer level.
-
-                     Set_Chars (STJ.ARECnT,  Suffixed_Name (STJ.ARECnT));
-                     Set_Chars (STJ.ARECnPT, Suffixed_Name (STJ.ARECnPT));
-
                      --  Build list of component declarations for ARECnT
 
                      Clist := Empty_List;
 
                      --  If we are in a subprogram that has a static link that
                      --  is passed in (as indicated by ARECnF being defined),
-                     --  then include ARECnU : ARECmPT where m is one less than
-                     --  the current level and the entity ARECnPT comes from
-                     --  the enclosing subprogram.
+                     --  then include ARECnU : ARECmPT where ARECmPT comes from
+                     --  the level one higher than the current level, and the
+                     --  entity ARECnPT comes from the enclosing subprogram.
 
                      if Present (STJ.ARECnF) then
                         declare
@@ -1142,14 +1140,20 @@ package body Exp_Unst is
                            Elmt : Elmt_Id;
                            Uent : Entity_Id;
 
+                           Indx : Nat;
+                           --  1's origin of index in list of elements. This is
+                           --  used to uniquify names if needed in Upref_Name.
+
                         begin
                            Elmt := First_Elmt (STJ.Uents);
+                           Indx := 0;
                            while Present (Elmt) loop
                               Uent := Node (Elmt);
+                              Indx := Indx + 1;
 
                               Comp :=
                                 Make_Defining_Identifier (Loc,
-                                  Chars => Upref_Name (Uent, Clist));
+                                  Chars => Upref_Name (Uent, Indx, Clist));
 
                               Set_Activation_Record_Component
                                 (Uent, Comp);
diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads
index 7b92dcd..084e904 100644
--- a/gcc/ada/exp_unst.ads
+++ b/gcc/ada/exp_unst.ads
@@ -184,9 +184,9 @@ package Exp_Unst is
    --   The fields of AREC1 are set at the point the corresponding entity
    --   is declared (immediately for parameters).
 
-   --   Note: the 1 in all these names represents the fact that we are at the
-   --   outer level of nesting. As we will see later, deeper levels of nesting
-   --   will use AREC2, AREC3, ...
+   --   Note: the 1 in all these names is a unique index number. Different
+   --   scopes requiring different ARECnT declarations will have different
+   --   values of n to ensure uniqueness.
 
    --   Note: normally the field names in the activation record match the
    --   name of the entity. An exception is when the entity is declared in
@@ -294,8 +294,8 @@ package Exp_Unst is
 
    --    What we do is to always generate a local constant for any dynamic
    --    bound in a dynamic subtype xx with name xx_FIRST or xx_LAST. The one
-   --    case where we can skip this is where the bound is For
-   --    example in the third example above, subtype dynam is expanded as
+   --    case where we can skip this is where the bound is e.g. in the third
+   --    example above, subtype dynam is expanded as
 
    --      dynam_LAST  : constant Integer := y + 3;
    --      subtype dynam is integer range x .. dynam_LAST;
@@ -465,8 +465,8 @@ package Exp_Unst is
    --        return inner1 (x, AREC1P);
    --     end case4x;
 
-   --  As can be seen in this example, the level number following AREC in the
-   --  names avoids any confusion between AREC names at different levels.
+   --  As can be seen in this example, the index numbers following AREC in the
+   --  generated names avoid confusion between AREC names at different levels.
 
    -------------------------
    -- Name Disambiguation --
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index 83fe625..15fa6ad 100644
--- a/gcc/ada/sem_cat.adb
+++ b/gcc/ada/sem_cat.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -441,20 +441,15 @@ package body Sem_Cat is
       At_Any_Place : Boolean := False) return Boolean
    is
       Rep_Item  : Node_Id;
-      Full_Type : Entity_Id := Typ;
+      Real_Rep  : Node_Id;
+      --  The stream operation may be specified by an attribute definition
+      --  clause in the source, or by an aspect that generates such an
+      --  attribute definition. For an aspect, the generated attribute
+      --  definition may be placed at the freeze point of the full view of
+      --  the type, but the aspect specification makes the operation visible
+      --  to a client wherever the partial view is visible.
 
    begin
-      --  In the case of a type derived from a private view, any specified
-      --  stream attributes will be attached to the derived type's underlying
-      --  type rather the derived type entity itself (which is itself private).
-
-      if Is_Private_Type (Typ)
-        and then Is_Derived_Type (Typ)
-        and then Present (Full_View (Typ))
-      then
-         Full_Type := Underlying_Type (Typ);
-      end if;
-
       --  We start from the declaration node and then loop until the end of
       --  the list until we find the requested attribute definition clause.
       --  In Ada 2005 mode, clauses are ignored if they are not currently
@@ -462,10 +457,19 @@ package body Sem_Cat is
       --  inserted by the expander at the point where the clause occurs),
       --  unless At_Any_Place is true.
 
-      Rep_Item := First_Rep_Item (Full_Type);
+      Rep_Item := First_Rep_Item (Typ);
       while Present (Rep_Item) loop
-         if Nkind (Rep_Item) = N_Attribute_Definition_Clause then
-            case Chars (Rep_Item) is
+         Real_Rep := Rep_Item;
+
+         --  If the representation item is an aspect specification, retrieve
+         --  the corresponding pragma or attribute definition.
+
+         if Nkind (Rep_Item) = N_Aspect_Specification then
+            Real_Rep := Aspect_Rep_Item (Rep_Item);
+         end if;
+
+         if Nkind (Real_Rep) = N_Attribute_Definition_Clause then
+            case Chars (Real_Rep) is
                when Name_Read =>
                   exit when Nam = TSS_Stream_Read;
 
@@ -487,14 +491,29 @@ package body Sem_Cat is
          Next_Rep_Item (Rep_Item);
       end loop;
 
-      --  If At_Any_Place is true, return True if the attribute is available
-      --  at any place; if it is false, return True only if the attribute is
-      --  currently visible.
+      --  If not found, and the type is derived from a private view, check
+      --  for a stream attribute inherited from parent. Any specified stream
+      --  attributes will be attached to the derived type's underlying type
+      --  rather the derived type entity itself (which is itself private).
+
+      if No (Rep_Item)
+        and then Is_Private_Type (Typ)
+        and then Is_Derived_Type (Typ)
+        and then Present (Full_View (Typ))
+      then
+         return Has_Stream_Attribute_Definition
+            (Underlying_Type (Typ), Nam, At_Any_Place);
+
+      --  Otherwise, if At_Any_Place is true, return True if the attribute is
+      --  available at any place; if it is false, return True only if the
+      --  attribute is currently visible.
 
-      return Present (Rep_Item)
-        and then (Ada_Version < Ada_2005
-                   or else At_Any_Place
-                   or else not Is_Hidden (Entity (Rep_Item)));
+      else
+         return Present (Rep_Item)
+           and then (Ada_Version < Ada_2005
+                      or else At_Any_Place
+                      or else not Is_Hidden (Entity (Rep_Item)));
+      end if;
    end Has_Stream_Attribute_Definition;
 
    ----------------------------
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index e87af41..03fec8b 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -916,30 +916,30 @@ package body Sem_Ch4 is
       ----------------------------
 
       --  The identification of conflicts in calls to functions with writable
-      --  actuals is performed in the analysis phase of the frontend to ensure
+      --  actuals is performed in the analysis phase of the front end to ensure
       --  that it reports exactly the same errors compiling with and without
       --  expansion enabled. It is performed in two stages:
 
-      --    1) When a call to a function with out-mode parameters is found
-      --       we climb to the outermost enclosing construct which can be
+      --    1) When a call to a function with out-mode parameters is found,
+      --       we climb to the outermost enclosing construct that can be
       --       evaluated in arbitrary order and we mark it with the flag
       --       Check_Actuals.
 
-      --    2) When the analysis of the marked node is complete then we
-      --       traverse its decorated subtree searching for conflicts
-      --       (see function Sem_Util.Check_Function_Writable_Actuals).
+      --    2) When the analysis of the marked node is complete, we traverse
+      --       its decorated subtree searching for conflicts (see function
+      --       Sem_Util.Check_Function_Writable_Actuals).
 
-      --  The unique exception to this general rule are aggregates, since
-      --  their analysis is performed by the frontend in the resolution
-      --  phase. For aggregates we do not climb to its enclosing construct:
+      --  The unique exception to this general rule is for aggregates, since
+      --  their analysis is performed by the front end in the resolution
+      --  phase. For aggregates we do not climb to their enclosing construct:
       --  we restrict the analysis to the subexpressions initializing the
       --  aggregate components.
 
       --  This implies that the analysis of expressions containing aggregates
-      --  is not complete since there may be conflicts on writable actuals
+      --  is not complete, since there may be conflicts on writable actuals
       --  involving subexpressions of the enclosing logical or arithmetic
       --  expressions. However, we cannot wait and perform the analysis when
-      --  the whole subtree is resolved since the subtrees may be transformed
+      --  the whole subtree is resolved, since the subtrees may be transformed,
       --  thus adding extra complexity and computation cost to identify and
       --  report exactly the same errors compiling with and without expansion
       --  enabled.
@@ -948,9 +948,9 @@ package body Sem_Ch4 is
 
          function Is_Arbitrary_Evaluation_Order_Construct
            (N : Node_Id) return Boolean;
-         --  Return True if N is an Ada construct which may evaluate in
-         --  arbitrary order. This function does not cover all the language
-         --  constructs which can be evaluated in arbitrary order but the
+         --  Return True if N is an Ada construct which may be evaluated in
+         --  an arbitrary order. This function does not cover all the language
+         --  constructs that can be evaluated in arbitrary order, but only the
          --  subset needed for AI05-0144.
 
          ---------------------------------------------
@@ -1003,11 +1003,11 @@ package body Sem_Ch4 is
                begin
                   while Present (P) loop
 
-                     --  For object declarations we can climb to such node from
+                     --  For object declarations we can climb to the node from
                      --  its object definition branch or from its initializing
                      --  expression. We prefer to mark the child node as the
                      --  outermost construct to avoid adding further complexity
-                     --  to the routine which will take care later of
+                     --  to the routine that will later take care of
                      --  performing the writable actuals check.
 
                      if Is_Arbitrary_Evaluation_Order_Construct (P)
@@ -1407,8 +1407,8 @@ package body Sem_Ch4 is
 
          Check_Writable_Actuals (N);
 
-         --  If found and the outermost construct which can be evaluated in
-         --  arbitrary order is precisely this call then check all its
+         --  If found and the outermost construct that can be evaluated in
+         --  an arbitrary order is precisely this call, then check all its
          --  actuals.
 
          if Check_Actuals (N) then
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index b823d80..57ec05c 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2119,10 +2119,10 @@ package body Sem_Util is
                then
                   return Skip;
 
-               --  For now we skip aggregate discriminants since they require
+               --  For now we skip aggregate discriminants, since they require
                --  performing the analysis in two phases to identify conflicts:
                --  first one analyzing discriminants and second one analyzing
-               --  the rest of components (since at runtime discriminants are
+               --  the rest of components (since at run time, discriminants are
                --  evaluated prior to components): too much computation cost
                --  to identify a corner case???
 
@@ -2191,8 +2191,8 @@ package body Sem_Util is
 
                      --  Report the error on the second occurrence of the
                      --  identifier. We cannot assume that N is the second
-                     --  occurrence since traverse_func walks through Field2
-                     --  last (see comment in the body of traverse_func).
+                     --  occurrence, since Traverse_Func walks through Field2
+                     --  last (see comment in the body of Traverse_Func).
 
                      declare
                         Elmt : Elmt_Id;