OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
171,306 Commits 63 Branches 184 Tags 3.1 GiB
C 48%
Ada 18.3%
C++ 14.1%
Go 7%
GCC Machine Description 4.6%
Other 7.7%
43b264110f
Go to file
Justin Squirek 43b264110f [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
2019-09-18 08:33:07 +00:00
config [ARM/FDPIC v6 02/24] [ARM] FDPIC: Handle arm*-*-uclinuxfdpiceabi in configure scripts 2019-09-10 09:37:00 +02:00
contrib GCC port for eBPF 2019-09-09 12:13:23 +02:00
fixincludes [Darwin, fixincludes] Fix PR83531 2019-08-18 18:54:13 +00:00
gcc [Ada] Spurious run time error on anonymous access formals 2019-09-18 08:33:07 +00:00
gnattools
gotools libgo: update to Go 1.13beta1 release 2019-09-06 18:12:46 +00:00
include Fix file descriptor existence of MinGW. 2019-08-08 07:50:28 +00:00
INSTALL
intl
libada Update copyright years. 2019-01-01 13:31:55 +01:00
libatomic [ARM/FDPIC v6 02/24] [ARM] FDPIC: Handle arm*-*-uclinuxfdpiceabi in configure scripts 2019-09-10 09:37:00 +02:00
libbacktrace Remove Cell Broadband Engine SPU targets 2019-09-03 15:08:28 +00:00
libcc1 [C++ PATCH] Using decls 2019-05-21 14:33:24 +00:00
libcpp [preprocessor] Popping "" file names 2019-09-06 12:54:19 +00:00
libdecnumber Update copyright years. 2019-01-01 13:31:55 +01:00
libffi re PR other/79543 (Inappropriate "ld --version" checking) 2019-09-03 14:10:26 +00:00
libgcc [ARM/FDPIC v6 13/24] [ARM] FDPIC: Force LSB bit for PC in Cortex-M architecture 2019-09-10 09:58:44 +02:00
libgfortran Improve PRNG jumping when using threads 2019-09-05 09:59:55 +03:00
libgo runtime: for FFI, treat directIface types as pointers 2019-09-17 20:26:21 +00:00
libgomp libgomp plugin - init string 2019-09-13 20:14:02 +02:00
libhsail-rt Update copyright years. 2019-01-01 13:31:55 +01:00
libiberty rust-demangle.c (unescape): Remove. 2019-09-03 14:04:32 -06:00
libitm [ARM/FDPIC v6 23/24] [ARM] FDPIC: Implement libitm support. 2019-09-10 10:11:46 +02:00
libobjc re PR target/89093 (C++ exception handling clobbers d8 VFP register) 2019-04-23 12:03:41 +02:00
liboffloadmic PR other/16615 [1/5] 2019-01-09 16:37:45 -05:00
libphobos libphobos.exp (libphobos_init): Add multi-lib libgcc dirs to the ld_library_path var. 2019-09-03 08:24:03 +00:00
libquadmath quadmath.h (M_Eq, [...]): Use two more decimal places. 2019-08-02 09:59:19 +02:00
libsanitizer [ARM/FDPIC v6 03/24] [ARM] FDPIC: Force FDPIC related options unless -mno-fdpic is provided 2019-09-10 09:39:47 +02:00
libssp Update copyright years. 2019-01-01 13:31:55 +01:00
libstdc++-v3 PR libstdc++/91748 fix std::for_each_n for random access iterators 2019-09-12 11:51:39 +01:00
libvtv Fix testsuite 2019-02-20 08:07:19 -08:00
lto-plugin lto-plugin, removed unused variable 2019-05-15 14:10:27 +00:00
maintainer-scripts update_web_docs_svn: Proceed even if the invocation of sphinx fails. 2019-08-04 22:31:54 +00:00
zlib Makefile.am (noinst_LTLIBRARIES): Rename libzgcj_convience.la to libz_convenience.la. 2019-01-21 17:23:58 +00:00
.dir-locals.el
.gitattributes
.gitignore Add .clangd and compile_commands.json to .gitignore. 2019-08-28 19:33:28 +00:00
ABOUT-NLS
ar-lib
ChangeLog [PATCH][GCC] Update my email address 2019-09-13 10:41:37 +00:00
ChangeLog.jit
ChangeLog.tree-ssa
compile
config-ml.in
config.guess Update config.sub and config.guess. 2019-09-09 11:14:32 +02:00
config.rpath
config.sub Update config.sub and config.guess. 2019-09-09 11:14:32 +02:00
configure GCC port for eBPF 2019-09-09 12:13:23 +02:00
configure.ac GCC port for eBPF 2019-09-09 12:13:23 +02:00
COPYING
COPYING3
COPYING3.LIB
COPYING.LIB
COPYING.RUNTIME
depcomp
install-sh
libtool-ldflags
libtool.m4 [ARM/FDPIC v6 02/24] [ARM] FDPIC: Handle arm*-*-uclinuxfdpiceabi in configure scripts 2019-09-10 09:37:00 +02:00
lt~obsolete.m4
ltgcc.m4
ltmain.sh
ltoptions.m4
ltsugar.m4
ltversion.m4
MAINTAINERS [PATCH][GCC] Update my email address 2019-09-13 10:41:37 +00:00
Makefile.def Sync top-level change from gdb 2019-06-15 21:32:03 +00:00
Makefile.in Makefile.tpl (HOST_EXPORTS): Add CXX_FOR_BUILD. 2019-08-23 15:37:22 -06:00
Makefile.tpl Makefile.tpl (HOST_EXPORTS): Add CXX_FOR_BUILD. 2019-08-23 15:37:22 -06:00
missing
mkdep
mkinstalldirs
move-if-change
multilib.am
README
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.