2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>

	* sem_aux.ads, sem_aux.adb (Has_Rep_Item): New variant.
	* sem_util.adb (Inherit_Rep_Item_Chain): Reimplemented.

2016-04-21  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch6.adb: Minor reformatting.

2016-04-21  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb: Minor comment update.

2016-04-21  Ed Schonberg  <schonberg@adacore.com>

	* freeze.ads, freeze.adb (Freeze_Entity, Freeze_Before): Add
	boolean parameter to determine whether freezing an overloadable
	entity freezes its profile as well. This is required by
	AI05-019. The call to Freeze_Profile within Freeze_Entity is
	conditioned by the value of this flag, whose default is True.
	* sem_attr.adb (Resolve_Attribute, case 'Access): The attribute
	reference freezes the prefix, but it the prefix is a subprogram
	it does not freeze its profile.



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

9 files changed, 223 insertions, 61 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c349a060dea..c44e72cd2f4 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,27 @@
+2016-04-21  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_aux.ads, sem_aux.adb (Has_Rep_Item): New variant.
+	* sem_util.adb (Inherit_Rep_Item_Chain): Reimplemented.
+
+2016-04-21  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch6.adb: Minor reformatting.
+
+2016-04-21  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch13.adb: Minor comment update.
+
+2016-04-21  Ed Schonberg  <schonberg@adacore.com>
+
+	* freeze.ads, freeze.adb (Freeze_Entity, Freeze_Before): Add
+	boolean parameter to determine whether freezing an overloadable
+	entity freezes its profile as well. This is required by
+	AI05-019. The call to Freeze_Profile within Freeze_Entity is
+	conditioned by the value of this flag, whose default is True.
+	* sem_attr.adb (Resolve_Attribute, case 'Access): The attribute
+	reference freezes the prefix, but it the prefix is a subprogram
+	it does not freeze its profile.
+
 2016-04-21  Javier Miranda  <miranda@adacore.com>
 
 	* exp_util.adb (Build_Procedure_Form): No action needed for
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index d084c379123..ff9530b931f 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -706,11 +706,10 @@ package body Exp_Ch6 is
                   Stmts   : List_Id;
 
                begin
-                  --  The extended return may just contain the declaration.
+                  --  The extended return may just contain the declaration
 
                   if Present (Handled_Statement_Sequence (Stmt)) then
-                     Stmts :=  Statements (Handled_Statement_Sequence (Stmt));
-
+                     Stmts := Statements (Handled_Statement_Sequence (Stmt));
                   else
                      Stmts := New_List;
                   end if;
@@ -2697,10 +2696,9 @@ package body Exp_Ch6 is
          --  See for example Expand_Boolean_Operator().
 
          if not (Comes_From_Source (Call_Node))
-           and then Nkind
-                      (Unit_Declaration_Node
-                        (Ultimate_Alias (Entity (Name (Call_Node)))))
-                      = N_Subprogram_Body
+           and then Nkind (Unit_Declaration_Node
+                            (Ultimate_Alias (Entity (Name (Call_Node))))) =
+                              N_Subprogram_Body
          then
             Set_Entity (Name (Call_Node),
               Rewritten_For_C_Func_Id
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 572b194e687..f5e114a0cab 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, 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- --
@@ -1908,8 +1908,16 @@ package body Freeze is
    -- Freeze_Before --
    -------------------
 
-   procedure Freeze_Before (N : Node_Id; T : Entity_Id) is
-      Freeze_Nodes : constant List_Id := Freeze_Entity (T, N);
+   procedure Freeze_Before
+     (N   : Node_Id;
+      T   : Entity_Id;
+      F_P : Boolean := True)
+   is
+   --  Freeze T, then insert the generated Freeze nodes before the node N.
+   --  The flag F_P is used when T is an overloadable entity, and indicates
+   --  whether its profile should be frozen at the same time.
+
+      Freeze_Nodes : constant List_Id := Freeze_Entity (T, N, F_P);
 
    begin
       if Ekind (T) = E_Function then
@@ -1925,7 +1933,11 @@ package body Freeze is
    -- Freeze_Entity --
    -------------------
 
-   function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is
+   function Freeze_Entity
+     (E : Entity_Id;
+      N : Node_Id;
+      F_P : Boolean := True) return List_Id
+   is
       Loc    : constant Source_Ptr := Sloc (N);
       Atype  : Entity_Id;
       Comp   : Entity_Id;
@@ -4990,12 +5002,13 @@ package body Freeze is
 
             --  In Ada 2012, freezing a subprogram does not always freeze
             --  the corresponding profile (see AI05-019). An attribute
-            --  reference is not a freezing point of the profile.
+            --  reference is not a freezing point of the profile. The boolean
+            --  Flag F_P indicates whether the profile should be frozen now.
             --  Other constructs that should not freeze ???
 
             --  This processing doesn't apply to internal entities (see below)
 
-            if not Is_Internal (E) then
+            if not Is_Internal (E) and then F_P then
                if not Freeze_Profile (E) then
                   Ghost_Mode := Save_Ghost_Mode;
                   return Result;
diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads
index f11347d5ed0..d95038152fc 100644
--- a/gcc/ada/freeze.ads
+++ b/gcc/ada/freeze.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, 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- --
@@ -187,13 +187,19 @@ package Freeze is
    --  If Initialization_Statements (E) is an N_Compound_Statement, insert its
    --  actions in the enclosing list and reset the attribute.
 
-   function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id;
+   function Freeze_Entity
+     (E : Entity_Id;
+      N : Node_Id;
+      F_P : Boolean := True) return List_Id;
    --  Freeze an entity, and return Freeze nodes, to be inserted at the point
    --  of call. N is a node whose source location corresponds to the freeze
    --  point. This is used in placing warning messages in the situation where
    --  it appears that a type has been frozen too early, e.g. when a primitive
    --  operation is declared after the freezing point of its tagged type.
    --  Returns No_List if no freeze nodes needed.
+   --  The defaulted parameter F_P is used when E is a subprogram, and
+   --  determines whether the profile of the subprogram should be frozen as
+   --  well.
 
    procedure Freeze_All (From : Entity_Id; After : in out Node_Id);
    --  Before a non-instance body, or at the end of a declarative part,
@@ -209,8 +215,13 @@ package Freeze is
    --  in the scope. It is used to prevent a quadratic traversal over already
    --  frozen entities.
 
-   procedure Freeze_Before (N : Node_Id; T : Entity_Id);
+   procedure Freeze_Before
+     (N   : Node_Id;
+      T   : Entity_Id;
+      F_P : Boolean := True);
    --  Freeze T then Insert the generated Freeze nodes before the node N
+   --  The flag F_P is used when T is an overloadable entity, and indicates
+   --  whether its profile should be frozen at the same time.
 
    procedure Freeze_Expression (N : Node_Id);
    --  Freezes the required entities when the Expression N causes freezing.
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index e8483b9eebd..099a1b84bc3 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, 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- --
@@ -10161,18 +10161,20 @@ package body Sem_Attr is
                   end loop;
 
                   --  If Prefix is a subprogram name, this reference freezes,
-                  --  but not if within spec expression mode
+                  --  but not if within spec expression mode. The profile of
+                  --  the subprogram is not frozen at this point.
 
                   if not In_Spec_Expression then
-                     Freeze_Before (N, Entity (P));
+                     Freeze_Before (N, Entity (P), False);
                   end if;
 
-               --  If it is a type, there is nothing to resolve. If it is an
-               --  object, complete its resolution.
+               --  If it is a type, there is nothing to resolve.
+               --  If it is a subprogram, do not freeze its profile.
+               --  If it is an object, complete its resolution.
 
                elsif Is_Overloadable (Entity (P)) then
                   if not In_Spec_Expression then
-                     Freeze_Before (N, Entity (P));
+                     Freeze_Before (N, Entity (P), False);
                   end if;
 
                --  Nothing to do if prefix is a type name
diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
index 79a3b9996a0..b9aa2df04a0 100644
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, 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- --
@@ -708,6 +708,29 @@ package body Sem_Aux is
       return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
    end Has_Rep_Item;
 
+   function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
+      Item : Node_Id;
+
+   begin
+      pragma Assert
+        (Nkind_In (N, N_Aspect_Specification,
+                      N_Attribute_Definition_Clause,
+                      N_Enumeration_Representation_Clause,
+                      N_Pragma,
+                      N_Record_Representation_Clause));
+
+      Item := First_Rep_Item (E);
+      while Present (Item) loop
+         if Item = N then
+            return True;
+         end if;
+
+         Item := Next_Rep_Item (Item);
+      end loop;
+
+      return False;
+   end Has_Rep_Item;
+
    --------------------
    -- Has_Rep_Pragma --
    --------------------
diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads
index ba60284daac..97a4f142d0f 100644
--- a/gcc/ada/sem_aux.ads
+++ b/gcc/ada/sem_aux.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, 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- --
@@ -246,6 +246,10 @@ package Sem_Aux is
    --  not inherited from its parents, if any). If found then True is returned,
    --  otherwise False indicates that no matching entry was found.
 
+   function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean;
+   --  Determine whether the Rep_Item chain of arbitrary entity E contains item
+   --  N. N must denote a valid rep item.
+
    function Has_Rep_Pragma
      (E             : Entity_Id;
       Nam           : Name_Id;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 352742aeae3..0fe36354644 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -3926,7 +3926,8 @@ package body Sem_Ch13 is
                return;
 
             --  A stream subprogram for an interface type must be a null
-            --  procedure (RM 13.13.2 (38/3)).
+            --  procedure (RM 13.13.2 (38/3)). Note that the class-wide type
+            --  of an interface is not an interface type (3.9.4 (6.b/2)).
 
             elsif Is_Interface (U_Ent)
               and then not Is_Class_Wide_Type (U_Ent)
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 0702cc71970..a10671144bf 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -10733,57 +10733,143 @@ package body Sem_Util is
    ----------------------------
 
    procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is
-      From_Item : constant Node_Id := First_Rep_Item (From_Typ);
-      Item      : Node_Id := Empty;
-      Last_Item : Node_Id := Empty;
+      Item      : Node_Id;
+      Next_Item : Node_Id;
 
    begin
-      --  Reach the end of the destination type's chain (if any) and capture
-      --  the last item.
+      --  There are several inheritance scenarios to consider depending on
+      --  whether both types have rep item chains and whether the destination
+      --  type already inherits part of the source type's rep item chain.
 
-      Item := First_Rep_Item (Typ);
-      while Present (Item) loop
+      --  1) The source type lacks a rep item chain
+      --     From_Typ ---> Empty
+      --
+      --     Typ --------> Item (or Empty)
 
-         --  Do not inherit a chain that has been inherited already
+      --  In this case inheritance cannot take place because there are no items
+      --  to inherit.
 
-         if Item = From_Item then
-            return;
-         end if;
+      --  2) The destination type lacks a rep item chain
+      --     From_Typ ---> Item ---> ...
+      --
+      --     Typ --------> Empty
 
-         Last_Item := Item;
-         Item := Next_Rep_Item (Item);
-      end loop;
+      --  Inheritance takes place by setting the First_Rep_Item of the
+      --  destination type to the First_Rep_Item of the source type.
+      --     From_Typ ---> Item ---> ...
+      --                    ^
+      --     Typ -----------+
 
-      Item := First_Rep_Item (From_Typ);
+      --  3.1) Both source and destination types have at least one rep item.
+      --  The destination type does NOT inherit a rep item from the source
+      --  type.
+      --     From_Typ ---> Item ---> Item
+      --
+      --     Typ --------> Item ---> Item
 
-      --  Additional check when both parent and current type have rep.
-      --  items, to prevent circularities when the derivation completes
-      --  a private declaration and inherits from both views of the parent.
-      --  There may be a remaining problem with the proper ordering of
-      --  attribute specifications and aspects on the chains of the four
-      --  entities involved. ???
+      --  Inheritance takes place by setting the Next_Rep_Item of the last item
+      --  of the destination type to the First_Rep_Item of the source type.
+      --     From_Typ -------------------> Item ---> Item
+      --                                    ^
+      --     Typ --------> Item ---> Item --+
 
-      if Present (Item) and then Present (From_Item) then
-         while Present (Item) loop
-            if Item = First_Rep_Item (Typ) then
-               return;
-            end if;
+      --  3.2) Both source and destination types have at least one rep item.
+      --  The destination type DOES inherit part of the rep item chain of the
+      --  source type.
+      --     From_Typ ---> Item ---> Item ---> Item
+      --                              ^
+      --     Typ --------> Item ------+
 
-            Item := Next_Rep_Item (Item);
-         end loop;
-      end if;
+      --  This rare case arises when the full view of a private extension must
+      --  inherit the rep item chain from the full view of its parent type and
+      --  the full view of the parent type contains extra rep items. Currently
+      --  only invariants may lead to such form of inheritance.
+
+      --     type From_Typ is tagged private
+      --       with Type_Invariant'Class => Item_2;
+
+      --     type Typ is new From_Typ with private
+      --       with Type_Invariant => Item_4;
+
+      --  At this point the rep item chains contain the following items
+
+      --     From_Typ -----------> Item_2 ---> Item_3
+      --                            ^
+      --     Typ --------> Item_4 --+
+
+      --  The full views of both types may introduce extra invariants
+
+      --     type From_Typ is tagged null record
+      --       with Type_Invariant => Item_1;
+
+      --     type Typ is new From_Typ with null record;
 
-      --  When the destination type has a rep item chain, the chain of the
-      --  source type is appended to it.
+      --  The full view of Typ would have to inherit any new rep items added to
+      --  the full view of From_Typ.
 
-      if Present (Last_Item) then
-         Set_Next_Rep_Item (Last_Item, From_Item);
+      --     From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
+      --                            ^
+      --     Typ --------> Item_4 --+
 
-      --  Otherwise the destination type directly inherits the rep item chain
-      --  of the source type (if any).
+      --  To achieve this form of inheritance, the destination type must first
+      --  sever the link between its own rep chain and that of the source type,
+      --  then inheritance 3.1 takes place.
+
+      --  Case 1: The source type lacks a rep item chain
+
+      if No (First_Rep_Item (From_Typ)) then
+         return;
+
+      --  Case 2: The destination type lacks a rep item chain
+
+      elsif No (First_Rep_Item (Typ)) then
+         Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
+
+      --  Case 3: Both the source and destination types have at least one rep
+      --  item. Traverse the rep item chain of the destination type to find the
+      --  last rep item.
 
       else
-         Set_First_Rep_Item (Typ, From_Item);
+         Item      := Empty;
+         Next_Item := First_Rep_Item (Typ);
+         while Present (Next_Item) loop
+
+            --  Detect a link between the destination type's rep chain and that
+            --  of the source type. There are two possibilities:
+
+            --    Variant 1
+            --                  Next_Item
+            --                      V
+            --       From_Typ ---> Item_1 --->
+            --                      ^
+            --       Typ -----------+
+            --
+            --       Item is Empty
+
+            --    Variant 2
+            --                              Next_Item
+            --                                  V
+            --       From_Typ ---> Item_1 ---> Item_2 --->
+            --                                  ^
+            --       Typ --------> Item_3 ------+
+            --                      ^
+            --                     Item
+
+            if Has_Rep_Item (From_Typ, Next_Item) then
+               exit;
+            end if;
+
+            Item      := Next_Item;
+            Next_Item := Next_Rep_Item (Next_Item);
+         end loop;
+
+         --  Inherit the source type's rep item chain
+
+         if Present (Item) then
+            Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ));
+         else
+            Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
+         end if;
       end if;
    end Inherit_Rep_Item_Chain;