[multiple changes]

2015-03-02  Robert Dewar  <dewar@adacore.com>

	* atree.ads, atree.adb (Uint24): New function
	(Set_Uint24): New procedure.
	* atree.h (Uint24): New macro for field access.
	* back_end.adb (Call_Back_End): For now, don't call back end
	if unnesting subprogs.
	* einfo.adb (Activation_Record_Component): New field
	(Subps_Index): New field.
	* einfo.ads (Activation_Record_Component): New field
	(Subps_Index): New field Minor reordering of comments into alpha order.
	* exp_unst.ads, exp_unst.adb: Continued development.

2015-03-02  Gary Dismukes  <dismukes@adacore.com>

	* exp_disp.ads: Minor reformatting.

2015-03-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Chain_Use_Clause): Do not chain use clause from
	ancestor to list of use clauses active in descendant unit if we
	are within the private part of an intervening parent, to prevent
	circularities in use clause list.

From-SVN: r221114

gcc/ada/ChangeLog

+2015-03-02  Robert Dewar  <dewar@adacore.com>
+
+	* atree.ads, atree.adb (Uint24): New function
+	(Set_Uint24): New procedure.
+	* atree.h (Uint24): New macro for field access.
+	* back_end.adb (Call_Back_End): For now, don't call back end
+	if unnesting subprogs.
+	* einfo.adb (Activation_Record_Component): New field
+	(Subps_Index): New field.
+	* einfo.ads (Activation_Record_Component): New field
+	(Subps_Index): New field Minor reordering of comments into alpha order.
+	* exp_unst.ads, exp_unst.adb: Continued development.
+
+2015-03-02  Gary Dismukes  <dismukes@adacore.com>
+
+	* exp_disp.ads: Minor reformatting.
+
+2015-03-02  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch8.adb (Chain_Use_Clause): Do not chain use clause from
+	ancestor to list of use clauses active in descendant unit if we
+	are within the private part of an intervening parent, to prevent
+	circularities in use clause list.
+
 2015-03-02  Javier Miranda  <miranda@adacore.com>
 
 	* exp_ch9.adb (Build_Corresponding_Record): Propagate type

gcc/ada/atree.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- --
@@ -3181,6 +3181,17 @@ package body Atree is
          end if;
       end Uint22;
 
+      function Uint24 (N : Node_Id) return Uint is
+         pragma Assert (Nkind (N) in N_Entity);
+         U : constant Union_Id := Nodes.Table (N + 4).Field6;
+      begin
+         if U = 0 then
+            return Uint_0;
+         else
+            return From_Union (U);
+         end if;
+      end Uint24;
+
       function Ureal3 (N : Node_Id) return Ureal is
       begin
          pragma Assert (N <= Nodes.Last);
@@ -5786,6 +5797,12 @@ package body Atree is
          Nodes.Table (N + 3).Field9 := To_Union (Val);
       end Set_Uint22;
 
+      procedure Set_Uint24 (N : Node_Id; Val : Uint) is
+      begin
+         pragma Assert (Nkind (N) in N_Entity);
+         Nodes.Table (N + 4).Field6 := To_Union (Val);
+      end Set_Uint24;
+
       procedure Set_Ureal3 (N : Node_Id; Val : Ureal) is
       begin
          pragma Assert (N <= Nodes.Last);

gcc/ada/atree.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          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- --
@@ -1424,6 +1424,9 @@ package Atree is
       function Uint22 (N : Node_Id) return Uint;
       pragma Inline (Uint22);
 
+      function Uint24 (N : Node_Id) return Uint;
+      pragma Inline (Uint24);
+
       function Ureal3 (N : Node_Id) return Ureal;
       pragma Inline (Ureal3);
 
@@ -2731,6 +2734,9 @@ package Atree is
       procedure Set_Uint22 (N : Node_Id; Val : Uint);
       pragma Inline (Set_Uint22);
 
+      procedure Set_Uint24 (N : Node_Id; Val : Uint);
+      pragma Inline (Set_Uint24);
+
       procedure Set_Ureal3 (N : Node_Id; Val : Ureal);
       pragma Inline (Set_Ureal3);
 

gcc/ada/atree.h

@@ -6,7 +6,7 @@
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *          Copyright (C) 1992-2013, 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- *
@@ -535,6 +535,7 @@ extern Node_Id Current_Error_Node;
 #define Uint16(N)     ((Field16 (N) == 0) ? Uint_0 : Field16 (N))
 #define Uint17(N)     ((Field17 (N) == 0) ? Uint_0 : Field17 (N))
 #define Uint22(N)     ((Field22 (N) == 0) ? Uint_0 : Field22 (N))
+#define Uint24(N)     ((Field24 (N) == 0) ? Uint_0 : Field24 (N))
 
 #define Ureal3(N)     Field3  (N)
 #define Ureal18(N)    Field18 (N)

gcc/ada/back_end.adb

@@ -118,6 +118,12 @@ package body Back_End is
          return;
       end if;
 
+      --  Skip call if unnesting subprograms (temp for now ???)
+
+      if Opt.Unnest_Subprogram_Mode then
+         return;
+      end if;
+
       --  The back end needs to know the maximum line number that can appear
       --  in a Sloc, in other words the maximum logical line number.
 

gcc/ada/einfo.adb

@@ -214,6 +214,7 @@ package body Einfo is
 
    --    Related_Expression              Node24
    --    Uplevel_References              Elist24
+   --    Subps_Index                     Uint24
 
    --    Interface_Alias                 Node25
    --    Interfaces                      Elist25
@@ -251,6 +252,7 @@ package body Einfo is
 
    --    Derived_Type_Link               Node31
    --    Thunk_Entity                    Node31
+   --    Activation_Record_Component     Node31
 
    --    SPARK_Pragma                    Node32
    --    No_Tagged_Streams_Pragma        Node32
@@ -689,6 +691,17 @@ package body Einfo is
       return Elist16 (Implementation_Base_Type (Id));
    end Access_Disp_Table;
 
+   function Activation_Record_Component (Id : E) return E is
+   begin
+      pragma Assert (Ekind_In (Id, E_Constant,
+                                   E_In_Parameter,
+                                   E_In_Out_Parameter,
+                                   E_Loop_Parameter,
+                                   E_Out_Parameter,
+                                   E_Variable));
+      return Node31 (Id);
+   end Activation_Record_Component;
+
    function Actual_Subtype (Id : E) return E is
    begin
       pragma Assert
@@ -3139,6 +3152,12 @@ package body Einfo is
       return Node29 (Id);
    end Subprograms_For_Type;
 
+   function Subps_Index (Id : E) return U is
+   begin
+      pragma Assert (Is_Subprogram (Id));
+      return Uint24 (Id);
+   end Subps_Index;
+
    function Suppress_Elaboration_Warnings (Id : E) return B is
    begin
       return Flag148 (Id);
@@ -3533,6 +3552,17 @@ package body Einfo is
       Set_Node22 (Id, V);
    end Set_Associated_Storage_Pool;
 
+   procedure Set_Activation_Record_Component (Id : E; V : E) is
+   begin
+      pragma Assert (Ekind_In (Id, E_Constant,
+                                   E_In_Parameter,
+                                   E_In_Out_Parameter,
+                                   E_Loop_Parameter,
+                                   E_Out_Parameter,
+                                   E_Variable));
+      Set_Node31 (Id, V);
+   end Set_Activation_Record_Component;
+
    procedure Set_Actual_Subtype (Id : E; V : E) is
    begin
       pragma Assert
@@ -6091,6 +6121,12 @@ package body Einfo is
       Set_Node29 (Id, V);
    end Set_Subprograms_For_Type;
 
+   procedure Set_Subps_Index (Id : E; V : U) is
+   begin
+      pragma Assert (Is_Subprogram (Id));
+      Set_Uint24 (Id, V);
+   end Set_Subps_Index;
+
    procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is
    begin
       Set_Flag148 (Id, V);
@@ -9689,7 +9725,11 @@ package body Einfo is
          when E_Function                                   |
               E_Operator                                   |
               E_Procedure                                  =>
-            Write_Str ("Uplevel_References");
+            if Field24 (Id) in Uint_Range then
+               Write_Str ("Subps_Index");
+            else
+               Write_Str ("Uplevel_References");
+            end if;
 
          when others                                       =>
             Write_Str ("Field24???");
@@ -9899,6 +9939,14 @@ package body Einfo is
          when Type_Kind                                    =>
             Write_Str ("Derived_Type_Link");
 
+         when E_Constant                                   |
+              E_In_Parameter                               |
+              E_In_Out_Parameter                           |
+              E_Loop_Parameter                             |
+              E_Out_Parameter                              |
+              E_Variable                                   =>
+            Write_Str ("Activation_Record_Component");
+
          when others                                       =>
             Write_Str ("Field31??");
       end case;

gcc/ada/exp_disp.ads

@@ -386,7 +386,7 @@ package Exp_Disp is
 
    procedure Set_DTC_Entity_Value (Tagged_Type : Entity_Id; Prim : Entity_Id);
    --  Set the definite value of the DTC_Entity value associated with a given
-   --  primitive of a tagged type. For subprogram wrappers propagat the value
+   --  primitive of a tagged type. For subprogram wrappers, propagate the value
    --  to the wrapped subprogram.
 
    procedure Write_DT (Typ : Entity_Id);

gcc/ada/exp_unst.ads

@@ -165,9 +165,6 @@ package Exp_Unst is
    --    since they will be accessed indirectly via an activation record as
    --    described below.
 
-   --    For each such entity xxx we create an access type xxxPTR (forced to
-   --    single length in the unconstrained case).
-
    --    An activation record is created containing system address values
    --    for each uplevel referenced entity in a given scope. In the example
    --    given before, we would have:
@@ -177,8 +174,11 @@ package Exp_Unst is
    --         x  : Address;
    --         rv : Address;
    --      end record;
-   --      type AREC1P is access all AREC1T;
-   --      AREC1 : AREC1T;
+
+   --      AREC1 : aliased AREC1T;
+
+   --      type AREC1PT is access all AREC1T;
+   --      AREC1P : constant AREC1PT := AREC1'Access;
 
    --   The fields of AREC1 are set at the point the corresponding entity
    --   is declared (immediately for parameters).
@@ -188,8 +188,8 @@ package Exp_Unst is
    --   will use AREC2, AREC3, ...
 
    --   For all subprograms nested immediately within the corresponding scope,
-   --   a parameter AREC1P is passed, and all calls to these routines have
-   --   AREC1 added as an additional formal.
+   --   a parameter AREC1F is passed, and all calls to these routines have
+   --   AREC1P added as an additional formal.
 
    --   Now within the nested procedures, any reference to an uplevel entity
    --   xxx is replaced by Tnn!(AREC1.xxx).all (where ! represents a call
@@ -216,11 +216,11 @@ package Exp_Unst is
    --
    --          AREC1.b := b'Address;
    --
-   --          procedure inner (bb : integer; AREC1P : AREC1PT);
+   --          procedure inner (bb : integer; AREC1F : AREC1PT);
    --
-   --          procedure inner2 (AREC1P : AREC1PT) is
+   --          procedure inner2 (AREC1F : AREC1PT) is
    --          begin
-   --            inner(5, AREC1P);
+   --            inner(5, AREC1F);
    --          end;
    --
    --          x  : aliased integer := 77;
@@ -231,13 +231,13 @@ package Exp_Unst is
    --          rv : aliased Integer;
    --          AREC1.rv := rv'Address;
    --
-   --          procedure inner (bb : integer; AREC1P : AREC1PT) is
+   --          procedure inner (bb : integer; AREC1F : AREC1PT) is
    --          begin
    --             type Tnn1 is access all Integer;
    --             type Tnn2 is access all Integer;
    --             type Tnn3 is access all Integer;
-   --             Tnn1!(AREC1P.x).all :=
-   --               Tnn2!(AREC1P.rv).all + y + b + Tnn3!(AREC1P.b).all;
+   --             Tnn1!(AREC1F.x).all :=
+   --               Tnn2!(AREC1F.rv).all + y + b + Tnn3!(AREC1F.b).all;
    --          end;
    --
    --       begin
@@ -386,10 +386,10 @@ package Exp_Unst is
    --          end record;
    --          darecv : darec;
    --
-   --          function inner (b : integer; AREC1P : AREC1PT) return boolean is
+   --          function inner (b : integer; AREC1F : AREC1PT) return boolean is
    --          begin
    --             type Tnn is access all Integer
-   --             return b in x .. Tnn!(AREC1P.dynam_LAST).all
+   --             return b in x .. Tnn!(AREC1F.dynam_LAST).all
    --               and then darecv.b in 42 .. 73;
    --          end inner;
    --
@@ -414,9 +414,9 @@ package Exp_Unst is
    --  approach described above for case 2, except that we need an activation
    --  record at each nested level. Basically the rule is that any procedure
    --  that has nested procedures needs an activation record. When we do this,
-   --  the inner activation records have a pointer to the immediately enclosing
-   --  activation record, the normal arrangement of static links. The following
-   --  shows the full translation of this fourth case.
+   --  the inner activation records have a pointer (uplink) to the immediately
+   --  enclosing activation record, the normal arrangement of static links. The
+   --  following shows the full translation of this fourth case.
 
    --     function case4x (x : integer) return integer is
    --        type AREC1T is record
@@ -430,10 +430,10 @@ package Exp_Unst is
    --        v1 : integer := x;
    --        AREC1.v1 := v1'Address;
    --
-   --        function inner1 (y : integer; AREC1P : ARECPT) return integer is
+   --        function inner1 (y : integer; AREC1F : AREC1PT) return integer is
    --           type AREC2T is record
-   --              AREC1 : AREC1PT := AREC1P;
-   --              v2    : Address;
+   --              AREC1U : AREC1PT := AREC1F;
+   --              v2     : Address;
    --           end record;
    --
    --           AREC2 : aliased AREC2T;
@@ -441,22 +441,22 @@ package Exp_Unst is
    --           AREC2P : constant AREC2PT := AREC2'Access;
    --
    --           type Tnn1 is access all Integer;
-   --           v2 : integer := Tnn1!(AREC1P.v1).all {+} 1;
+   --           v2 : integer := Tnn1!(AREC1F.v1).all {+} 1;
    --           AREC2.v2 := v2'Address;
    --
    --           function inner2
-   --              (z : integer; AREC2P : AREC2PT) return integer
+   --              (z : integer; AREC2F : AREC2PT) return integer
    --           is
    --           begin
    --              type Tnn1 is access all Integer;
    --              type Tnn2 is access all Integer;
    --              return integer(z {+}
-   --                             Tnn1!(AREC2P.AREC1.v1).all {+}
-   --                             Tnn2!(AREC2P.v2).all);
+   --                             Tnn1!(AREC2F.AREC1U.v1).all {+}
+   --                             Tnn2!(AREC2F.v2).all);
    --           end inner2;
    --        begin
    --           type Tnn is access all Integer;
-   --           return integer(y {+} inner2 (Tnn!(AREC1P.v1).all, AREC2P));
+   --           return integer(y {+} inner2 (Tnn!(AREC1F.v1).all, AREC2P));
    --        end inner1;
    --     begin
    --        return inner1 (x, AREC1P);

gcc/ada/sem_ch8.adb

@@ -4026,6 +4026,15 @@ package body Sem_Ch8 is
          if not In_Open_Scopes (Pack) then
             null;  --  default as well
 
+         --  If the use clause appears in an ancestor and we are in the
+         --  private part of the immediate parent, the use clauses are
+         --  already installed.
+
+         elsif Pack /= Scope (Current_Scope)
+           and then In_Private_Part (Scope (Current_Scope))
+         then
+            null;
+
          else
             --  Find entry for parent unit in scope stack