43b264110f
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
|
||
|---|---|---|
| INSTALL | ||
| config | ||
| contrib | ||
| fixincludes | ||
| gcc | ||
| gnattools | ||
| gotools | ||
| include | ||
| intl | ||
| libada | ||
| libatomic | ||
| libbacktrace | ||
| libcc1 | ||
| libcpp | ||
| libdecnumber | ||
| libffi | ||
| libgcc | ||
| libgfortran | ||
| libgo | ||
| libgomp | ||
| libhsail-rt | ||
| libiberty | ||
| libitm | ||
| libobjc | ||
| liboffloadmic | ||
| libphobos | ||
| libquadmath | ||
| libsanitizer | ||
| libssp | ||
| libstdc++-v3 | ||
| libvtv | ||
| lto-plugin | ||
| maintainer-scripts | ||
| zlib | ||
| .dir-locals.el | ||
| .gitattributes | ||
| .gitignore | ||
| ABOUT-NLS | ||
| COPYING | ||
| COPYING.LIB | ||
| COPYING.RUNTIME | ||
| COPYING3 | ||
| COPYING3.LIB | ||
| ChangeLog | ||
| ChangeLog.jit | ||
| ChangeLog.tree-ssa | ||
| MAINTAINERS | ||
| Makefile.def | ||
| Makefile.in | ||
| Makefile.tpl | ||
| README | ||
| ar-lib | ||
| compile | ||
| config-ml.in | ||
| config.guess | ||
| config.rpath | ||
| config.sub | ||
| configure | ||
| configure.ac | ||
| depcomp | ||
| install-sh | ||
| libtool-ldflags | ||
| libtool.m4 | ||
| ltgcc.m4 | ||
| ltmain.sh | ||
| ltoptions.m4 | ||
| ltsugar.m4 | ||
| ltversion.m4 | ||
| lt~obsolete.m4 | ||
| missing | ||
| mkdep | ||
| mkinstalldirs | ||
| move-if-change | ||
| multilib.am | ||
| symlink-tree | ||
| test-driver | ||
| ylwrap | ||
README
This directory contains the GNU Compiler Collection (GCC). The GNU Compiler Collection is free software. See the files whose names start with COPYING for copying permission. The manuals, and some of the runtime libraries, are under different terms; see the individual source files for details. The directory INSTALL contains copies of the installation information as HTML and plain text. The source of this information is gcc/doc/install.texi. The installation information includes details of what is included in the GCC sources and what files GCC installs. See the file gcc/doc/gcc.texi (together with other files that it includes) for usage and porting information. An online readable version of the manual is in the files gcc/doc/gcc.info*. See http://gcc.gnu.org/bugs/ for how to report bugs usefully. Copyright years on GCC source files may be listed using range notation, e.g., 1987-2012, indicating that every year in the range, inclusive, is a copyrightable year that could otherwise be listed individually.