[Ada] Spurious run time error on anonymous access formals

This patch fixes an issue whereby subprograms with anonymous access
formals may trigger spurious runtime accessibility errors when such
formals are used as actuals in calls to nested subprograms.

Running these commands:

  gnatmake -q pass.adb
  gnatmake -q fail.adb
  gnatmake -q test_main.adb
  gnatmake -q indirect_call_test.adb
  pass
  fail
  test_main
  indirect_call_test

On the following sources:

--  pass.adb

procedure Pass is

  function A (Param : access Integer) return Boolean is
    type Typ is access all Integer;
    function A_Inner (Param : access Integer) return Typ is
      begin
        return Typ (Param); --  OK
      end;
    begin
      return A_Inner (Param) = Typ (Param);
    end;

  function B (Param : access Integer) return Boolean;
  function B (Param : access Integer) return Boolean is
    type Typ is access all Integer;
    function B_Inner (Param : access Integer) return Typ is
      begin
        return Typ (Param); --  OK
      end;
    begin
      return B_Inner (Param) = Typ (Param);
    end;

  procedure C (Param : access Integer) is
    type Typ is access all Integer;
    Var : Typ;
    procedure C_Inner (Param : access Integer) is
      begin
        Var := Typ (Param); --  OK
      end;
    begin
      C_Inner (Param);
    end;

  procedure D (Param : access Integer);
  procedure D (Param : access Integer) is
    type Typ is access all Integer;
    Var : Typ;
    procedure D_Inner (Param : access Integer) is
      begin
        Var := Typ (Param); --  OK
      end;
    begin
      D_Inner (Param);
    end;

  protected type E is
    function G (Param : access Integer) return Boolean;
    procedure I (Param : access Integer);
  end;

  protected body E is
    function F (Param : access Integer) return Boolean is
      type Typ is access all Integer;
      function F_Inner (Param : access Integer) return Typ is
        begin
          return Typ (Param); --  OK
        end;
      begin
        return F_Inner (Param) = Typ (Param);
      end;

    function G (Param : access Integer) return Boolean is
      type Typ is access all Integer;
      function G_Inner (Param : access Integer) return Typ is
        begin
          return Typ (Param); --  OK
        end;
      B : Boolean := F (Param); --  OK
      begin
        return G_Inner (Param) = Typ (Param);
      end;

    procedure H (Param : access Integer) is
      type Typ is access all Integer;
      Var : Typ;
      procedure H_Inner (Param : access Integer) is
        begin
          Var := Typ (Param); --  OK
        end;
      begin
        H_Inner (Param);
      end;

    procedure I (Param : access Integer) is
      type Typ is access all Integer;
      Var : Typ;
      procedure I_Inner (Param : access Integer) is
        begin
          Var := Typ (Param); --  OK
        end;
      begin
        H (Param); --  OK
        I_Inner (Param);
      end;
  end;

  task type J is end;

  task body J is
    function K (Param : access Integer) return Boolean is
      type Typ is access all Integer;
      function K_Inner (Param : access Integer) return Typ is
        begin
          return Typ (Param); --  OK
        end;
      begin
        return K_Inner (Param) = Typ (Param);
      end;

    function L (Param : access Integer) return Boolean;
    function L (Param : access Integer) return Boolean is
      type Typ is access all Integer;
      function L_Inner (Param : access Integer) return Typ is
        begin
          return Typ (Param); --  OK
        end;
      begin
        return L_Inner (Param) = Typ (Param);
      end;

    procedure M (Param : access Integer) is
      type Typ is access all Integer;
      Var : Typ;
      procedure M_Inner (Param : access Integer) is
        begin
          Var := Typ (Param); --  OK
        end;
      begin
        M_Inner (Param);
      end;

    procedure N (Param : access Integer);
    procedure N (Param : access Integer) is
      type Typ is access all Integer;
      Var : Typ;
      procedure N_Inner (Param : access Integer) is
        begin
          Var := Typ (Param); --  OK
        end;
      begin
        N_Inner (Param);
      end;
    Var : aliased Integer := 666;
    begin
      if K (Var'Access) then null; end if; --  OK
      if L (Var'Access) then null; end if; --  OK
      M (Var'Access);                      --  OK
      N (Var'Access);                      --  OK
    end;

begin
  begin
    begin
      declare
      Var  : aliased Integer := 666;
      T    : J;
      Prot : E;
      begin
        if A (Var'Access) then null; end if;      --  OK
        if B (Var'Access) then null; end if;      --  OK
        C (Var'Access);                           --  OK
        D (Var'Access);                           --  OK
        if Prot.G (Var'Access) then null; end if; --  OK
        Prot.I (Var'Access);                      --  OK
      end;
    end;
  end;
end;

--  fail.adb

procedure Fail is
  Failures : Integer := 0;

  type Base_Typ is access all Integer;

  function A (Param : access Integer) return Boolean is
    subtype Typ is Base_Typ;
    function A_Inner (Param : access Integer) return Typ is
      begin
        return Typ (Param); --  ERROR
      end;
    begin
      return A_Inner (Param) = Typ (Param);
    exception
      when others => Failures := Failures + 1;
      return False;
    end;

  function B (Param : access Integer) return Boolean;
  function B (Param : access Integer) return Boolean is
    subtype Typ is Base_Typ;
    function B_Inner (Param : access Integer) return Typ is
      begin
        return Typ (Param); --  ERROR
      end;
    begin
      return B_Inner (Param) = Typ (Param);
    exception
      when others => Failures := Failures + 1;
      return False;
    end;

  procedure C (Param : access Integer) is
    subtype Typ is Base_Typ;
    Var : Typ;
    procedure C_Inner (Param : access Integer) is
      begin
        Var := Typ (Param); --  ERROR
      end;
    begin
      C_Inner (Param);
    exception
      when others => Failures := Failures + 1;
    end;

  procedure D (Param : access Integer);
  procedure D (Param : access Integer) is
    subtype Typ is Base_Typ;
    Var : Typ;
    procedure D_Inner (Param : access Integer) is
      begin
        Var := Typ (Param); --  ERROR
      end;
    begin
      D_Inner (Param);
    exception
      when others => Failures := Failures + 1;
    end;

  protected type E is
    function G (Param : access Integer) return Boolean;
    procedure I (Param : access Integer);
  end;

  protected body E is
    function F (Param : access Integer) return Boolean is
      subtype Typ is Base_Typ;
      function F_Inner (Param : access Integer) return Typ is
        begin
          return Typ (Param); --  ERROR
        end;
      begin
        return F_Inner (Param) = Typ (Param);
      exception
        when others => Failures := Failures + 1;
        return False;
      end;

    function G (Param : access Integer) return Boolean is
      subtype Typ is Base_Typ;
      function G_Inner (Param : access Integer) return Typ is
        begin
          return Typ (Param); --  ERROR
        end;
      B : Boolean := F (Param); --  ERROR
      begin
        return G_Inner (Param) = Typ (Param);
      exception
        when others => Failures := Failures + 1;
        return False;
      end;

    procedure H (Param : access Integer) is
      subtype Typ is Base_Typ;
      Var : Typ;
      procedure H_Inner (Param : access Integer) is
        begin
          Var := Typ (Param); --  ERROR
        end;
      begin
        H_Inner (Param);
      exception
        when others => Failures := Failures + 1;
      end;

    procedure I (Param : access Integer) is
      subtype Typ is Base_Typ;
      Var : Typ;
      procedure I_Inner (Param : access Integer) is
        begin
          Var := Typ (Param); --  ERROR
        end;
      begin
        H (Param); --  ERROR
        I_Inner (Param);
      exception
        when others => Failures := Failures + 1;
      end;
  end;

  task type J is end;

  task body J is
    function K (Param : access Integer) return Boolean is
      subtype Typ is Base_Typ;
      function K_Inner (Param : access Integer) return Typ is
        begin
          return Typ (Param); --  ERROR
        end;
      begin
        return K_Inner (Param) = Typ (Param);
      exception
        when others => Failures := Failures + 1;
        return False;
      end;

    function L (Param : access Integer) return Boolean;
    function L (Param : access Integer) return Boolean is
      subtype Typ is Base_Typ;
      function L_Inner (Param : access Integer) return Typ is
        begin
          return Typ (Param); --  ERROR
        end;
      begin
        return L_Inner (Param) = Typ (Param);
      exception
        when others => Failures := Failures + 1;
        return False;
      end;

    procedure M (Param : access Integer) is
      subtype Typ is Base_Typ;
      Var : Typ;
      procedure M_Inner (Param : access Integer) is
        begin
          Var := Typ (Param); --  ERROR
        end;
      begin
        M_Inner (Param);
      exception
        when others => Failures := Failures + 1;
      end;

    procedure N (Param : access Integer);
    procedure N (Param : access Integer) is
      subtype Typ is Base_Typ;
      Var : Typ;
      procedure N_Inner (Param : access Integer) is
        begin
          Var := Typ (Param); --  ERROR
        end;
      begin
        N_Inner (Param);
      exception
        when others => Failures := Failures + 1;
      end;
    Var : aliased Integer := 666;
    begin
      if K (Var'Access) then null; end if; --  ERROR
      if L (Var'Access) then null; end if; --  ERROR
      M (Var'Access);                      --  ERROR
      N (Var'Access);                      --  ERROR
    end;

begin
  begin
    begin
      declare
      Var  : aliased Integer := 666;
      T    : J;
      Prot : E;
      begin
        if A (Var'Access) then null; end if;      --  ERROR
        if B (Var'Access) then null; end if;      --  ERROR
        C (Var'Access);                           --  ERROR
        D (Var'Access);                           --  ERROR
        if Prot.G (Var'Access) then null; end if; --  ERROR
        Prot.I (Var'Access);                      --  ERROR
        if Failures /= 12 then
          raise Program_Error;
        end if;
      end;
    end;
  end;
end;

--  indirect_call_test.adb

with Text_IO;

procedure Indirect_Call_Test is

   Tracing_Enabled : constant Boolean := False;
   procedure Trace (S : String) is
   begin
      if Tracing_Enabled then
        Text_IO.Put_Line (S);
      end if;
   end;

   package Pkg is
      type Root is abstract tagged null record;
      function F (X : Root; Param : access Integer)
        return Boolean is abstract;
   end Pkg;

   function F_Wrapper
     (X : Pkg.Root; Param : access Integer)
     return Boolean
     is (Pkg.F (Pkg.Root'Class (X), Param));
     -- dispatching call

   function A (Param : access Integer) return Boolean is
      type Typ is access all Integer;

      package Nested is
         type Ext is new Pkg.Root with null record;
         overriding function F
           (X : Ext; Param : access Integer)
           return Boolean;
      end Nested;

      function A_Inner
        (Param : access Integer) return Typ is
      begin
         return Typ (Param);  -- OK
      end A_Inner;

      package body Nested is
         function F (X : Ext; Param : access Integer)
          return Boolean is
         begin
            return A_Inner (Param) = null;
         end;
      end;

       Ext_Obj : Nested.Ext;
   begin
       Trace ("In subtest A");
       return F_Wrapper (Pkg.Root (Ext_Obj), Param);
   exception
      when Program_Error =>
          Trace ("Failed");
          return True;
   end A;

   function B (Param : access Integer) return Boolean is
      type Typ is access all Integer;

      function B_Inner
        (Param : access Integer) return Typ is
      begin
         return Typ (Param); -- OK
      end B_Inner;

      type Ref is access function
         (Param : access Integer) return Typ;
      Ptr : Ref := B_Inner'Access;

      function Ptr_Caller return Typ is
        (Ptr.all (Param)); -- access-to-subp value
   begin
      Trace ("In subtest B");
      return Ptr_Caller = null;
   exception
      when Program_Error =>
          Trace ("*** failed");
          return True;
   end B;

begin
   begin
      begin
         declare
            Var : aliased Integer := 666;
         begin
            if A (Var'Access) then
               null;
            end if;
            Trace ("Subtest A done");
            if B (Var'Access) then
               null;
            end if;
            Trace ("Subtest B done");
         end;
      end;
   end;
end Indirect_Call_Test;

Should produce the following output:

  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure
  Failure

2019-09-18  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* einfo.adb, einfo.ads (Minimum_Accessibility): Added new field.
	(Set_Minimum_Accessibility): Added to set new field.
	(Minimum_Accessibility): Added to fetch new field.
	* exp_ch6.adb (Expand_Subprogram_Call): Modify calls to fetch
	accessibility levels to the new subprogram Get_Accessibility
	which handles cases where minimum accessibility might be needed.
	* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Add section to
	generate a Minimum_Accessibility object within relevant
	subprograms.
	* sem_util.adb, sem_util.ads (Dynamic_Accessibility_Level):
	Additional documentation added and modify section to use new
	function Get_Accessibility.
	(Get_Accessibility): Added to centralize processing of
	accessibility levels.

From-SVN: r275858

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 452243a9589fffe79ddc3045b738b2e8ae50efca..384f98205420d8d25ae45d97dbdb0bba3c9524d8 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,20 @@
+2019-09-18  Justin Squirek  <squirek@adacore.com>
+
+       * einfo.adb, einfo.ads (Minimum_Accessibility): Added new field.
+       (Set_Minimum_Accessibility): Added to set new field.
+       (Minimum_Accessibility): Added to fetch new field.
+       * exp_ch6.adb (Expand_Subprogram_Call): Modify calls to fetch
+       accessibility levels to the new subprogram Get_Accessibility
+       which handles cases where minimum accessibility might be needed.
+       * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Add section to
+       generate a Minimum_Accessibility object within relevant
+       subprograms.
+       * sem_util.adb, sem_util.ads (Dynamic_Accessibility_Level):
+       Additional documentation added and modify section to use new
+       function Get_Accessibility.
+       (Get_Accessibility): Added to centralize processing of
+       accessibility levels.
+
 2019-09-18  Steve Baird  <baird@adacore.com>
 
        * sem_util.ads (Interval_Lists): A new visible package. This

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index ebef3a0ca74106e4b624af98912ed6623165a5af..dcbeac5780ca5b0201c387eef4a97a9b33d17a52 100644 (file)
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -215,6 +215,7 @@ package body Einfo is
    --    Stored_Constraint               Elist23
 
    --    Incomplete_Actuals              Elist24
+   --    Minimum_Accessibility           Node24
    --    Related_Expression              Node24
    --    Subps_Index                     Uint24
 
@@ -2847,6 +2848,12 @@ package body Einfo is
       return UI_To_Int (Uint8 (Id));
    end Mechanism;
 
+   function Minimum_Accessibility (Id : E) return E is
+   begin
+      pragma Assert (Ekind (Id) in Formal_Kind);
+      return Node24 (Id);
+   end Minimum_Accessibility;
+
    function Modulus (Id : E) return Uint is
    begin
       pragma Assert (Is_Modular_Integer_Type (Id));
@@ -6076,6 +6083,12 @@ package body Einfo is
       Set_Uint8 (Id, UI_From_Int (V));
    end Set_Mechanism;
 
+   procedure Set_Minimum_Accessibility (Id : E; V : E) is
+   begin
+      pragma Assert (Ekind (Id) in Formal_Kind);
+      Set_Node24 (Id, V);
+   end Set_Minimum_Accessibility;
+
    procedure Set_Modulus (Id : E; V : U) is
    begin
       pragma Assert (Ekind (Id) = E_Modular_Integer_Type);
@@ -10913,6 +10926,9 @@ package body Einfo is
          =>
             Write_Str ("Related_Expression");
 
+         when Formal_Kind =>
+            Write_Str ("Minimum_Accessibility");
+
          when E_Function
             | E_Operator
             | E_Procedure

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index e93a837b82e7478e82d73205cad8b892a44b4567..3e968a29bd844326a451b0374a31f8b100594c0c 100644 (file)
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3516,6 +3516,14 @@ package Einfo is
 --       is also set (to the default value of zero = Default_Mechanism) in a
 --       subprogram body entity but not used in this context.
 
+--    Minimum_Accessibility (Node24)
+--       Defined in formal parameters in the non-generic case. Normally Empty,
+--       but if expansion is active, and a parameter exists for which a
+--       dynamic accessibility check is required, then an object is generated
+--       within such a subprogram representing the accessibility level of the
+--       subprogram or the formal's Extra_Accessibility - whichever one is
+--       lesser. The Minimum_Accessibility field then points to this object.
+
 --    Modulus (Uint17) [base type only]
 --       Defined in modular types. Contains the modulus. For the binary case,
 --       this will be a power of 2, but if Non_Binary_Modulus is set, then it
@@ -6273,6 +6281,7 @@ package Einfo is
    --    Default_Expr_Function               (Node21)
    --    Protected_Formal                    (Node22)
    --    Extra_Constrained                   (Node23)
+   --    Minimum_Accessibility               (Node24)
    --    Last_Assignment                     (Node26)   (OUT, IN-OUT only)
    --    Activation_Record_Component         (Node31)
    --    Has_Initial_Value                   (Flag219)
@@ -7398,6 +7407,7 @@ package Einfo is
    function Materialize_Entity                  (Id : E) return B;
    function May_Inherit_Delayed_Rep_Aspects     (Id : E) return B;
    function Mechanism                           (Id : E) return M;
+   function Minimum_Accessibility               (Id : E) return E;
    function Modulus                             (Id : E) return U;
    function Must_Be_On_Byte_Boundary            (Id : E) return B;
    function Must_Have_Preelab_Init              (Id : E) return B;
@@ -8103,6 +8113,7 @@ package Einfo is
    procedure Set_Materialize_Entity              (Id : E; V : B := True);
    procedure Set_May_Inherit_Delayed_Rep_Aspects (Id : E; V : B := True);
    procedure Set_Mechanism                       (Id : E; V : M);
+   procedure Set_Minimum_Accessibility           (Id : E; V : E);
    procedure Set_Modulus                         (Id : E; V : U);
    procedure Set_Must_Be_On_Byte_Boundary        (Id : E; V : B := True);
    procedure Set_Must_Have_Preelab_Init          (Id : E; V : B := True);
@@ -8973,6 +8984,7 @@ package Einfo is
    pragma Inline (Materialize_Entity);
    pragma Inline (May_Inherit_Delayed_Rep_Aspects);
    pragma Inline (Mechanism);
+   pragma Inline (Minimum_Accessibility);
    pragma Inline (Modulus);
    pragma Inline (Must_Be_On_Byte_Boundary);
    pragma Inline (Must_Have_Preelab_Init);
@@ -9466,6 +9478,7 @@ package Einfo is
    pragma Inline (Set_Materialize_Entity);
    pragma Inline (Set_May_Inherit_Delayed_Rep_Aspects);
    pragma Inline (Set_Mechanism);
+   pragma Inline (Set_Minimum_Accessibility);
    pragma Inline (Set_Modulus);
    pragma Inline (Set_Must_Be_On_Byte_Boundary);
    pragma Inline (Set_Must_Have_Preelab_Init);

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 3277b46b0ccbdc68a19d2345b2c6b1325c0f6251..78a1496d011c57a1c4a09608b17b6cc678e74811 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3221,7 +3221,7 @@ package body Exp_Ch6 is
 
          --  Create possible extra actual for accessibility level
 
-         if Present (Extra_Accessibility (Formal)) then
+         if Present (Get_Accessibility (Formal)) then
 
             --  Ada 2005 (AI-252): If the actual was rewritten as an Access
             --  attribute, then the original actual may be an aliased object
@@ -3297,8 +3297,8 @@ package body Exp_Ch6 is
 
                   Add_Extra_Actual
                     (Expr =>
-                       New_Occurrence_Of (Extra_Accessibility (Parm_Ent), Loc),
-                     EF   => Extra_Accessibility (Formal));
+                       New_Occurrence_Of (Get_Accessibility (Parm_Ent), Loc),
+                     EF   => Get_Accessibility (Formal));
                end;
 
             elsif Is_Entity_Name (Prev_Orig) then
@@ -3327,12 +3327,12 @@ package body Exp_Ch6 is
                   begin
                      pragma Assert (Present (Parm_Ent));
 
-                     if Present (Extra_Accessibility (Parm_Ent)) then
+                     if Present (Get_Accessibility (Parm_Ent)) then
                         Add_Extra_Actual
                           (Expr =>
                              New_Occurrence_Of
-                               (Extra_Accessibility (Parm_Ent), Loc),
-                           EF   => Extra_Accessibility (Formal));
+                               (Get_Accessibility (Parm_Ent), Loc),
+                           EF   => Get_Accessibility (Formal));
 
                      --  If the actual access parameter does not have an
                      --  associated extra formal providing its scope level,
@@ -3344,7 +3344,7 @@ package body Exp_Ch6 is
                           (Expr =>
                              Make_Integer_Literal (Loc,
                                Intval => Scope_Depth (Standard_Standard)),
-                           EF   => Extra_Accessibility (Formal));
+                           EF   => Get_Accessibility (Formal));
                      end if;
                   end;
 
@@ -3354,7 +3354,7 @@ package body Exp_Ch6 is
                else
                   Add_Extra_Actual
                     (Expr => Dynamic_Accessibility_Level (Prev_Orig),
-                     EF   => Extra_Accessibility (Formal));
+                     EF   => Get_Accessibility (Formal));
                end if;
 
             --  If the actual is an access discriminant, then pass the level
@@ -3370,7 +3370,7 @@ package body Exp_Ch6 is
                  (Expr =>
                     Make_Integer_Literal (Loc,
                       Intval => Object_Access_Level (Prefix (Prev_Orig))),
-                  EF   => Extra_Accessibility (Formal));
+                  EF   => Get_Accessibility (Formal));
 
             --  All other cases
 
@@ -3440,19 +3440,19 @@ package body Exp_Ch6 is
                                    Make_Integer_Literal (Loc,
                                      Intval =>
                                        Type_Access_Level (Pref_Entity)),
-                                 EF   => Extra_Accessibility (Formal));
+                                 EF   => Get_Accessibility (Formal));
 
                            elsif Nkind (Prev_Orig) = N_Explicit_Dereference
                              and then Present (Pref_Entity)
                              and then Is_Formal (Pref_Entity)
                              and then Present
-                                        (Extra_Accessibility (Pref_Entity))
+                                        (Get_Accessibility (Pref_Entity))
                            then
                               Add_Extra_Actual
                                 (Expr =>
                                    New_Occurrence_Of
-                                     (Extra_Accessibility (Pref_Entity), Loc),
-                                 EF   => Extra_Accessibility (Formal));
+                                     (Get_Accessibility (Pref_Entity), Loc),
+                                 EF   => Get_Accessibility (Formal));
 
                            else
                               Add_Extra_Actual
@@ -3460,7 +3460,7 @@ package body Exp_Ch6 is
                                    Make_Integer_Literal (Loc,
                                      Intval =>
                                        Object_Access_Level (Prev_Orig)),
-                                 EF   => Extra_Accessibility (Formal));
+                                 EF   => Get_Accessibility (Formal));
                            end if;
 
                         --  Treat the unchecked attributes as library-level
@@ -3472,7 +3472,7 @@ package body Exp_Ch6 is
                              (Expr =>
                                 Make_Integer_Literal (Loc,
                                   Intval => Scope_Depth (Standard_Standard)),
-                              EF   => Extra_Accessibility (Formal));
+                              EF   => Get_Accessibility (Formal));
 
                         --  No other cases of attributes returning access
                         --  values that can be passed to access parameters.
@@ -3494,7 +3494,7 @@ package body Exp_Ch6 is
                        (Expr =>
                           Make_Integer_Literal (Loc,
                             Intval => Scope_Depth (Current_Scope) + 1),
-                        EF   => Extra_Accessibility (Formal));
+                        EF   => Get_Accessibility (Formal));
 
                   --  For most other cases we simply pass the level of the
                   --  actual's access type. The type is retrieved from
@@ -3505,7 +3505,7 @@ package body Exp_Ch6 is
                   when others =>
                      Add_Extra_Actual
                        (Expr => Dynamic_Accessibility_Level (Prev),
-                        EF   => Extra_Accessibility (Formal));
+                        EF   => Get_Accessibility (Formal));
                end case;
             end if;
          end if;

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index ddb12ec52f50eddfb17066a62e547075bb547b1f..eb6768d3ae2ce0e28dc5f714f83f01d8c769816f 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -3376,6 +3376,9 @@ package body Sem_Ch6 is
 
       --  Local variables
 
+      Body_Nod         : Node_Id := Empty;
+      Minimum_Acc_Objs : List_Id := No_List;
+
       Saved_GM   : constant Ghost_Mode_Type := Ghost_Mode;
       Saved_IGR  : constant Node_Id         := Ignored_Ghost_Region;
       Saved_EA   : constant Boolean         := Expander_Active;
@@ -4254,6 +4257,110 @@ package body Sem_Ch6 is
          end;
       end if;
 
+      --  Generate minimum accessibility local objects to correspond with
+      --  any extra formal added for anonymous access types. This new local
+      --  object can then be used instead of the formal in case it is used
+      --  in an actual to a call to a nested subprogram.
+
+      --  This method is used to suppliment our "small integer model" for
+      --  accessibility check generation (for more information see
+      --  Dynamic_Accessibility_Level).
+
+      --  Because we allow accesibility values greater than our expected value
+      --  passing along the same extra accessibility formal as an actual
+      --  to a nested subprogram becomes a problem because high values mean
+      --  different things to the callee even though they are the same to the
+      --  caller. So, as described in the first section, we create a local
+      --  object representing the minimum of the accessibility level value that
+      --  is passed in and the accessibility level of the callee's parameter
+      --  and locals and use it in the case of a call to a nested subprogram.
+      --  This generated object is refered to as a "minimum accessiblity
+      --  level."
+
+      if Present (Spec_Id) or else Present (Body_Id) then
+         Body_Nod := Unit_Declaration_Node (Body_Id);
+
+         declare
+            Form : Entity_Id;
+         begin
+            --  Grab the appropriate formal depending on whether there exists
+            --  an actual spec for the subprogram or whether we are dealing
+            --  with a protected subprogram.
+
+            if Present (Spec_Id) then
+               if Present (Protected_Body_Subprogram (Spec_Id)) then
+                  Form := First_Formal (Protected_Body_Subprogram (Spec_Id));
+               else
+                  Form := First_Formal (Spec_Id);
+               end if;
+            else
+               Form := First_Formal (Body_Id);
+            end if;
+
+            --  Loop through formals if the subprogram is capable of accepting
+            --  a generated local object. If it is not then it is also not
+            --  capable of having local subprograms meaning it would not need
+            --  a minimum accessibility level object anyway.
+
+            if Present (Body_Nod)
+              and then Has_Declarations (Body_Nod)
+              and then Nkind (Body_Nod) /= N_Package_Specification
+            then
+               while Present (Form) loop
+
+                  if Present (Extra_Accessibility (Form))
+                    and then No (Minimum_Accessibility (Form))
+                  then
+                     --  Generate the minimum accessibility level object
+
+                     --    A60b : integer := integer'min(2, paramL);
+
+                     declare
+                        Loc      : constant Source_Ptr := Sloc (Body_Nod);
+                        Obj_Node : constant Node_Id :=
+                           Make_Object_Declaration (Loc,
+                            Defining_Identifier =>
+                              Make_Temporary
+                                (Loc, 'A', Extra_Accessibility (Form)),
+                            Object_Definition   => New_Occurrence_Of
+                                                     (Standard_Integer, Loc),
+                            Expression          =>
+                              Make_Attribute_Reference (Loc,
+                                Prefix         => New_Occurrence_Of
+                                                    (Standard_Integer, Loc),
+                                Attribute_Name => Name_Min,
+                                Expressions    => New_List (
+                                  Make_Integer_Literal (Loc,
+                                    Object_Access_Level (Form)),
+                                  New_Occurrence_Of
+                                    (Extra_Accessibility (Form), Loc))));
+                     begin
+                        --  Add the new local object to the Minimum_Acc_Obj to
+                        --  be later prepended to the subprogram's list of
+                        --  declarations after we are sure all expansion is
+                        --  done.
+
+                        if Present (Minimum_Acc_Objs) then
+                           Prepend (Obj_Node, Minimum_Acc_Objs);
+                        else
+                           Minimum_Acc_Objs := New_List (Obj_Node);
+                        end if;
+
+                        --  Register the object and analyze it
+
+                        Set_Minimum_Accessibility
+                          (Form, Defining_Identifier (Obj_Node));
+
+                        Analyze (Obj_Node);
+                     end;
+                  end if;
+
+                  Next_Formal (Form);
+               end loop;
+            end if;
+         end;
+      end if;
+
       --  Now we can go on to analyze the body
 
       HSS := Handled_Statement_Sequence (N);
@@ -4358,6 +4465,19 @@ package body Sem_Ch6 is
       Inspect_Deferred_Constant_Completion (Declarations (N));
       Analyze (HSS);
 
+      --  Add the generated minimum accessibility objects to the subprogram
+      --  body's list of declarations after analysis of the statements and
+      --  contracts.
+
+      while Is_Non_Empty_List (Minimum_Acc_Objs) loop
+         if Present (Declarations (Body_Nod)) then
+            Prepend (Remove_Head (Minimum_Acc_Objs), Declarations (Body_Nod));
+         else
+            Set_Declarations
+              (Body_Nod, New_List (Remove_Head (Minimum_Acc_Objs)));
+         end if;
+      end loop;
+
       --  Deal with end of scope processing for the body
 
       Process_End_Label (HSS, 't', Current_Scope);

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 13555a56cbe5a6488b1d3527e048b5b5bf7fe4fc..1bcda5fa172676893e6899e8bd9e7524d5ffa6fb 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6531,10 +6531,11 @@ package body Sem_Util is
             return Dynamic_Accessibility_Level (Renamed_Object (E));
          end if;
 
-         if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
-            if Present (Extra_Accessibility (E)) then
-               return New_Occurrence_Of (Extra_Accessibility (E), Loc);
-            end if;
+         if (Is_Formal (E)
+              or else Ekind_In (E, E_Variable, E_Constant))
+           and then Present (Get_Accessibility (E))
+         then
+            return New_Occurrence_Of (Get_Accessibility (E), Loc);
          end if;
       end if;
 
@@ -9212,6 +9213,30 @@ package body Sem_Util is
       end if;
    end Gather_Components;
 
+   -----------------------
+   -- Get_Accessibility --
+   -----------------------
+
+   function Get_Accessibility (E : Entity_Id) return Node_Id is
+   begin
+      --  When minimum accessibility is set for E then we utilize it - except
+      --  in a few edge cases like the expansion of select statements where
+      --  generated subprogram may attempt to unnecessarily use a minimum
+      --  accessibility object declared outside of scope.
+
+      --  To avoid these situations where expansion may get complex we verify
+      --  that the minimum accessibility object is within scope.
+
+      if Ekind (E) in Formal_Kind
+        and then Present (Minimum_Accessibility (E))
+        and then In_Open_Scopes (Scope (Minimum_Accessibility (E)))
+      then
+         return Minimum_Accessibility (E);
+      end if;
+
+      return Extra_Accessibility (E);
+   end Get_Accessibility;
+
    ------------------------
    -- Get_Actual_Subtype --
    ------------------------

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index c77f4414a74ad409cc1d206db67c828291d1d0a3..b41b8750fd25bcdcb4bcf48effc7a7d68bc3f2f9 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -983,6 +983,10 @@ package Sem_Util is
    --  discriminants. Otherwise all components of the parent must be included
    --  in the subtype for semantic analysis.
 
+   function Get_Accessibility (E : Entity_Id) return Node_Id;
+   --  Obtain the accessibility level for a given entity formal taking into
+   --  account both extra and minimum accessibility.
+
    function Get_Actual_Subtype (N : Node_Id) return Entity_Id;
    --  Given a node for an expression, obtain the actual subtype of the
    --  expression. In the case of a parameter where the formal is an