[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
This commit is contained in:
Justin Squirek
Pierre-Marie de Rodat
parent
c8324fe7b1
commit
43b264110f
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
------------------------
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue