Re: [PR81878]: fix --disable-bootstrap --enable-languages=ada, and cross-back gnattools build
> Huh, indeed - it's a host_module without bootstrap ... and libada is > a target_module not bootstrapped either. So we're indeed in a curious > situation where we have a bootstrap of Ada requiring a host Ada but > nothing of Ada is actually bootstrapped ... ;) Not sure what you mean by that, all the files needed to compile gnat1 and gnatbind (which includes most of the files under gcc/gcc/ada and all the files under gcc/gcc/ada/gcc-interface) are boostrapped. What's not bootstrapped are the Ada runtime (only a subset is as part of bootstrapping gnat1/gnatbind) and Ada tools. If we were starting from scratch, we would indeed likely have a different and simpler bootstrap scheme where: - we first build gnat1 only - then we build the Ada runtime (libgnat/libgnarl) - then we build Ada tools (gnatbind, gnatlink, gnatmake, etc...) and then we iterate again for stage2 and stage3 on the above using the previously built toolchain. Doing the above at this stage and given the complexity of the GCC Makefiles would require a lot of complex and error prone work, not sure it's worth the trouble and it would likely take a lot of time and effort to get all the combinations of possible builds (including all complex cases of "standard" cross and canadian cross builds) working. > Yeah, I expected that for non-bootstrap. And I somehow assumed it > was bootstrapped so I'd get gnattools and gnat1 not depending on the > host compiler libs. I guess we're lucky for gnat1 because it's written > in C? gnat1 is written mostly in Ada not in C (most of the Ada files under gcc/gcc/ada are used for gnat1). Arno
Re: not posted ada patch breaks ada build on alpha-linux-gnu
> r266136 broke the ada build on alpha-linux-gnu, filed as PR88191. I didn't > find this patch posted to gcc-patches. Thanks for the heads up. This is this change: [Ada] Update signal constants for GNU/Linux Add the signal SIGSYS and mark the glibc reserved real-time signals (32-34) as reserved rather than not maskable. 2018-11-14 Patrick Bernardi gcc/ada/ * libgnarl/a-intnam__linux.ads: Add SIGSYS. * libgnarl/s-linux__alpha.ads, libgnarl/s-linux__android.ads, libgnarl/s-linux__hppa.ads, libgnarl/s-linux__mips.ads, libgnarl/s-linux__riscv.ads, libgnarl/s-linux__sparc.ads, libgnarl/s-linux__x32.ads: Rename SIGLTHRRES, SIGLTHRCAN and SIGLTHRDBG to SIG32, SIG33 and SIG34 as their names are implementation specific. * libgnarl/s-osinte__linux.ads, libgnarl/s-linux.ads: Add SIGSYS. Move SIG32, SIG33 and SIG34 from the unmasked list to the reserved list. Pat, can you have a look? Matthias, can you suggest a suitable change since we don't have access to an alpha-linux setup?
Re: not posted ada patch breaks ada build on alpha-linux-gnu
> that fixes the build, taken from the sparc64 file. not sure if that is > appropriate. The patch looks good, you can go ahead and commit it. > --- gcc/ada/libgnarl/s-linux__alpha.ads (revision 266457) > +++ gcc/ada/libgnarl/s-linux__alpha.ads (working copy) > @@ -87,6 +87,7 @@ > SIGKILL: constant := 9; -- kill (cannot be caught or ignored) > SIGBUS : constant := 10; -- bus error > SIGSEGV: constant := 11; -- segmentation violation > + SIGSYS : constant := 12; -- bad system call > SIGPIPE: constant := 13; -- write on a pipe with no one to read it > SIGALRM: constant := 14; -- alarm clock > SIGTERM: constant := 15; -- software termination signal from kill > > The build continues, but then fails with: > > /home/packages/cross/9/p/gcc-cross-ports/gcc/build/./gcc/xgcc > -B/home/packages/cross/9/p/gcc-cross-ports/gcc/build/./gcc/ - > B/usr/alpha-linux-gnu/bin/ -B/usr/alpha-linux-gnu/lib/ -isystem > /usr/alpha-linux-gnu/include -isystem /usr/alpha-linux-gnu/ > sys-include -isystem > /home/packages/cross/9/p/gcc-cross-ports/gcc/build/sys-include-c > -g -O2 -W > -Wall -gnatpg -nostdi > nc -gnatn s-secsta.adb -o s-secsta.o > > raised STORAGE_ERROR : stack overflow or erroneous memory access This is definitely an unrelated issue. Arno
Re: [PATCH] [Ada] Make clockid_t type public on GNU/kFreeBSD
OK, thanks. > From: James Clarke > > Monotonic_Clock and RT_Resolution in the recently-added s-tpopmo.adb > call clock_gettime/clock_getres with the integral constants from OSC and > thus rely on clockid_t being an integral type, so we cannot hide it on > GNU/kFreeBSD. Instead, make the definition public to match all the other > implementations. > > gcc/ada > * libgnarl/s-osinte__kfreebsd-gnu.ads (clockid_t): Make type > definition public. > (CLOCK_REALTIME): Make value public. > --- > gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads | 8 ++-- > 1 file changed, 2 insertions(+), 6 deletions(-) > > diff --git a/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads > b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads > index 408187314..b60ffd2c0 100644 > --- a/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads > +++ b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads > @@ -206,9 +206,8 @@ package System.OS_Interface is > function nanosleep (rqtp, rmtp : access timespec) return int; > pragma Import (C, nanosleep, "nanosleep"); > > - type clockid_t is private; > - > - CLOCK_REALTIME : constant clockid_t; > + type clockid_t is new int; > + CLOCK_REALTIME : constant clockid_t := 0; > > function clock_gettime > (clock_id : clockid_t; > @@ -607,9 +606,6 @@ private > end record; > pragma Convention (C, timespec); > > - type clockid_t is new int; > - CLOCK_REALTIME : constant clockid_t := 0; > - > type pthread_attr_t is record >detachstate : int; >schedpolicy : int; > -- > 2.17.1 >
Re: [PATCH] [Ada] Make clockid_t type public on GNU/kFreeBSD
> I don't have commit access so could you please do so on my behalf? No, I won't be able to do that unfortunately. By the way do you have a copyright assignment in place? Arno
Re: [PATCH] [Ada] Make clockid_t type public on GNU/kFreeBSD
> checked in. Ok for the gcc-9 branch as well? Yes.
Re: r273212 - in /trunk/gcc/ada: ChangeLog Makefile...
> > 2019-07-08 Dmitriy Anisimkov > > > > gcc/ada/ > > > > * Makefile.rtl: Use g-sercom__linux.adb for all linuxes. > > ln: failed to create symbolic link 'rts/g-sercom.adb': File exists > make[7]: *** [/daten/riscv64/gcc/gcc-20190713/gcc/ada/Makefile.rtl:2676: > setup-rts] Error 1 > > Andreas. > > diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl > index 80ba46dd104..daee19a4ba5 100644 > --- a/gcc/ada/Makefile.rtl > +++ b/gcc/ada/Makefile.rtl > @@ -2460,7 +2460,6 @@ ifeq ($(strip $(filter-out riscv% linux%,$(target_cpu) > $(target_os))),) >s-tasinf.adbs-taspri.adss-tpopsp.adb - g-sercom.adbsystem.ads >TOOLS_TARGET_PAIRS = indepsw.adb
[Ada] clean ups in C runtime files
This change introduces a "STANDALONE" mode where the C files of the Ada
runtime do not have any dependency on GCC include files. This is
useful for rebuilding the Ada runtime in a sandbox where GCC include files
are not available.
Also a few clean ups along the way.
Tested on x86_64-pc-linux-gnu, committed on trunk.
2019-07-18 Arnaud Charlet
* Makefile.rtl, expect.c, env.c, aux-io.c, mkdir.c, initialize.c,
cstreams.c, raise.c, tracebak.c, adadecode.c, init.c, raise-gcc.c,
argv.c, adaint.c, adaint.h, ctrl_c.c, sysdep.c, rtinit.c, cio.c,
seh_init.c, exit.c, targext.c: Introduce a "STANDALONE" mode where C
runtime files do not have any dependency on GCC include files.
Remove unnecessary includes.
Remove remaining references to VMS in runtime C file.
* runtime.h: new File.
--
Index: expect.c
===
--- expect.c(revision 273575)
+++ expect.c(working copy)
@@ -29,14 +29,11 @@
* *
/
-#ifdef __alpha_vxworks
-#include "vxWorks.h"
-#endif
-
#ifdef IN_RTS
#define POSIX
-#include "tconfig.h"
-#include "tsystem.h"
+#include "runtime.h"
+#include
+
#else
#include "config.h"
#include "system.h"
Index: env.c
===
--- env.c (revision 273575)
+++ env.c (working copy)
@@ -30,15 +30,11 @@
/
#ifdef IN_RTS
-# include "tconfig.h"
-# include "tsystem.h"
+# include "runtime.h"
+# include
+# include
+# include
-# include
-# include
-# include
-# ifdef VMS
-# include
-# endif
/* We don't have libiberty, so use malloc. */
# define xmalloc(S) malloc (S)
#else /* IN_RTS */
@@ -109,89 +105,10 @@
return;
}
-/* VMS specific declarations for set_env_value. */
-
-#ifdef VMS
-
-typedef struct _ile3
-{
- unsigned short len, code;
- __char_ptr32 adr;
- __char_ptr32 retlen_adr;
-} ile_s;
-
-#endif
-
void
__gnat_setenv (char *name, char *value)
{
-#if defined (VMS)
- struct dsc$descriptor_s name_desc;
- $DESCRIPTOR (table_desc, "LNM$PROCESS");
- char *host_pathspec = value;
- char *copy_pathspec;
- int num_dirs_in_pathspec = 1;
- char *ptr;
- long status;
-
- name_desc.dsc$w_length = strlen (name);
- name_desc.dsc$b_dtype = DSC$K_DTYPE_T;
- name_desc.dsc$b_class = DSC$K_CLASS_S;
- name_desc.dsc$a_pointer = name; /* ??? Danger, not 64bit safe. */
-
- if (*host_pathspec == 0)
-/* deassign */
-{
- status = LIB$DELETE_LOGICAL (&name_desc, &table_desc);
- /* no need to check status; if the logical name is not
- defined, that's fine. */
- return;
-}
-
- ptr = host_pathspec;
- while (*ptr++)
-if (*ptr == ',')
- num_dirs_in_pathspec++;
-
- {
-int i, status;
-/* Alloca is guaranteed to be 32bit. */
-ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1));
-char *copy_pathspec = alloca (strlen (host_pathspec) + 1);
-char *curr, *next;
-
-strcpy (copy_pathspec, host_pathspec);
-curr = copy_pathspec;
-for (i = 0; i < num_dirs_in_pathspec; i++)
- {
- next = strchr (curr, ',');
- if (next == 0)
- next = strchr (curr, 0);
-
- *next = 0;
- ile_array[i].len = strlen (curr);
-
- /* Code 2 from lnmdef.h means it's a string. */
- ile_array[i].code = 2;
- ile_array[i].adr = curr;
-
- /* retlen_adr is ignored. */
- ile_array[i].retlen_adr = 0;
- curr = next + 1;
- }
-
-/* Terminating item must be zero. */
-ile_array[i].len = 0;
-ile_array[i].code = 0;
-ile_array[i].adr = 0;
-ile_array[i].retlen_adr = 0;
-
-status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array);
-if ((status & 1) != 1)
- LIB$SIGNAL (status);
- }
-
-#elif (defined (__vxworks) && defined (__RTP__)) || defined (__APPLE__)
+#if (defined (__vxworks) && defined (__RTP__)) || defined (__APPLE__)
setenv (name, value, 1);
#else
@@ -213,10 +130,7 @@
char **
__gnat_environ (void)
{
-#if defined (VMS) || defined (RTX)
- /* Not implemented */
- return NULL;
-#elif defined (__MINGW32__)
+#if defined (__MINGW32__)
return _environ;
#elif defined (__sun__)
extern char **_environ;
@@ -247,10 +161,7 @@
void __gnat_unsetenv (char *name)
{
-#if defined (VMS)
- /* Not implemented */
- return;
-#elif defined (__hpux__) || defined (__sun__) \
+#if defined (__hpux__) || defined (__sun__) \
|| (defined (__vxworks) && ! defined (__RTP__)) \
|| defined (_AIX) || defined (__Lynx__)
Re: [PATCH] PR ada/89583, GNAT.Sockets.Bind_Socket fails with IPv4 address
Simon, Thanks for the patch. We already have a fix pending for that in our tree that we will merge. Arno > On 4 Mar 2019, at 20:48, Simon Wright wrote: > > With GCC9, GNAT.Sockets includes support for IPv6. Sockaddr is an > Unchecked_Union, which now includes IPv6 fields, bringing the total possible > size to 28 bytes. The code in Bind_Socket currently calculates the length of > the struct sockaddr to be passed to bind(2) as this size, which (at any rate > on Darwin x86_64) results in failure (EINVAL). > > This patch provides the required length explicitly from the socket's family. > > Tested by rebuilding the compiler with --disable-bootstrap and re-running the > reproducer. > > gcc/ada/Changelog: > >2019-03-04 Simon Wright > >PR ada/89583 >* libgnat/g-socket.adb (Bind_Socket): Calculate Len (the significant > length of > the Sockaddr) using the Family of the Address parameter. > > >
Re: [ada, build] Fix make install-gcc-specs with empty GCC_SPEC_FILES
> When installing gcc 9.1.0 on Solaris 10 with CONFIG_SHELL=/bin/ksh, it > failed in the same way as originally fixed by > > https://gcc.gnu.org/ml/gcc-patches/2016-05/msg00087.html > > While the patch still is on the gcc-5 and gcc-6 branches, it has been > lost (inadvertently, I assume) on trunk before gcc-7 branched by r244367. > > I'd like to restore the fix, preferably on all of mainline and the > gcc-9, gcc-8, and gcc-7 branches. > > Tested with the gcc 9.1.0 release on i386-pc-solaris2.10 and > sparc-sun-solaris2.10. Ok? OK
Re: [ada, build] Avoid cp -p failures during Ada make install
> Tested on x86_64-pc-linux-gnu installing both to a local filesystem and > an NFSv3 filesystem. > > Ok for mainline (and the gcc-9 and gcc-8 branches eventually)? No, this is not OK. I'd rather keep the simple current logic and either stick to cp -p, or use a proper $(INSTALL_whatever) as done elsewhere rather than adding more kludges. Also, standard.ads.h is a valid file, so the reference shouldn't be removed. I'll add it to the repository, this was an oversight, thanks for noticing. Arno
Re: [ada, build] Avoid cp -p failures during Ada make install
> Also, standard.ads.h is a valid file, so the reference shouldn't be removed. > > I'll add it to the repository, this was an oversight, thanks for noticing. I've added it now. 2019-05-08 Arnaud Charlet * standard.ads.h: New file.
Re: [ada, build] Avoid cp -p failures during Ada make install
> > No, this is not OK.
> >
> > I'd rather keep the simple current logic and either stick to cp -p, or
> > use a proper $(INSTALL_whatever) as done elsewhere rather than adding more
> > kludges.
>
> how do you mean, `proper $(INSTALL_whatever)'?
Using e.g. INSTALL_DATA from configure.
> I've run the cp -p under strace, which shows
>
> fgetxattr(3, "system.posix_acl_access", 0x7fff96829fd0, 132) = -1 ENODATA (No
> data available)
> fstat(3, {st_mode=S_IFREG|0644, st_size=35368, ...}) = 0
> fsetxattr(4, "system.posix_acl_access",
> "\2\0\0\0\1\0\6\0\377\377\377\377\4\0\4\0\377\377\377\377
> \0\4\0\377\377\377\377", 28, 0) = -1 EOPNOTSUPP (Operation not supported)
>
> i.e. it tries to determine an extended attribute, is told there's none,
> tries to set that none on the destination and chokes if that doesn't
> work. Seems pretty insane to me.
>
> This is cp from coreutils 8.30 on Fedora 29, btw., not same ancient
> prehistoric software.
Did someone file a bug report there BTW?
Arno
Re: [PATCH] Don't DCE const/pure calls that can throw if cfg can't be altered (PR rtl-optimization/88870)
> > > PR rtl-optimization/88870 > > > * dce.c (deletable_insn_p): Never delete const/pure calls that can > > > throw if we can't alter the cfg or delete dead exceptions. > > > (mark_insn): Don't call find_call_stack_args for such calls. > > > > > > * gcc.dg/pr88870.c: New test. > > OK. Though I wonder if we want to continue to support > > -fnon-call-exceptions. With GCJ gone is there any value left in that > > capability? There's little doubt in my mind other parts of GCC are not > > -fnon-call-exception safe. > > AFAIK Ada and Go use -fnon-call-exceptions by default and heavily rely on > it. Agreed.
[Ada] fix gnatlib build on x32 runtime
This has been reported on https://github.com/mattgodbolt/compiler-explorer-image/issues/161 The failure has been introduced 2018-11-14 when updating the list of signals in s-linux*.ads files, s-linux__x32.ads was forgotten. Tested on x86_64-pc-linux-gnu, committed on trunk. 2019-02-06 Arnaud Charlet * libgnarl/s-linux__x32.ads: Resync list of signals with s-linux.ads Index: libgnarl/s-linux__x32.ads === --- libgnarl/s-linux__x32.ads (revision 268575) +++ libgnarl/s-linux__x32.ads (working copy) @@ -82,35 +82,36 @@ SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP: constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction - SIGABRT: constant := 6; -- used by abort, replace SIGIOT in the future + SIGABRT: constant := 6; -- used by abort, replace SIGIOT in the future SIGFPE : constant := 8; -- floating point exception SIGKILL: constant := 9; -- kill (cannot be caught or ignored) SIGBUS : constant := 7; -- bus error + SIGUSR1: constant := 10; -- user defined signal 1 SIGSEGV: constant := 11; -- segmentation violation + SIGUSR2: constant := 12; -- user defined signal 2 SIGPIPE: constant := 13; -- write on a pipe with no one to read it SIGALRM: constant := 14; -- alarm clock SIGTERM: constant := 15; -- software termination signal from kill - SIGUSR1: constant := 10; -- user defined signal 1 - SIGUSR2: constant := 12; -- user defined signal 2 + SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) SIGCLD : constant := 17; -- alias for SIGCHLD SIGCHLD: constant := 17; -- child status change - SIGPWR : constant := 30; -- power-fail restart - SIGWINCH : constant := 28; -- window size change - SIGURG : constant := 23; -- urgent condition on IO channel - SIGPOLL: constant := 29; -- pollable event occurred - SIGIO : constant := 29; -- I/O now possible (4.2 BSD) - SIGLOST: constant := 29; -- File lock lost SIGSTOP: constant := 19; -- stop (cannot be caught or ignored) SIGTSTP: constant := 20; -- user stop requested from tty SIGCONT: constant := 18; -- stopped process has been continued SIGTTIN: constant := 21; -- background tty read attempted SIGTTOU: constant := 22; -- background tty write attempted + SIGURG : constant := 23; -- urgent condition on IO channel + SIGXCPU: constant := 24; -- CPU time limit exceeded + SIGXFSZ: constant := 25; -- filesize limit exceeded SIGVTALRM : constant := 26; -- virtual timer expired SIGPROF: constant := 27; -- profiling timer expired - SIGXCPU: constant := 24; -- CPU time limit exceeded - SIGXFSZ: constant := 25; -- filesize limit exceeded - SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) - SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) + SIGWINCH : constant := 28; -- window size change + SIGPOLL: constant := 29; -- pollable event occurred + SIGIO : constant := 29; -- I/O now possible (4.2 BSD) + SIGLOST: constant := 29; -- File lock lost + SIGPWR : constant := 30; -- power-fail restart + SIGSYS : constant := 31; -- bad system call + SIGUNUSED : constant := 31; -- unused signal (mapped to SIGSYS) SIG32 : constant := 32; -- glibc internal signal SIG33 : constant := 33; -- glibc internal signal SIG34 : constant := 34; -- glibc internal signal
Re: [PATCH 1/4][Ada,DJGPP] Ada support for DJGPP
>>> * ada/adaint.c (__gnat_is_djgpp): define (1 for DJGPP host, 0 >>> otherwise). * ada/s-os_lib.ads (Is_Djgpp): import __gnat_is_djgpp as >>> constant. * ada/s-os_lib.adb (Normalize_Pathname): support DJGPP special >>> paths (/dev/*) for DJGPP hosts >> The patch does more than this though: > Updated ChangeLog entry: > > Subject: [PATCH 1/4] [DJGPP, Ada] File path handling for DJGPP host > > * ada/adaint.c (__gnat_is_djgpp): define (1 for DJGPP host, 0 otherwise). > * ada/s-os_lib.ads (Is_Djgpp): import __gnat_is_djgpp as constant. > * ada/s-os_lib.adb (Normalize_Pathname): support DJGPP special paths (/dev/*) > for DJGPP hosts, > (Normalize_Pathname): do not convert '/' to '\' for DJGPP hosts. > > >> >> @@ -2242,8 +2271,11 @@ package body System.OS_Lib is >>end File_Name_Conversion; >> -- Replace all '/' by Directory Separators (this is for Windows) >> + -- No need to do that however for DJGPP >> - if Directory_Separator /= '/' then >> + if Directory_Separator /= '/' >> +and then Is_Djgpp = 0 >> + then >> for Index in 1 .. End_Path loop >> if Path_Buffer (Index) = '/' then >> Path_Buffer (Index) := Directory_Separator; >> >> Why does DJGPP need to be special-cased here? In order to disable some >> further transformation downstream? Could DIR_SEPARATOR be just '/'? >> > Both '/' and '\' must be supported as directory separators. So > DIR_SEPARATOR='/' is not OK in this case. > > Unconditional converting '/' to '\' in case of DJGPP native build causes > gnatmake to break. Retested it today it with gcc-6.1.0. The problem is that > special directory name /dev/env/DJDIR is used as prefix for DJGPP (it > resolves to $DJDIR in execution time) This part of the patch is really too kludgy and too intrusive, you will need to find find a less intrusive way to address this djgpp special case. Arno
Re: [PATCH 2/4][Ada,DJGPP] Ada support for DJGPP
> This patch (2nd of 4) includes various changes to Ada related C files > required for DJGPP support > > ChangeLog entry: > > 2016-07-30 Andris Pavenis > > * ada/ctrl_c.c: Do not use macro SA_RESTART for DJGPP. > > * ada/gsocket.h: Do not support sockets for DJGPP. > > * ada/init.c (timestruct_t): Define for DJGPP. > (nanosleep): Implement for DJGPP using usleep(). Why do you need to define nanosleep() here? I suspect this is no longer needed. If it is, would be good to know why. Arno
Re: [PATCH 3/4][Ada,DJGPP] Ada support for DJGPP
> 2016-07-30 Andris Pavenis > > * ada/gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS): Define for > DJGPP target > (EH_MECHANISM): Define to -gcc for DJGPP > * ada/system-djgpp.ads: New file > > Andris > +++ b/gcc/ada/system-djgpp.ads > @@ -0,0 +1,148 @@ > +-- > > +-- > -- > +--GNAT RUN-TIME COMPONENTS > -- > +-- > -- > +-- S Y S T E M > -- > +-- > -- > +-- S p e c > -- > +--(DJGPP Version) -- Wrong formatting here. > +-- > -- > +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. > -- Wrong copyright here.
Re: [Patch] Disable text mode translation in ada for Cygwin
> > Text mode translation should not be done for Cygwin, especially since it > > does not > > support unicode setmode calls. This also fixes ada builds for Cygwin. > > > > OK for trunk? > > Ping? Can you send the link to your original submission for easy retrieval? Arno
Re: Implement -Wimplicit-fallthrough (take 3)
> > > > Does this warning make sense if !(lang_GNU_C() || lang_GNU_CXX()) ? > > > > > > I don't think so, it's meant for C/C++ only. I added a better check. > > > > Well, maybe the warning could also work for ObjC and ObjC++, but since I > > haven't included any testcases for these languages so far, maybe better > > to > > restrict it for C and C++ only. > > IMHO it should be also on for ObjC and ObjC++, even if there is no test > coverage (though, it would be good to add some eventually). > > > Go switch statements look very similar to C/C++ switches, but they don't > > fall through, so the warning would be pointless. No idea about Fortran and > > Ada. > > Go don't fall through by default, but there is fallthrough keyword for > falling through. And Fortran SELECT CASE doesn't fall through. Ada never falls through. Arno
Re: [Patch] Disable text mode translation in ada for Cygwin
Patch is OK
Re: [PATCH 2/4][Ada,DJGPP] Ada support for DJGPP
> -#if defined (__MINGW32__) > +#if defined (__DJGPP__) > + > +/* FIXME: this is draft version only. Fix me if that is not correct */ > +/*or not complete (AP) */ This FIXME needs to be addressed. The rest of the patch is OK. Arno
Re: [PATCH 3/4][Ada,DJGPP] Ada support for DJGPP
Which exception handling mechanism is used by the DJGPP port? Is it (GCC) SJLJ? Arno
Re: [PATCH 3/4][Ada,DJGPP] Ada support for DJGPP
> On 08/25/2016 12:46 PM, Arnaud Charlet wrote: > >Which exception handling mechanism is used by the DJGPP port? > >Is it (GCC) SJLJ? > No. Updated to set ZCX_By_Default := true for DJGPP. Well I'm confused now. How could this work before? In other words, has the target runtime been tested/used by anyone? Arno
Re: [PATCH 4/4][Ada,DJGPP] Ada support for DJGPP
> >This last patch (4/4) contains DJGPP related changes to adaint.c
> >(except one which belongs to patch 1/4).
This patch is quite intrusive. Are all these changes really needed?
> char
> __gnat_get_default_identifier_character_set (void)
> {
> +#if defined (__DJGPP__)
> + return 'p';
> +#else
>return '1';
> +#endif
> }
Why is this needed?
> -#elif defined (_WIN32)
> +#elif defined (__DJGPP__) || defined (_WIN32)
>/* args[0] must be quotes as it could contain a full pathname with spaces
>*/
>char *args_0 = args[0];
>args[0] = (char *)xmalloc (strlen (args_0) + 3);
> @@ -2606,6 +2630,12 @@ __gnat_portable_no_block_spawn (char *args[]
> ATTRIBUTE_UNUSED)
>/* Not supported. */
>return -1;
>
> +#elif defined(__DJGPP__)
> + if (spawnvp (P_WAIT, args[0], args) != 0)
> +return -1;
> + else
> +return 0;
> +
> #elif defined (_WIN32)
>
>HANDLE h = NULL;
> @@ -2649,6 +2679,7 @@ __gnat_portable_wait (int *process_status)
>
>pid = win32_wait (&status);
>
> +#elif defined (__DJGPP__)
> #else
You can't add an empty #elif without explaining it with a proper
comment.
Arno
Re: [PATCH 2/4][Ada,DJGPP] Ada support for DJGPP
This patch is OK > From 83fe70a17d811ebdec7ca70509e3c2521657d8f2 Mon Sep 17 00:00:00 2001 > From: Andris Pavenis > Date: Sun, 28 Aug 2016 08:02:11 +0300 > Subject: [PATCH 2/4] [DJGPP, Ada] DJGPP support > > * ada/ctrl_c.c: Do not use macro SA_RESTART for DJGPP. > > * ada/gsocket.h: Do not support sockets for DJGPP. > > * ada/init.c (__gnat_install_handler): Implememt for DJGPP > > * ada/sysdep.c: Include for DJGPP > (_setmode): Define to setmode for DJGPP > (__gnat_set_mode): Add implementation for DJGPP > (__gnat_localtime_tzoff): Use localtime_r for DJGPP > > * ada/terminals.c: Add DJGPP to list of unsupported platforms. > > * ada/env.c (__gnat_clearenv): use _gnat_unsetenv on all entries for
Re: [PATCH 3/4][Ada,DJGPP] Ada support for DJGPP
> GCC Ada compiler itself uses exceptions. Yes, but the bootstrap doesn't use system-dgjpp.ads, it uses the generic system.ads which uses front-end (GNAT) SJLJ, hence my question. Your answer isn't very reassuring. Arno
Re: [Patch] Disable text mode translation in ada for Cygwin
> Text mode translation should not be done for Cygwin, especially since it > does not > support unicode setmode calls. This also fixes ada builds for Cygwin. > > OK for trunk? OK, thanks. > gcc/ada/ChangeLog: > * sysdep.c (__gnat_set_binary_mode, __gnat_set_text_mode, > __gnat_set_mode): Disable text mode translation, Cygwin should > follow *Nix behavior. This also fixes build failures on Cywgin.
Re: [PATCH] Fix PR ada/71358
> This fixes a minor problem where GNAT.Command_Line.Getopt raises CE if > there are in fact no program-specified options (only the > internally-supplied -h, --help are meant to be available). > > Tested on GCC 6.1.0, x86_64-apple-darwin15. > > If OK, can someone commit it (I can't). > > gcc/ada/Changelog: > > 2016-05-31 Simon Wright > > PR ada/71358 > * g-comlin.adb: bump copyright year. > (Display_Section_Help): don't deference Config.Switches if > it's null. > (Getopt): likewise. Patch is OK. Arno
[Ada] Fix handling of separate units in GNATprove cross references
The collect of cross references for computing effects of subprograms in GNATprove was done incorrectly in the case of separate units. This is now fixed, by bypassing subunits when computing the unit of interest for both scopes and cross references. Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-14 Yannick Moy * lib-xref-spark_specific.adb (Add_SPARK_File): Do not traverse subunits directly, as they are already traversed as part of the top-level unit to which they belong. (Add_SPARK_Xrefs): Add assertions to ensure correct sorting. (Generate_Dereference): Use unique definition place for special variable __HEAP, to ensure correct sorting of references. * lib-xref.adb (Generate_Reference): Use top-level unit in case of subunits. * lib.adb, lib.ads (Get_Top_Level_Code_Unit): New functions that compute the top-level code unit for a source location of AST node, that go past subunits. Index: lib.adb === --- lib.adb (revision 237429) +++ lib.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -68,9 +68,12 @@ function Get_Code_Or_Source_Unit (S: Source_Ptr; - Unwind_Instances : Boolean) return Unit_Number_Type; - -- Common code for Get_Code_Unit (get unit of instantiation for location) - -- and Get_Source_Unit (get unit of template for location). + Unwind_Instances : Boolean; + Unwind_Subunits : Boolean) return Unit_Number_Type; + -- Common code for Get_Code_Unit (get unit of instantiation for + -- location) Get_Source_Unit (get unit of template for location) and + -- Get_Top_Level_Code_Unit (same as Get_Code_Unit but not stopping at + -- subunits). -- Access Functions for Unit Table Fields -- @@ -573,7 +576,8 @@ function Get_Code_Or_Source_Unit (S: Source_Ptr; - Unwind_Instances : Boolean) return Unit_Number_Type + Unwind_Instances : Boolean; + Unwind_Subunits : Boolean) return Unit_Number_Type is begin -- Search table unless we have No_Location, which can happen if the @@ -584,6 +588,7 @@ declare Source_File : Source_File_Index; Source_Unit : Unit_Number_Type; +Unit_Node : Node_Id; begin Source_File := Get_Source_File_Index (S); @@ -596,6 +601,21 @@ Source_Unit := Unit (Source_File); +if Unwind_Subunits then + Unit_Node := Unit (Cunit (Source_Unit)); + + while Nkind (Unit_Node) = N_Subunit + and then Present (Corresponding_Stub (Unit_Node)) + loop + Source_Unit := +Get_Code_Or_Source_Unit + (Sloc (Corresponding_Stub (Unit_Node)), + Unwind_Instances => Unwind_Instances, + Unwind_Subunits => Unwind_Subunits); + Unit_Node := Unit (Cunit (Source_Unit)); + end loop; +end if; + if Source_Unit /= No_Unit then return Source_Unit; end if; @@ -616,7 +636,7 @@ function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is begin return Get_Code_Or_Source_Unit (Top_Level_Location (S), -Unwind_Instances => False); +Unwind_Instances => False, Unwind_Subunits => False); end Get_Code_Unit; function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is @@ -691,7 +711,8 @@ function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is begin - return Get_Code_Or_Source_Unit (S, Unwind_Instances => True); + return Get_Code_Or_Source_Unit (S, +Unwind_Instances => True, Unwind_Subunits => False); end Get_Source_Unit; function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is @@ -699,6 +720,22 @@ return Get_Source_Unit (Sloc (N)); end Get_Source_Unit; + - + -- Get_Top_Level_Code_Unit -- + - + + function Get_Top_Level_Code_Unit (S : Source_Ptr) return Unit_Number_Type is + begin + return Get_Code_Or_Source_Unit (Top_Level_Location (S),
[Ada] Missing error on formal package
This patch fixes an omission in the analysis of formal package declarations. Actuals in the instance are properly rejected if their name does not correspond to any of the actuals, and there are box associations for existing formals. Compiling gcc -c c_test.ads must yield generic_p_level_2.ads:7:53: unmatched actual "C_Test" generic_p_level_2.ads:7:53: in instantiation of "Generic_P_Level_1" declared at generic_p_level_1.ads:5 --- -- generic type Param is (<>); package Generic_P_Level_1 is Var : Integer; end; -- with Generic_P_Level_1; generic with package P_Level_1 is new Generic_P_Level_1 (C_Test => 2, Param => <>); package Generic_P_Level_2 is Var : Integer; end; with Generic_P_Level_1; with Generic_P_Level_2; package test is package P_Level_1 is new Generic_P_Level_1(Integer); package P_Level_2 is new Generic_P_Level_2(P_Level_1); end; Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-14 Ed Schonberg * sem_ch12.adb (Analyze_Associations): An actual parameter with a box must be included in the count of actuals, to detect possible superfluous named actuals that do not match any of the formals of the generic unit in a formal package declaration. Index: sem_ch12.adb === --- sem_ch12.adb(revision 237432) +++ sem_ch12.adb(working copy) @@ -1496,10 +1496,13 @@ -- A named association may lack an actual parameter, if it was -- introduced for a default subprogram that turns out to be local - -- to the outer instantiation. + -- to the outer instantiation. If it has a box association it must + -- correspond to some formal in the generic. if Nkind (Named) /= N_Others_Choice - and then Present (Explicit_Generic_Actual_Parameter (Named)) + and then + (Present (Explicit_Generic_Actual_Parameter (Named)) + or else Box_Present (Named)) then Num_Actuals := Num_Actuals + 1; end if;
[Ada] Improve error message on Extensions_Visible
This patch changes the formatting of errors related to the pragma
Extensions_Visible so as not to suggest Extensions_Visible applies to a formal
parameters instead of a subprogram when SPARK RM 6.1.7(3) is violated. In
addition, a small change to sem_prag was made to make the printing of boolean
values consistent accross all error messages.
-- Source --
-- ext_vis_error.ads
package Ext_Vis_Error with SPARK_Mode is
type Root is tagged record
Comp_1 : Integer := 1;
end record;
type Child is new Root with record
Comp_2 : Integer := 2;
end record;
procedure Proc_1 (Obj_C : Child) with Extensions_Visible => False;
procedure Proc_2 (Obj_C : Child) with Extensions_Visible => True;
end Ext_Vis_Error;
-- ext_vis_error.adb
package body Ext_Vis_Error with SPARK_Mode is
procedure Proc_1 (Obj_C : Child) is
Error_1 : constant Root'Class := Obj_C;
Error_2 : constant Root'Class := Root'Class (Obj_C);
begin
Proc_2 (Obj_C);
end Proc_1;
procedure Proc_2 (Obj_C : Child) is begin null; end Proc_2;
end Ext_Vis_Error;
-- Compilation and output --
gcc -c ext_vis_error.adb
gcc -c ext_vis_error.adb -gnatd.F
ext_vis_error.adb:3:40: formal parameter cannot be implicitly converted to
class-wide type when Extensions_Visible is False
ext_vis_error.adb:4:52: formal parameter cannot be converted to class-wide
type when Extensions_Visible is False
ext_vis_error.adb:7:15: formal parameter cannot act as actual parameter when
Extensions_Visible is False
ext_vis_error.adb:7:15: subprogram "Proc_2" has Extensions_Visible True
ext_vis_error.adb:3:40: formal parameter cannot be implicitly converted to
class-wide type when Extensions_Visible is False
ext_vis_error.adb:4:52: formal parameter cannot be converted to class-wide
type when Extensions_Visible is False
ext_vis_error.adb:7:15: formal parameter cannot act as actual parameter when
Extensions_Visible is False
ext_vis_error.adb:7:15: subprogram "Proc_2" has Extensions_Visible True
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-14 Justin Squirek
* sem_ch3.adb (Analyze_Object_Declaration): Fix formatting
of error output related to SPARK RM 6.1.7(3) and pragma
Extensions_Visible.
* sem_ch4.adb (Analyze_Type_Conversion): Fix formatting of error
output related to SPARK RM 6.1.7(3) and pragma Extensions_Visible.
* sem_prag.adb (Analyze_Pragma): Fix formatting of error output
related to SPARK RM 7.1.2(15) and pragma Volatile_Function
so that the values True and False are no longer surrounded by
double quotes.
* sem_res.adb (Resolve_Actuals): Fix formatting of error output
related to SPARK RM 6.1.7(3) and pragma Extensions_Visible.
Index: sem_ch3.adb
===
--- sem_ch3.adb (revision 237429)
+++ sem_ch3.adb (working copy)
@@ -3796,8 +3796,8 @@
and then Is_EVF_Expression (E)
then
Error_Msg_N
- ("formal parameter with Extensions_Visible False cannot be "
- & "implicitly converted to class-wide type", E);
+ ("formal parameter cannot be implicitly converted to "
+ & "class-wide type when Extensions_Visible is False", E);
end if;
end if;
Index: sem_prag.adb
===
--- sem_prag.adb(revision 237429)
+++ sem_prag.adb(working copy)
@@ -22821,12 +22821,12 @@
Error_Msg_Sloc := Sloc (Over_Id);
Error_Msg_N
- ("\& declared # with Volatile_Function value `False`",
+ ("\& declared # with Volatile_Function value False",
Spec_Id);
Error_Msg_Sloc := Sloc (Spec_Id);
Error_Msg_N
- ("\overridden # with Volatile_Function value `True`",
+ ("\overridden # with Volatile_Function value True",
Spec_Id);
end if;
Index: sem_res.adb
===
--- sem_res.adb (revision 237432)
+++ sem_res.adb (working copy)
@@ -4596,8 +4596,8 @@
Extensions_Visible_True
then
Error_Msg_N
- ("formal parameter with Extensions_Visible False cannot act "
- & "as actual parameter", A);
+ ("formal parameter cannot act as actual parameter when "
+ & "Extensions_Visible is False", A);
Error_Msg_NE
("\subprogram & has Extensions_Visible True", A, Nam);
end if;
Index: sem_ch4.adb
===
--- sem_ch4.adb (revision 237429)
+++ sem_ch4.adb (working copy)
@@ -5246,8 +5246,8 @@
and then I
[Ada] Remove useless calls to invariant procedures
This patch removes a redundant call to a generated invariant procedure when Assertion_Policy is ignored. The following must execute quietly: gcc -c -gnatn -O3 -S ut.adb grep "invariant" ut.s --- pragma Assertion_Policy (Ignore); --- private with TI; package UT is type T2 is limited private; procedure Set ( X : in out T2; J : in Integer ); private type T2 is limited record X : TI.T; end record; end; package body UT is procedure Set ( X : in out T2; J : in Integer ) is begin TI.Set (X.X, J); end; end; package TI is type T is limited private; procedure Set ( X : in out T; J : in Integer ); private type T is limited record I : Integer := 0; J : Integer := Integer'Last; end record with Type_Invariant => T.I < T.J; end; package body TI is procedure Set ( X : in out T; J : in Integer ) is begin X.J := J; end; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-14 Ed Schonberg * contracts.adb (Has_Null_Body): Move to sem_util, for general availability. * sem_util.ads, sem_util.adb (Has_Null_Body): Predicate to determine when an internal procedure created for some assertion checking (e.g. type invariant) is a null procedure. Used to eliminate redundant calls to such procedures when they apply to components of composite types. * exp_ch3.adb (Build_Component_Invariant_Call): Do not add call if invariant procedure has a null body. Index: sem_util.adb === --- sem_util.adb(revision 237434) +++ sem_util.adb(working copy) @@ -9581,6 +9581,65 @@ and then Nkind (Node (First_Elmt (Constits))) /= N_Null; end Has_Non_Null_Refinement; + --- + -- Has_Null_Body -- + --- + + function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is + Body_Id : Entity_Id; + Decl: Node_Id; + Spec: Node_Id; + Stmt1 : Node_Id; + Stmt2 : Node_Id; + + begin + Spec := Parent (Proc_Id); + Decl := Parent (Spec); + + -- Retrieve the entity of the procedure body (e.g. invariant proc). + + if Nkind (Spec) = N_Procedure_Specification +and then Nkind (Decl) = N_Subprogram_Declaration + then + Body_Id := Corresponding_Body (Decl); + + -- The body acts as a spec + + else + Body_Id := Proc_Id; + end if; + + -- The body will be generated later + + if No (Body_Id) then + return False; + end if; + + Spec := Parent (Body_Id); + Decl := Parent (Spec); + + pragma Assert +(Nkind (Spec) = N_Procedure_Specification + and then Nkind (Decl) = N_Subprogram_Body); + + Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); + + -- Look for a null statement followed by an optional return + -- statement. + + if Nkind (Stmt1) = N_Null_Statement then + Stmt2 := Next (Stmt1); + + if Present (Stmt2) then +return Nkind (Stmt2) = N_Simple_Return_Statement; + else +return True; + end if; + end if; + + return False; + end Has_Null_Body; + -- Has_Null_Exclusion -- Index: sem_util.ads === --- sem_util.ads(revision 237434) +++ sem_util.ads(working copy) @@ -1103,6 +1103,11 @@ -- as expressed in pragma Refined_State. This function does not take into -- account the visible refinement region of abstract state Id. + function Has_Null_Body (Proc_Id : Entity_Id) return Boolean; + -- Determine whether the body of procedure Proc_Id contains a sole + -- null statement, possibly followed by an optional return. Used to + -- optimize useless calls to assertion checks. + function Has_Null_Exclusion (N : Node_Id) return Boolean; -- Determine whether node N has a null exclusion Index: contracts.adb === --- contracts.adb (revision 237429) +++ contracts.adb (working copy) @@ -1452,73 +1452,10 @@ - function Invariant_Checks_OK (Typ : Entity_Id) return Boolean is -function Has_Null_Body (Proc_Id : Entity_Id) return Boolean; --- Determine whether the body of procedure Proc_Id contains a sole --- null statement, possibly followed by an optional return. - function Has_Public_Visibility_Of_Subprogram return Boolean; -- Determine whether type Typ has public visibility of subprogram -- Subp_Id. ---- --- Has_Null_Body -- ---- - -function Has_Nu
[Ada] Exclude private protected type defined in the runtime for restrictions
This is preliminary work to allow an implementation change in the runtime. Does not affect users. Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-16 Tristan Gingold * einfo.ads (Has_Protected): Clarify comment. * sem_ch9.adb (Analyze_Protected_Type_Declaration): Do not consider private protected types declared in the runtime for the No_Local_Protected_Types restriction. Index: sem_ch9.adb === --- sem_ch9.adb (revision 237439) +++ sem_ch9.adb (working copy) @@ -32,8 +32,10 @@ with Errout;use Errout; with Exp_Ch9; use Exp_Ch9; with Elists;use Elists; +with Fname; use Fname; with Freeze;use Freeze; with Layout;use Layout; +with Lib; use Lib; with Lib.Xref; use Lib.Xref; with Namet; use Namet; with Nlists;use Nlists; @@ -1985,12 +1987,27 @@ Set_Ekind (T, E_Protected_Type); Set_Is_First_Subtype (T, True); - Set_Has_Protected (T, True); Init_Size_Align(T); Set_Etype (T, T); Set_Has_Delayed_Freeze (T, True); Set_Stored_Constraint (T, No_Elist); + -- Mark this type as a protected type for the sake of restrictions, + -- unless the protected type is declared in a private part of a package + -- of the runtime. With this exception, the Suspension_Object from + -- Ada.Synchronous_Task_Control can be implemented using a protected + -- without triggering violations of No_Local_Protected_Objects when the + -- user locally declares such an object. This may look like a trick but + -- the user doesn't have to know how Suspension_Object is implemented. + + if In_Private_Part (Current_Scope) +and then Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)) + then + Set_Has_Protected (T, False); + else + Set_Has_Protected (T, True); + end if; + -- Set the SPARK_Mode from the current context (may be overwritten later -- with an explicit pragma). Index: einfo.ads === --- einfo.ads (revision 237436) +++ einfo.ads (working copy) @@ -1936,10 +1936,10 @@ --Has_Protected (Flag271) [base type only] -- Defined in all type entities. Set on protected types themselves, and -- also (recursively) on any composite type which has a component for --- which Has_Protected is set. The meaning is that an allocator for --- or declaration of such an object must create the required protected --- objects. Note: the flag is not set on access types, even if they --- designate an object that Has_Protected. +-- which Has_Protected is set, unless the protected type is declared in +-- the private part of an internal unit. The meaning is that restrictions +-- for protected types apply to this type. Note: the flag is not set on +-- access types, even if they designate an object that Has_Protected. --Has_Qualified_Name (Flag161) -- Defined in all entities. Set if the name in the Chars field has
[Ada] Improve the support of No_Use_Entity
This patch performs a code cleanup of the previous implementation and extends
its functionality to facilitate the use of this restriction with entities of
the Ada83 package Text_IO. For example:
pragma Restrictions (No_Use_Of_Entity => Text_IO.Put_Line);
with Text_IO; use Text_IO;
procedure Restrict is
begin
Put ("Hello");
Put_Line ("Hello_World!"); -- Restriction failed
Text_IO.Put ("Hello");
Text_IO.Put_Line ("Hello_World!"); -- Restriction failed
end;
Command: gcc -c restrict.adb
Output:
restrict.adb:7:04: reference to "Put_Line" violates restriction
No_Use_Of_Entity at line 1
restrict.adb:10:11: reference to "Text_IO.Put_Line" violates restriction
No_Use_Of_Entity at line 1
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-16 Javier Miranda
* restrict.adb (Check_Restriction_No_Use_Of_Entity): Avoid
never-ending loop, code cleanup; adding also support for Text_IO.
* sem_ch8.adb (Find_Expanded_Name): Invoke
Check_Restriction_No_Use_Entity.
Index: restrict.adb
===
--- restrict.adb(revision 237429)
+++ restrict.adb(working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -759,9 +759,16 @@
Ent := Entity (N);
Expr := NE_Ent.Entity;
loop
- -- Here if at outer level of entity name in reference
+ -- Here if at outer level of entity name in reference (handle
+ -- also the direct use of Text_IO in the pragma). For example:
+ -- pragma Restrictions (No_Use_Of_Entity => Text_IO.Put);
- if Scope (Ent) = Standard_Standard then
+ if Scope (Ent) = Standard_Standard
+ or else (Nkind (Expr) = N_Identifier
+ and then Chars (Ent) = Name_Text_IO
+ and then Chars (Scope (Ent)) = Name_Ada
+ and then Scope (Scope (Ent)) = Standard_Standard)
+ then
if Nkind_In (Expr, N_Identifier, N_Operator_Symbol)
and then Chars (Ent) = Chars (Expr)
then
@@ -774,22 +781,19 @@
return;
else
- goto Continue;
+ exit;
end if;
-- Here if at outer level of entity name in table
elsif Nkind_In (Expr, N_Identifier, N_Operator_Symbol) then
- goto Continue;
+ exit;
-- Here if neither at the outer level
else
pragma Assert (Nkind (Expr) = N_Selected_Component);
-
- if Chars (Selector_Name (Expr)) /= Chars (Ent) then
- goto Continue;
- end if;
+ exit when Chars (Selector_Name (Expr)) /= Chars (Ent);
end if;
-- Move up a level
@@ -800,10 +804,6 @@
end loop;
Expr := Prefix (Expr);
-
- -- Entry did not match
-
- <> null;
end loop;
end;
end loop;
Index: sem_ch12.adb
===
--- sem_ch12.adb(revision 237437)
+++ sem_ch12.adb(working copy)
@@ -1112,7 +1112,7 @@
-- Find actual that corresponds to a given a formal parameter. If the
-- actuals are positional, return the next one, if any. If the actuals
-- are named, scan the parameter associations to find the right one.
- -- A_F is the corresponding entity in the analyzed generic,which is
+ -- A_F is the corresponding entity in the analyzed generic, which is
-- placed on the selector name for ASIS use.
--
-- In Ada 2005, a named association may be given with a box, in which
@@ -1257,7 +1257,7 @@
elsif No (Selector_Name (Actual)) then
Found_Assoc := Actual;
-Act := Explicit_Generic_Actual_Parameter (Actual);
+Act := Explicit_Generic_Actual_Parameter (Actual);
Num_Matched := Num_Matched + 1;
Next (Actual);
@@ -1271,12 +1271,17 @@
Prev:= Empty;
while Presen
[Ada] Warn on buffer overrun with complex overlay
This change improves the warning issued for buffer overruns caused by overlays where the underlying object is too small, by taking into account the offset of the overlaid object from the first bit of the underlying object. The effect is visible on the following package: 1. with Interfaces; use Interfaces; 2. 3. package P is 4. 5. type Arr1 is array (Positive range <>) of Unsigned_16; 6. 7. type Rec1 is record 8. I : Integer; 9. A : Arr1 (1 .. 4); 10. end record; 11. 12. type Arr2 is array (Positive range <>) of Rec1; 13. 14. type Rec2 is record 15. I : Integer; 16. A : Arr2 (1 .. 2); 17. end record; 18. 19. R : Rec2; 20. 21. Obj1 : Arr1 (1 .. 13); 22. for Obj1'Address use R.A(1).I'Address; -- warning | >>> warning: "Obj1" overlays smaller object >>> warning: program execution may be erroneous >>> warning: size of "Obj1" is 208 >>> warning: size of "R" is 224 >>> warning: and offset of "Obj1" is 32 23. 24. Obj2 : Arr1 (1 .. 7); 25. for Obj2'Address use R.A(2).I'Address; -- warning | >>> warning: "Obj2" overlays smaller object >>> warning: program execution may be erroneous >>> warning: size of "Obj2" is 112 >>> warning: size of "R" is 224 >>> warning: and offset of "Obj2" is 128 26. 27. Obj3 : Arr1 (1 .. 10); 28. for Obj3'Address use R.A(1).A(2)'Address; -- warning | >>> warning: "Obj3" overlays smaller object >>> warning: program execution may be erroneous >>> warning: size of "Obj3" is 160 >>> warning: size of "R" is 224 >>> warning: and offset of "Obj3" is 80 29. 30. Obj4 : Arr1 (1 .. 2); 31. for Obj4'Address use R.A(2).A(4)'Address; -- warning | >>> warning: "Obj4" overlays smaller object >>> warning: program execution may be erroneous >>> warning: size of "Obj4" is 32 >>> warning: size of "R" is 224 >>> warning: and offset of "Obj4" is 208 32. 33. Obj5 : Unsigned_16; 34. for Obj5'Address use R.A(2).A(4)'Address; -- no warning 35. 36. end P; Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-16 Eric Botcazou * sem_util.ads (Indexed_Component_Bit_Offset): Declare. * sem_util.adb (Indexed_Component_Bit_Offset): New function returning the offset of an indexed component. (Has_Compatible_Alignment_Internal): Call it. * sem_ch13.adb (Offset_Value): New function returning the offset of an Address attribute reference from the underlying entity. (Validate_Address_Clauses): Call it and take the offset into account for the size warning. Index: sem_util.adb === --- sem_util.adb(revision 237510) +++ sem_util.adb(working copy) @@ -8780,7 +8780,6 @@ elsif Nkind (Expr) = N_Indexed_Component then declare Typ : constant Entity_Id := Etype (Prefix (Expr)); - Ind : constant Node_Id := First_Index (Typ); begin -- Packing generates unknown alignment if layout is not done @@ -8789,22 +8788,12 @@ Set_Result (Unknown); end if; - -- Check prefix and component offset + -- Check prefix and component offset (or at least size) Check_Prefix; - Offs := Component_Size (Typ); - - -- Small optimization: compute the full offset when possible - - if Offs /= No_Uint - and then Offs > Uint_0 - and then Present (Ind) - and then Nkind (Ind) = N_Range - and then Compile_Time_Known_Value (Low_Bound (Ind)) - and then Compile_Time_Known_Value (First (Expressions (Expr))) - then - Offs := Offs * (Expr_Value (First (Expressions (Expr))) -- Expr_Value (Low_Bound ((Ind; + Offs := Indexed_Component_Bit_Offset (Expr); + if Offs = No_Uint then + Offs := Component_Size (Typ); end if; end; end if; @@ -11064,6 +11053,59 @@ return Empty; end Incomplete_Or_Partial_View; + -- + -- Indexed_Component_Bit_Offset -- + -- + + function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is + Exp : constant Node_Id := First (Expressions (N)); + Typ : constant Entity_Id := Etype (Prefix (N)); + Off : constant Uint := Component_Size (Typ); + Ind : Node_Id; + + begin + -- Return early if the component size is not known or variable + + if Off
[Ada] Avoid anonymous array object for aggregates with qualified expressions
This patch enhances the memory usage of object declarations initialized by a qualified array aggregate. Previously, as per RM 4.3(5), an anonymous object was created to capture the value of the array aggregate, effectively doubling the memory consumption. The changes above remove the anonymous object declaration and instead ignore the qualified expression. As noted in the comments this is allowed due to RM 7.6(17 1/3). -- Source -- -- pack.adb procedure Pack is type Rec is record I : Integer; SI : Short_Integer; B : Boolean; end record; type Arr is array (1 .. 3, 0 .. 255) of Rec; Obj_1 : Arr := Arr'(others => (others => Rec'(0, 0, False))); begin null; end Pack; -- Compilation and output -- gnatmake -g -f -gnatD pack.adb grep "obj_1[]*:[a-z_]*;" pack.adb.dg obj_1 : pack__arr; Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-16 Justin Squirek * sem_ch3.adb (Analyze_Object_Declaration): Add a missing check for optimized aggregate arrays with qualified expressions. * exp_aggr.adb (Expand_Array_Aggregate): Fix block and conditional statement in charge of deciding whether to perform in-place expansion. Specifically, use Parent_Node to jump over the qualified expression to the object declaration node. Also, a check has been inserted to skip the optimization if SPARK 2005 is being used in strict adherence to RM 4.3(5). Index: sem_ch3.adb === --- sem_ch3.adb (revision 237439) +++ sem_ch3.adb (working copy) @@ -3471,7 +3471,7 @@ -- In case of aggregates we must also take care of the correct -- initialization of nested aggregates bug this is done at the - -- point of the analysis of the aggregate (see sem_aggr.adb). + -- point of the analysis of the aggregate (see sem_aggr.adb) ??? if Present (Expression (N)) and then Nkind (Expression (N)) = N_Aggregate @@ -4038,7 +4038,10 @@ elsif Is_Array_Type (T) and then No_Initialization (N) -and then Nkind (Original_Node (E)) = N_Aggregate +and then (Nkind (Original_Node (E)) = N_Aggregate + or else (Nkind (Original_Node (E)) = N_Qualified_Expression + and then Nkind (Original_Node (Expression +(Original_Node (E = N_Aggregate)) then if not Is_Entity_Name (Object_Definition (N)) then Act_T := Etype (E); Index: exp_aggr.adb === --- exp_aggr.adb(revision 237429) +++ exp_aggr.adb(working copy) @@ -5433,8 +5433,8 @@ -- STEP 3 - -- Delay expansion for nested aggregates: it will be taken care of - -- when the parent aggregate is expanded. + -- Delay expansion for nested aggregates: it will be taken care of when + -- the parent aggregate is expanded. Parent_Node := Parent (N); Parent_Kind := Nkind (Parent_Node); @@ -5524,14 +5524,18 @@ and then Parent_Kind = N_Object_Declaration and then not Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ) - and then N = Expression (Parent_Node) + and then Present (Expression (Parent_Node)) + and then not Has_Controlled_Component (Typ) and then not Is_Bit_Packed_Array (Typ) - and then not Has_Controlled_Component (Typ) + + -- ??? the test for SPARK 05 needs documentation + + and then not Restriction_Check_Required (SPARK_05) then In_Place_Assign_OK_For_Declaration := True; - Tmp := Defining_Identifier (Parent (N)); - Set_No_Initialization (Parent (N)); - Set_Expression (Parent (N), Empty); + Tmp := Defining_Identifier (Parent_Node); + Set_No_Initialization (Parent_Node); + Set_Expression (Parent_Node, Empty); -- Set kind and type of the entity, for use in the analysis -- of the subsequent assignments. If the nominal type is not @@ -5544,10 +5548,10 @@ if not Is_Constrained (Typ) then Build_Constrained_Type (Positional => False); - elsif Is_Entity_Name (Object_Definition (Parent (N))) - and then Is_Constrained (Entity (Object_Definition (Parent (N + elsif Is_Entity_Name (Object_Definition (Parent_Node)) + and then Is_Constrained (Entity (Object_Definition (Parent_Node))) then -Set_Etype (Tmp, Entity (Object_Definition (Parent (N; +Set_Etype (Tmp, Entity (Object_Definition (Parent_Node))); else Set_Size_Known_At_Compile_Time (Typ, False);
[Ada] Use System.Priority to validate pragma Priority value for subprogram.
This fixes a corner case for pragma Priority (0) set on the main subprogram.
Does not affect usual platforms.
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-16 Tristan Gingold
* sem_prag.adb (Analyze_Pragma): Simplify code
for Pragma_Priority.
Index: exp_aggr.adb
===
--- exp_aggr.adb(revision 237429)
+++ exp_aggr.adb(working copy)
@@ -5433,8 +5433,8 @@
-- STEP 3
- -- Delay expansion for nested aggregates: it will be taken care of
- -- when the parent aggregate is expanded.
+ -- Delay expansion for nested aggregates: it will be taken care of when
+ -- the parent aggregate is expanded.
Parent_Node := Parent (N);
Parent_Kind := Nkind (Parent_Node);
@@ -5524,14 +5524,18 @@
and then Parent_Kind = N_Object_Declaration
and then not
Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ)
- and then N = Expression (Parent_Node)
+ and then Present (Expression (Parent_Node))
+ and then not Has_Controlled_Component (Typ)
and then not Is_Bit_Packed_Array (Typ)
- and then not Has_Controlled_Component (Typ)
+
+ -- ??? the test for SPARK 05 needs documentation
+
+ and then not Restriction_Check_Required (SPARK_05)
then
In_Place_Assign_OK_For_Declaration := True;
- Tmp := Defining_Identifier (Parent (N));
- Set_No_Initialization (Parent (N));
- Set_Expression (Parent (N), Empty);
+ Tmp := Defining_Identifier (Parent_Node);
+ Set_No_Initialization (Parent_Node);
+ Set_Expression (Parent_Node, Empty);
-- Set kind and type of the entity, for use in the analysis
-- of the subsequent assignments. If the nominal type is not
@@ -5544,10 +5548,10 @@
if not Is_Constrained (Typ) then
Build_Constrained_Type (Positional => False);
- elsif Is_Entity_Name (Object_Definition (Parent (N)))
- and then Is_Constrained (Entity (Object_Definition (Parent (N
+ elsif Is_Entity_Name (Object_Definition (Parent_Node))
+ and then Is_Constrained (Entity (Object_Definition (Parent_Node)))
then
-Set_Etype (Tmp, Entity (Object_Definition (Parent (N;
+Set_Etype (Tmp, Entity (Object_Definition (Parent_Node)));
else
Set_Size_Known_At_Compile_Time (Typ, False);
Index: sem_prag.adb
===
--- sem_prag.adb(revision 237433)
+++ sem_prag.adb(working copy)
@@ -18903,22 +18903,15 @@
-- where we ignore the value if out of range.
else
- declare
- Val : constant Uint := Expr_Value (Arg);
- begin
- if not Relaxed_RM_Semantics
- and then
- (Val < 0
- or else Val > Expr_Value (Expression
- (Parent (RTE (RE_Max_Priority)
- then
-Error_Pragma_Arg
- ("main subprogram priority is out of range", Arg1);
- else
-Set_Main_Priority
- (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
- end if;
- end;
+ if not Relaxed_RM_Semantics
+and then not Is_In_Range (Arg, RTE (RE_Priority))
+ then
+ Error_Pragma_Arg
+ ("main subprogram priority is out of range", Arg1);
+ else
+ Set_Main_Priority
+ (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
+ end if;
end if;
-- Load an arbitrary entity from System.Tasking.Stages or
[Ada] Fix minor memory leak in GNAT.Command_Line
When a new switch is defined with a specific name for its parameter, that name is not freed. This is a minor leak, since such switches are in general defined once at the beginning of the program, and never modified afterwards. Detected with valgrind. Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-16 Emmanuel Briot * g-comlin.adb: Fix minor memory leak in GNAT.Command_Line. Index: g-comlin.adb === --- g-comlin.adb(revision 237429) +++ g-comlin.adb(working copy) @@ -3073,6 +3073,7 @@ Free (Config.Switches (S).Long_Switch); Free (Config.Switches (S).Help); Free (Config.Switches (S).Section); + Free (Config.Switches (S).Argument); end loop; Unchecked_Free (Config.Switches);
[Ada] Missing finalization of controlled build-in-place function result
This patch modifies the finalization machinery to recognize a controlled
deferred constant initialized by means of a build-in-place function call
as requiring finalization actions.
-- Source --
-- types.ads
private with Ada.Finalization;
package Types is
type T (<>) is limited private;
function Create return T;
private
type T is new Ada.Finalization.Limited_Controlled with record
Id : Natural := 0;
end record;
overriding procedure Initialize (X : in out T);
overriding procedure Finalize (X : in out T);
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Id_Gen : Natural := 0;
procedure Finalize (X : in out T) is
begin
Put_Line (" fin" & X.Id'Img);
X.Id := 0;
end;
procedure Initialize (X : in out T) is
begin
Id_Gen := Id_Gen + 1;
X.Id := Id_Gen;
Put_Line (" ini" & X.Id'Img);
end Initialize;
function Create return T is
begin
return Result : T do
Put_Line ("Create");
end return;
end Create;
end Types;
-- main.adb
with Types; use Types;
procedure Main is
Obj : T renames Create;
begin
null;
end Main;
-- Compilation and output --
$ gnatmake -q main.adb
$ ./main
ini 1
Create
fin 1
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-16 Hristian Kirtchev
* exp_ch7.adb (Find_Last_Init): Remove obsolete code. The
logic is now performed by Process_Object_Declaration.
(Process_Declarations): Recognize a controlled deferred
constant which is in fact initialized by means of a
build-in-place function call as needing finalization actions.
(Process_Object_Declaration): Insert the counter after the
build-in-place initialization call for a controlled object. This
was previously done in Find_Last_Init.
* exp_util.adb (Requires_Cleanup_Actions): Recognize a controlled
deferred constant which is in fact initialized by means of a
build-in-place function call as needing finalization actions.
Index: exp_ch7.adb
===
--- exp_ch7.adb (revision 237429)
+++ exp_ch7.adb (working copy)
@@ -2100,16 +2100,21 @@
null;
-- The object is of the form:
- --Obj : Typ [:= Expr];
+ --Obj : [constant] Typ [:= Expr];
- -- Do not process the incomplete view of a deferred constant.
- -- Do not consider tag-to-class-wide conversions.
+ -- Do not process tag-to-class-wide conversions because they do
+ -- not yield an object. Do not process the incomplete view of a
+ -- deferred constant. Note that an object initialized by means
+ -- of a build-in-place function call may appear as a deferred
+ -- constant after expansion activities. These kinds of objects
+ -- must be finalized.
elsif not Is_Imported (Obj_Id)
and then Needs_Finalization (Obj_Typ)
- and then not (Ekind (Obj_Id) = E_Constant
-and then not Has_Completion (Obj_Id))
and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
+ and then not (Ekind (Obj_Id) = E_Constant
+and then not Has_Completion (Obj_Id)
+and then No (BIP_Initialization_Call (Obj_Id)))
then
Processing_Actions;
@@ -2757,48 +2762,9 @@
Stmt := Next_Suitable_Statement (Decl);
--- A limited controlled object initialized by a function call uses
--- the build-in-place machinery to obtain its value.
+-- Nothing to do for an object with suppressed initialization
---Obj : Lim_Controlled_Type := Func_Call;
-
--- is expanded into
-
---Obj : Lim_Controlled_Type;
---type Ptr_Typ is access Lim_Controlled_Type;
---Temp : constant Ptr_Typ :=
--- Func_Call
--- (BIPalloc => 1,
---BIPaccess => Obj'Unrestricted_Access)'reference;
-
--- In this scenario the declaration of the temporary acts as the
--- last initialization statement.
-
-if Is_Limited_Type (Obj_Typ)
- and then Has_Init_Expression (Decl)
- and then No (Expression (Decl))
-then
- while Present (Stmt) loop
- if Nkind (Stmt) = N_Object_Declaration
-and then Present (Expression (Stmt))
-and then Is_Object_Access_BIP_Func_Call
- (Expr => Expression (Stmt),
-Obj_I
[Ada] Missing errors on illegal expressions for entry pre/postconditions
This patch adds checks on the expressions of pre/postconditions for task and protected entries, prior to their full analysis, so that errors are properly emitted in various compiler modes. Tested by ACATS 4.0L: B611008 Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-16 Ed Schonberg * sem_ch3.adb (Check_Entry_Contracts): New procedure, subsidiary of Analyze_Declarations, that performs pre-analysis of pre/postconditions on entry declarations before full analysis is performed after entries have been converted into procedures. Done solely to capture semantic errors. * sem_attr.adb (Analyze_Attribute, case 'Result): Add guard to call to Denote_Same_Function. Index: sem_ch3.adb === --- sem_ch3.adb (revision 237514) +++ sem_ch3.adb (working copy) @@ -2165,6 +2165,13 @@ -- (They have the sloc of the label as found in the source, and that -- is ahead of the current declarative part). + procedure Check_Entry_Contracts; + -- Perform a pre-analysis of the pre- and postconditions of an entry + -- declaration. This must be done before full resolution and creation + -- of the parameter block, etc. to catch illegal uses within the + -- contract expression. Full analysis of the expression is done when + -- the contract is processed. + procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id); -- Determine whether Body_Decl denotes the body of a late controlled -- primitive (either Initialize, Adjust or Finalize). If this is the @@ -2189,6 +2196,56 @@ end loop; end Adjust_Decl; + --- + -- Check_Entry_Contracts -- + --- + + procedure Check_Entry_Contracts is + ASN : Node_Id; + Ent : Entity_Id; + Exp : Node_Id; + + begin + Ent := First_Entity (Current_Scope); + while Present (Ent) loop + +-- This only concerns entries with pre/postconditions + +if Ekind (Ent) = E_Entry + and then Present (Contract (Ent)) + and then Present (Pre_Post_Conditions (Contract (Ent))) +then + ASN := Pre_Post_Conditions (Contract (Ent)); + Push_Scope (Ent); + Install_Formals (Ent); + + -- Pre/postconditions are rewritten as Check pragmas. Analysis + -- is performed on a copy of the pragma expression, to prevent + -- modifying the original expression. + + while Present (ASN) loop + if Nkind (ASN) = N_Pragma then + Exp := + New_Copy_Tree + (Expression + (First (Pragma_Argument_Associations (ASN; + Set_Parent (Exp, ASN); + + -- ??? why not Preanalyze_Assert_Expression + + Preanalyze (Exp); + end if; + + ASN := Next_Pragma (ASN); + end loop; + + End_Scope; +end if; + +Next_Entity (Ent); + end loop; + end Check_Entry_Contracts; + -- -- Handle_Late_Controlled_Primitive -- -- @@ -2349,12 +2406,14 @@ -- (This is needed in any case for early instantiations ???). if No (Next_Decl) then -if Nkind_In (Parent (L), N_Component_List, - N_Task_Definition, - N_Protected_Definition) -then +if Nkind (Parent (L)) = N_Component_List then null; +elsif Nkind_In (Parent (L), N_Protected_Definition, +N_Task_Definition) +then + Check_Entry_Contracts; + elsif Nkind (Parent (L)) /= N_Package_Specification then if Nkind (Parent (L)) = N_Package_Body then Freeze_From := First_Entity (Current_Scope); Index: sem_attr.adb === --- sem_attr.adb(revision 237507) +++ sem_attr.adb(working copy) @@ -5348,7 +5348,9 @@ if Is_Entity_Name (P) then Pref_Id := Entity (P); - if Ekind_In (Pref_Id, E_Function, E_Generic_Function) then + if Ekind_In (Pref_Id, E_Function, E_Generic_Function) + and then Ekind (Spec_Id) = Ekind (Pref_Id) + then if Denote_Same_Function (Pref_Id, Spec_Id) then -- Correct the prefix of the attribute when the context
[Ada] Handling of all-digits host names
In Get_Host_By_Name, do not treat a strings consisting of digits only as an IP address whose lookup should actually be done using Get_Host_By_Address. Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-20 Thomas Quinot * g-socket.adb (Is_IP_Address): A string consisting in digits only is not a dotted quad. Index: g-socket.adb === --- g-socket.adb(revision 237595) +++ g-socket.adb(working copy) @@ -150,7 +150,7 @@ -- Output an array of inet address components in hex or decimal mode function Is_IP_Address (Name : String) return Boolean; - -- Return true when Name is an IP address in standard dot notation + -- Return true when Name is an IPv4 address in dotted quad notation procedure Netdb_Lock; pragma Inline (Netdb_Lock); @@ -996,7 +996,8 @@ function Get_Host_By_Name (Name : String) return Host_Entry_Type is begin - -- Detect IP address name and redirect to Inet_Addr + -- If the given name actually is the string representation of + -- an IP address, use Get_Host_By_Address instead. if Is_IP_Address (Name) then return Get_Host_By_Address (Inet_Addr (Name)); @@ -1503,16 +1504,37 @@ --- function Is_IP_Address (Name : String) return Boolean is + Dots : Natural := 0; begin + -- Perform a cursory check for a dotted quad: we must have 1 to 3 + -- dots, and there must be at least one digit around each. + for J in Name'Range loop - if Name (J) /= '.' - and then Name (J) not in '0' .. '9' - then + if Name (J) = '.' then + +-- Check that the dot is not in first or last position, and +-- that it is followed by a digit. Note that we already know +-- that it is preceded by a digit, or we would have returned +-- earlier on. + +if J in Name'First + 1 .. Name'Last - 1 + and then Name (J + 1) in '0' .. '9' +then + Dots := Dots + 1; + +else + + -- Definitely not a proper dotted quad + + return False; +end if; + + elsif Name (J) not in '0' .. '9' then return False; end if; end loop; - return True; + return Dots in 1 .. 3; end Is_IP_Address; -
[Ada] Always consider Linker_Options from package System
On full runtimes, this was always the case. On restricted one, force system to be in the closer of the program. No test for full runtimes (as no behaviour change). Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-20 Tristan Gingold * make.adb (Check_Standard_Library): Consider system.ads if s-stalib.adb is not available. * gnatbind.adb (Add_Artificial_ALI_File): New procedure extracted from gnatbind. Index: make.adb === --- make.adb(revision 237595) +++ make.adb(working copy) @@ -84,8 +84,11 @@ -- Make control characters visible Standard_Library_Package_Body_Name : constant String := "s-stalib.adb"; - -- Every program depends on this package, that must then be checked, - -- especially when -f and -a are used. + System_Package_Spec_Name : constant String := "system.ads"; + -- Every program depends on one of these packages: usually the first one, + -- or if Supress_Standard_Library is true on the second one. The dependency + -- is not always explicit and considering it is important when -f and -a + -- are used. type Sigint_Handler is access procedure; pragma Convention (C, Sigint_Handler); @@ -2701,39 +2704,43 @@ begin Need_To_Check_Standard_Library := False; + Name_Len := 0; + if not Targparm.Suppress_Standard_Library_On_Target then -declare - Sfile : File_Name_Type; - Add_It : Boolean := True; +Add_Str_To_Name_Buffer (Standard_Library_Package_Body_Name); + else +Add_Str_To_Name_Buffer (System_Package_Spec_Name); + end if; -begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Standard_Library_Package_Body_Name); - Sfile := Name_Enter; + declare +Sfile : File_Name_Type; +Add_It : Boolean := True; - -- If we have a special runtime, we add the standard - -- library only if we can find it. + begin +Sfile := Name_Enter; - if RTS_Switch then - Add_It := Full_Source_Name (Sfile) /= No_File; - end if; +-- If we have a special runtime, we add the standard library only +-- if we can find it. - if Add_It then - if not Queue.Insert - ((Format => Format_Gnatmake, - File=> Sfile, - Unit=> No_Unit_Name, - Project => No_Project, - Index => 0, - Sid => No_Source)) - then - if Is_In_Obsoleted (Sfile) then -Executable_Obsolete := True; - end if; +if RTS_Switch then + Add_It := Full_Source_Name (Sfile) /= No_File; +end if; + +if Add_It then + if not Queue.Insert +((Format => Format_Gnatmake, + File=> Sfile, + Unit=> No_Unit_Name, + Project => No_Project, + Index => 0, + Sid => No_Source)) + then + if Is_In_Obsoleted (Sfile) then + Executable_Obsolete := True; end if; end if; -end; - end if; +end if; + end; end Check_Standard_Library; --- Index: gnatbind.adb === --- gnatbind.adb(revision 237595) +++ gnatbind.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -89,6 +89,9 @@ -- Table to record the sources in the closure, to avoid duplications. Used -- only with switch -R. + procedure Add_Artificial_ALI_File (Name : String); + -- Artificially add ALI file Name in the closure. + function Gnatbind_Supports_Auto_Init return Boolean; -- Indicates if automatic initialization of elaboration procedure -- through the constructor mechanism is possible o
[Ada] Adapt treatment of inherited classwide pre/post to GNATprove
In GNATprove mode, inherited classwide pre/post are copied to the overriding subprogram declaration, so that GNATprove can find them to verify Liskov Substitution Principle on SPARK code. The copied pre/post are not turned into pragma checks anymore in GNATprove mode, so that they are added to the Contract node of the overriding subprogram entity, which makes it easier to deal with in GNATprove. The type of the call node is also set to the appropriate type after the function has been specialized in the copied pragma, in both GNATprove mode and normal mode. Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-20 Yannick Moy * sem_prag.adb, sem_prag.ads (Build_Pragma_Check_Equivalent): Add parameter Keep_Pragma_Id to optionally keep the identifier of the pragma instead of converting to pragma Check. Also set type of new function call appropriately. (Collect_Inherited_Class_Wide_Conditions): Call Build_Pragma_Check_Equivalent with the new parameter Keep_Pragma_Id set to True to keep the identifier of the copied pragma. * sinfo.ads: Add comment. Index: sem_prag.adb === --- sem_prag.adb(revision 237598) +++ sem_prag.adb(working copy) @@ -26277,9 +26277,10 @@ --- function Build_Pragma_Check_Equivalent - (Prag : Node_Id; - Subp_Id : Entity_Id := Empty; - Inher_Id : Entity_Id := Empty) return Node_Id + (Prag : Node_Id; + Subp_Id: Entity_Id := Empty; + Inher_Id : Entity_Id := Empty; + Keep_Pragma_Id : Boolean := False) return Node_Id is Map : Elist_Id; -- List containing the following mappings @@ -26361,6 +26362,15 @@ & "for&#", N, Current_Scope); end if; +-- Update type of function call node, which should be the same as +-- the function's return type. + +if Is_Subprogram (Entity (N)) + and then Nkind (Parent (N)) = N_Function_Call +then + Set_Etype (Parent (N), Etype (Entity (N))); +end if; + -- The whole expression will be reanalyzed elsif Nkind (N) in N_Has_Etype then @@ -26595,7 +26605,6 @@ Set_Analyzed (Check_Prag, False); Set_Comes_From_Source (Check_Prag, False); - Set_Class_Present (Check_Prag, False); -- The tree of the original pragma may contain references to the -- formal parameters of the related subprogram. At the same time @@ -26621,16 +26630,21 @@ Nam := Prag_Nam; end if; - -- Convert the copy into pragma Check by correcting the name and adding - -- a check_kind argument. + -- Unless Keep_Pragma_Id is True in order to keep the identifier of + -- the copied pragma in the newly created pragma, convert the copy into + -- pragma Check by correcting the name and adding a check_kind argument. - Set_Pragma_Identifier -(Check_Prag, Make_Identifier (Loc, Name_Check)); + if not Keep_Pragma_Id then + Set_Class_Present (Check_Prag, False); - Prepend_To (Pragma_Argument_Associations (Check_Prag), -Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Nam))); + Set_Pragma_Identifier + (Check_Prag, Make_Identifier (Loc, Name_Check)); + Prepend_To (Pragma_Argument_Associations (Check_Prag), + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Nam))); + end if; + -- Update the error message when the pragma is inherited if Present (Inher_Id) then @@ -27154,7 +27168,8 @@ end if; New_Prag := - Build_Pragma_Check_Equivalent (Prag, Subp, Parent_Subp); + Build_Pragma_Check_Equivalent (Prag, Subp, Parent_Subp, +Keep_Pragma_Id => True); Insert_After (Unit_Declaration_Node (Subp), New_Prag); Preanalyze (New_Prag); Index: sem_prag.ads === --- sem_prag.ads(revision 237595) +++ sem_prag.ads(working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public Li
[Ada] Reimplementation of type invariants
This patch prevents the insertion of the invariant procedure declaration and
body when the context is a generic unit. This ensures that generated code does
not permiate the template.
-- Source --
-- tester.ads
package Tester is
type Type_Id is
(Ext_1_Id,
Ext_1_FV_Id,
Ext_2_Id,
Ext_3_Id,
Ext_4_Id,
Ext_4_FV_Id,
Ext_5_Id,
Ext_6_Id,
Ext_6_FV_Id,
Ext_7_Id,
Ext_8_Id,
Iface_1_Id,
Iface_2_Id,
Iface_3_Id,
Iface_4_Id,
Par_1_Id,
Par_2_FV_Id,
Par_3_Id,
Par_4_Id,
Par_4_FV_Id,
Prot_1_FV_Id,
Prot_2_Id,
Prot_3_Id,
Prot_3_FV_Id,
Synch_1_Id,
Synch_2_Id,
Tag_1_Id,
Tag_2_Id,
Tag_3_Id,
Tag_4_Id,
Tag_4_FV_Id,
Tag_5_Id,
Tag_6_Id,
Tag_7_Id,
Tag_8_Id,
Tag_9_Id,
Tag_10_Id,
Tag_11_Id,
Tag_12_Id,
Tag_13_Id,
Tag_14_Id,
Tag_15_Id,
Tag_15_FV_Id,
Tag_16_Id,
Tag_17_Id,
Tag_18_Id,
Tag_19_Id,
Tag_20_Id,
Tag_20_FV_Id,
Tag_21_Id,
Tag_22_Id,
Tag_23_Id,
Tag_24_Id,
Tag_24_FV_Id,
Tag_25_Id,
Tag_26_Id,
Tag_27_Id,
Tag_28_Id,
Task_1_Id,
Task_2_Id,
Task_2_FV_Id,
Untag_1_Id,
Untag_2_Id,
Untag_3_Id,
Untag_4_Id,
Untag_5_Id,
Untag_6_Id,
Untag_7_Id,
Untag_8_Id,
Untag_9_Id);
type Results is array (Type_Id) of Boolean;
function Mark (Typ : Type_Id) return Boolean;
-- Mark the result for a particular type as verified. The function always
-- returns True.
procedure Reset_Results;
-- Reset the internally kept result state
procedure Test_Results (Test_Id : String; Exp : Results);
-- Ensure that the internally kept result state agrees with expected
-- results Exp. Emit an error if this is not the case.
end Tester;
-- tester.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Tester is
State : Results;
--
-- Mark --
--
function Mark (Typ : Type_Id) return Boolean is
begin
State (Typ) := True;
return True;
end Mark;
---
-- Reset_Results --
---
procedure Reset_Results is
begin
State := (others => False);
end Reset_Results;
--
-- Test_Results --
--
procedure Test_Results (Test_Id : String; Exp : Results) is
Exp_Val : Boolean;
Posted: Boolean := False;
State_Val : Boolean;
begin
for Index in Results'Range loop
Exp_Val := Exp (Index);
State_Val := State (Index);
if State_Val /= Exp_Val then
if not Posted then
Posted := True;
Put_Line (Test_Id & ": ERROR");
end if;
Put_Line (" Expected: " & Exp_Val'Img & " for " & Index'Img);
Put_Line (" Got: " & State_Val'Img);
end if;
end loop;
if not Posted then
Put_Line (Test_Id & ": OK");
end if;
end Test_Results;
end Tester;
-- gen_invariants.ads
with Tester; use Tester;
generic
package Gen_Invariants is
type Untag_1 is private
with Type_Invariant => Mark (Untag_1_Id);
private
type Untag_1 is null record;
Obj_1 : Untag_1;
end Gen_Invariants;
-
-- Compilation --
-
$ gcc -c -gnata -gnatDG gen_invariants.ads
$ grep "Invariant" gen_invariants.ads.dg
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-20 Hristian Kirtchev
* exp_ch7.adb (Build_Invariant_Procedure_Body):
Always install the scope of the invariant procedure
in order to produce better error messages. Do not
insert the body when the context is a generic unit.
(Build_Invariant_Procedure_Declaration): Perform minimal
decoration of the invariant procedure and its formal parameter
in case they are not analyzed. Do not insert the declaration
when the context is a generic unit.
Index: exp_ch7.adb
===
--- exp_ch7.adb (revision 237598)
+++ exp_ch7.adb (working copy)
@@ -4622,7 +4622,16 @@
Set_Ghost_Mode_From_Entity (Work_Typ);
+ -- Emulate the environment of the invariant procedure by installing
+ -- its scope and formal parameters. Note that this is not need, but
+ -- having the scope of the invariant procedure installed helps with
+ -- the detection of invariant-related errors.
+
+ Push_Scope (Proc_Id);
+ Install_Formals (Proc_Id);
+
Obj_Id := First_Formal (Proc_Id);
+ pragma Assert (Present (Obj_Id));
-- The "partial" invariant procedure verifies the invariants of the
-- partial view only.
@@ -4631,14 +4640,6 @@
pragma Assert (Present (Priv_Typ));
Freeze_Typ := Priv_Typ;
[Ada] Spurious error with predicate on type derived from unconstrained array
This patch fixes a spurious error on the compilation of a subprogram whose formal parameter is derived from an unconstrained array type with a dynamic predicate aspect. The following must compile quietly: gcc -c gpr2-attribute.adb gcc -c -gnata gpr2-attribute.adb --- package GPR2 is subtype Name_Type is String with Dynamic_Predicate => Name_Type'Length > 0; end GPR2; --- package GPR2.Attribute is type Qualified_Name (<>) is private; procedure Get (Q_Name : Qualified_Name); private type Qualified_Name is new Name_Type; end GPR2.Attribute; -- package body GPR2.Attribute is procedure Get (Q_Name : Qualified_Name) is N : Name_Type := Name_Type (Q_Name); begin null; end Get; end GPR2.Attribute; Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-22 Ed Schonberg * sem_ch6.adb (Set_Actual_Subtypes): If the type of the actual has predicates, the actual subtype must be frozen properly because of the generated tests that may follow. The predicate may be specified by an explicit aspect, or may be inherited in a derivation. Index: sem_ch6.adb === --- sem_ch6.adb (revision 237680) +++ sem_ch6.adb (working copy) @@ -11308,9 +11308,10 @@ Freeze_Entity (Defining_Identifier (Decl), N)); -- Ditto if the type has a dynamic predicate, because the --- generated function will mention the actual subtype. +-- generated function will mention the actual subtype. The +-- predicate may come from an explicit aspect of be inherited. -elsif Has_Dynamic_Predicate_Aspect (T) then +elsif Has_Predicates (T) then Insert_List_Before_And_Analyze (Decl, Freeze_Entity (Defining_Identifier (Decl), N)); end if;
[Ada] New debug switch -gnatd.o
This patch causes -gnatd.o to choose a more conservative elaboration order.
The following test should compile and run quietly.
gnatmake -q -f -gnatd.o -g -O0 elab_indirect_2-main -bargs -p -ws
with Elab_Indirect;
with Elab_Indirect.Child;
package body Elab_Indirect_2 is
procedure P is
begin
null;
end P;
procedure Process_Line (Line : String) is
begin
Elab_Indirect.Child.Child_Proc;
end Process_Line;
procedure Q is
begin
Elab_Indirect.Process_Lines (Process_Line'Access);
end Q;
begin
Q;
end Elab_Indirect_2;
package Elab_Indirect_2 is
procedure P;
end Elab_Indirect_2;
procedure Elab_Indirect_2.Main is
begin
null;
end Elab_Indirect_2.Main;
package body Elab_Indirect is
procedure Process_Lines
(Process_Line : access procedure (Line : String)) is
begin
Process_Line ("Hello");
end Process_Lines;
end Elab_Indirect;
package Elab_Indirect is
procedure Process_Lines
(Process_Line : access procedure (Line : String));
end Elab_Indirect;
with Text_IO; use Text_IO;
package body Elab_Indirect.Child is
type String_Ref is access all String;
Var : String_Ref := new String'("Hello world");
procedure Child_Proc is
begin
if Var.all /= "Hello world" then
raise Program_Error;
end if;
end Child_Proc;
end Elab_Indirect.Child;
package Elab_Indirect.Child is
procedure Child_Proc;
end Elab_Indirect.Child;
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-22 Bob Duff
* debug.adb: Document debug switch -gnatd.o.
* sem_elab.adb (Check_Internal_Call): Debug switch -gnatd.o
now causes a more conservative treatment of indirect calls,
treating P'Access as a call to P in more cases. We Can't make
this the default, because it breaks common idioms, for example
the soft links.
* sem_util.adb: Add an Assert.
Index: debug.adb
===
--- debug.adb (revision 237680)
+++ debug.adb (working copy)
@@ -105,7 +105,7 @@
-- d.l Use Ada 95 semantics for limited function returns
-- d.m For -gnatl, print full source only for main unit
-- d.n Print source file names
- -- d.o
+ -- d.o Conservative elaboration order for indirect calls
-- d.p
-- d.q
-- d.r Enable OK_To_Reorder_Components in non-variant records
@@ -556,6 +556,9 @@
-- compiler has a bug -- these are the files that need to be included
-- in a bug report.
+ -- d.o Conservative elaboration order for indirect calls. This causes
+ -- P'Access to be treated as a call in more cases.
+
-- d.r Forces the flag OK_To_Reorder_Components to be set in all record
-- base types that have no discriminants.
Index: sem_util.adb
===
--- sem_util.adb(revision 237680)
+++ sem_util.adb(working copy)
@@ -6314,6 +6314,7 @@
Encl_Unit := Library_Unit (Encl_Unit);
end loop;
+ pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit);
return Encl_Unit;
end Enclosing_Lib_Unit_Node;
Index: sem_elab.adb
===
--- sem_elab.adb(revision 237680)
+++ sem_elab.adb(working copy)
@@ -2139,7 +2139,8 @@
-- node comes from source.
if Nkind (N) = N_Attribute_Reference
-and then (not Warn_On_Elab_Access or else not Comes_From_Source (N))
+and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O)
+or else not Comes_From_Source (N))
then
return;
[Ada] Crash on illegal expression in context with predicate
This patch fixes a compiler abort on a return statement for a function whose type is a derived type with a dynamic predicate, when the return expression has the parent type. Compiling gpr2-attribute.adb must yield: gpr2-attribute.adb:8:14: expected type "Qualified_Name" defined at gpr2-attribute.ads:12 gpr2-attribute.adb:8:14: found type "Standard.String" --- package GPR2 is subtype Name_Type is String with Dynamic_Predicate => Name_Type'Length > 0; end GPR2; -- with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; package GPR2.Attribute is type Qualified_Name (<>) is private; function Create (Name : Name_Type) return Qualified_Name; private type Qualified_Name is new Name_Type; end GPR2.Attribute; -- package body GPR2.Attribute is function Create (Name : Name_Type) return Qualified_Name is begin -- OK: return Qualified_Name (Name); -- with below code (missing conversion) GNAT crashes return Name; end Create; end GPR2.Attribute; Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-22 Ed Schonberg * sem_ch13.adb (Is_Predicate_Static): An inherited predicate can be static only if it applies to a scalar type. Index: sem_ch13.adb === --- sem_ch13.adb(revision 237680) +++ sem_ch13.adb(working copy) @@ -8552,8 +8552,7 @@ Expression => Expr; -- If declaration has not been analyzed yet, Insert declaration --- before freeze node. --- Insert body after freeze node. +-- before freeze node. Insert body itself after freeze node. if not Analyzed (FDecl) then Insert_Before_And_Analyze (N, FDecl); @@ -11644,9 +11643,11 @@ -- to specify a static predicate for a subtype which is inheriting a -- dynamic predicate, so the static predicate validation here ignores -- the inherited predicate even if it is dynamic. + -- In all cases, a static predicate can only apply to a scalar type. elsif Nkind (Expr) = N_Function_Call and then Is_Predicate_Function (Entity (Name (Expr))) +and then Is_Scalar_Type (Etype (First_Entity (Entity (Name (Expr) then return True;
[Ada] New implementation of Ada.Containers.Unbounded_Priority_Queues
This patch uses O(lg N) algorithms for Unbounded_Priority_Queues. No expected change in behavior; no test available. Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-22 Bob Duff * a-cuprqu.ads, a-cuprqu.adb: Completely rewrite this package. Use red-black trees, which gives O(lg N) worst-case performance on Enqueue and Dequeue. The previous version had O(N) Enqueue in the worst case. Index: a-cuprqu.adb === --- a-cuprqu.adb(revision 237680) +++ a-cuprqu.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- ---Copyright (C) 2011-2015, Free Software Foundation, Inc. -- +--Copyright (C) 2011-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,225 +27,8 @@ -- This unit was originally developed by Matthew J Heaney. -- -- -with Ada.Unchecked_Deallocation; - package body Ada.Containers.Unbounded_Priority_Queues is - package body Implementation is - - --- - -- Local Subprograms -- - --- - - function Before_Or_Equal (X, Y : Queue_Priority) return Boolean; - -- True if X is before or equal to Y. Equal means both Before(X,Y) and - -- Before(Y,X) are False. - - procedure Free is -new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - - - -- Before_Or_Equal -- - - - - function Before_Or_Equal (X, Y : Queue_Priority) return Boolean is - begin - return (if Before (X, Y) then True else not Before (Y, X)); - end Before_Or_Equal; - - - - -- Dequeue -- - - - - procedure Dequeue -(List: in out List_Type; - Element : out Queue_Interfaces.Element_Type) - is - H : constant Node_Access := List.Header'Unchecked_Access; - pragma Assert (List.Length /= 0); - pragma Assert (List.Header.Next /= H); - -- List can't be empty; see the barrier - - pragma Assert - (List.Header.Next.Next = H or else -Before_Or_Equal (Get_Priority (List.Header.Next.Element), - Get_Priority (List.Header.Next.Next.Element))); - -- The first item is before-or-equal to the second - - pragma Assert - (List.Header.Next.Next_Unequal = H or else -Before (Get_Priority (List.Header.Next.Element), -Get_Priority (List.Header.Next.Next_Unequal.Element))); - -- The first item is before its Next_Unequal item - - -- The highest-priority item is always first; just remove it and - -- return that element. - - X : Node_Access := List.Header.Next; - - -- Start of processing for Dequeue - - begin - Element := X.Element; - X.Next.Prev := H; - List.Header.Next := X.Next; - List.Header.Next_Unequal := X.Next; - List.Length := List.Length - 1; - Free (X); - end Dequeue; - - procedure Dequeue -(List : in out List_Type; - At_Least : Queue_Priority; - Element : in out Queue_Interfaces.Element_Type; - Success : out Boolean) - is - begin - -- This operation dequeues a high priority item if it exists in the - -- queue. By "high priority" we mean an item whose priority is equal - -- or greater than the value At_Least. The generic formal operation - -- Before has the meaning "has higher priority than". To dequeue an - -- item (meaning that we return True as our Success value), we need - -- as our predicate the equivalent of "has equal or higher priority - -- than", but we cannot say that directly, so we require some logical - -- gymnastics to make it so. - - -- If E is the element at the head of the queue, and symbol ">" - -- refers to the "is higher priority than" function Before, then we - -- derive our predicate as follows: - --original: P(E) >= At_Least - --same as: not (P(E) < At_Least) - --same as: not (At_Least > P(E)) - --same as: not Before (At_Least, P(E)) - - -- But that predicate needs to be true in order to successfully - -- dequeue an item. If it's false, it means no item is de
[Ada] Improve and unify warning machinery for address clauses
This change moves the rest of the warning machinery for address clauses to
Validate_Address_Clauses, ensuring that all the variants are issued from it.
This affects only absolute address clauses in practice, i.e. address clauses
of the form for I'Address use To_Address (16#_#) and variants thereof.
This automatically brings a couple of improvements: warnings are more accurate
because they take into account the final alignment set by the back-end and they
catch more cases because the back-end sets the alignment of every single type
and object in the program. The warning also prints the alignment value now.
The following code gives an example of the warnings:
pragma Unsuppress (Alignment_Check);
1. with System.Storage_Elements; use System.Storage_Elements;
2.
3. package P is
4.
5. I : Integer;
6. for I'Address use To_Address (16#7FFF_0001#); -- warning
|
>>> warning: specified address for "I" is inconsistent with alignment
>>> warning: program execution may be erroneous (RM 13.3(27))
>>> warning: alignment of "I" is 4
7.
8. type Rec is record
9. I : Integer;
10. end record;
11.
12. R1 : Rec;
13. for R1'Address use To_Address (16#7FFF_0001#); -- warning
|
>>> warning: specified address for "R1" is inconsistent with alignment
>>> warning: program execution may be erroneous (RM 13.3(27))
>>> warning: alignment of "R1" is 4
14.
15. C : constant System.Address := To_Address (16#7FFF_0001#); -- warning
16.
17. R2 : Rec;
18. for R2'Address use C;
|
>>> warning: specified address for "R2" is inconsistent with alignment
>>> warning: program execution may be erroneous (RM 13.3(27))
>>> warning: alignment of "R2" is 4
19.
20. R3 : Rec;
21. for R3'Address use To_Address (16#7FFF_0004#); -- no warning
22.
23. end P;
23 lines: No errors, 9 warnings
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-22 Eric Botcazou
* sem_util.ads (Address_Value): Declare new function.
* sem_util.adb (Address_Value): New function extracted
unmodified from Apply_Address_Clause_Check, which returns the
underlying value of the expression of an address clause.
* checks.adb (Compile_Time_Bad_Alignment): Delete.
(Apply_Address_Clause_Check): Call Address_Value on
the expression. Do not issue the main warning here and
issue the secondary warning only when the value of the
expression is not known at compile time.
* sem_ch13.adb (Address_Clause_Check_Record): Add A component and
adjust the description.
(Analyze_Attribute_Definition_Clause): In the case
of an address, move up the code creating an entry in the table of
address clauses. Also create an entry for an absolute address.
(Validate_Address_Clauses): Issue the warning for absolute
addresses here too. Tweak condition associated with overlays
for consistency.
Index: checks.adb
===
--- checks.adb (revision 237687)
+++ checks.adb (revision 237688)
@@ -638,36 +638,12 @@
AC : constant Node_Id:= Address_Clause (E);
Loc : constant Source_Ptr := Sloc (AC);
Typ : constant Entity_Id := Etype (E);
- Aexp : constant Node_Id:= Expression (AC);
Expr : Node_Id;
-- Address expression (not necessarily the same as Aexp, for example
-- when Aexp is a reference to a constant, in which case Expr gets
-- reset to reference the value expression of the constant).
- procedure Compile_Time_Bad_Alignment;
- -- Post error warnings when alignment is known to be incompatible. Note
- -- that we do not go as far as inserting a raise of Program_Error since
- -- this is an erroneous case, and it may happen that we are lucky and an
- -- underaligned address turns out to be OK after all.
-
-
- -- Compile_Time_Bad_Alignment --
-
-
- procedure Compile_Time_Bad_Alignment is
- begin
- if Address_Clause_Overlay_Warnings then
-Error_Msg_FE
- ("?o?specified address for& may be inconsistent with alignment",
- Aexp, E);
-Error_Msg_FE
- ("\?o?program execution may be erroneous (RM 13.3(27))",
- Aexp, E);
-Set_Address_Warning_Posted (AC);
- end if;
- end Compile_Time_Bad_Alignment;
-
-- Start of processing for Apply_Address_Clause_Check
begin
@@ -690,44 +666,12 @@
-- Obtain expression from address clause
- Expr := Expression (AC);
+ Expr := Address_Value (Expression (AC));
- -- The following loop digs for the real expression to use in the che
[Ada] Independent tasks and the Fall_Back_Handler
This patch fixes a bug in which if a Fall_Back_Handler is installed for the environment task, independent tasks will call it. The following test should run quietly: with Ada.Text_IO; package body Debug is protected body Dbg is procedure Termination (Cause : in Task_Termination.Cause_Of_Termination; Task_Id : in Task_Identification.Task_Id; Except : in Exceptions.Exception_Occurrence) is begin Text_IO.Put_Line (Task_Identification.Image (Task_Id) & " " & Cause'Img); end Termination; end Dbg; end Debug; with Ada.Exceptions, Ada.Task_Termination, Ada.Task_Identification; use Ada; package Debug is protected Dbg is procedure Termination (Cause : in Task_Termination.Cause_Of_Termination; Task_Id : in Task_Identification.Task_Id; Except : in Exceptions.Exception_Occurrence); end Dbg; end Debug; with Ada.Real_Time.Timing_Events, Ada.Task_Termination, Debug; use Ada; procedure Pb_Terminate is begin Task_Termination.Set_Dependents_Fallback_Handler (Debug.Dbg.Termination'Access); end Pb_Terminate; Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-22 Bob Duff * s-tassta.adb (Task_Wrapper): Fix handling of Fall_Back_Handler wrt independent tasks. Index: s-tassta.adb === --- s-tassta.adb(revision 237680) +++ s-tassta.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1339,7 +1339,13 @@ if Self_ID.Common.Specific_Handler /= null then TH := Self_ID.Common.Specific_Handler; - else + + -- Independent tasks should not call the Fall_Back_Handler (of the + -- environment task), because they are implementation artifacts that + -- should be invisible to Ada programs. + + elsif Self_ID.Master_of_Task /= Independent_Task_Level then + -- Look for a fall-back handler following the master relationship -- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back -- handler applies only to the dependent tasks of the task". Hence,
[Ada] Spurious error on derived type with unknown discriminants and predicate
This patch fixes a spurious error on an instantiation of an unbounded
container, when the element type is a private type with unknown discriminants,
derived from an array subtype with a predicate aspect.
The following must ocmpile quietly:
gcc -c gpr2-attribute.adb
---
package GPR2 is
subtype Name_Type is String
with Dynamic_Predicate => Name_Type'Length > 0;
end GPR2;
---
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package GPR2.Attribute is
type Qualified_Name (<>) is private;
function Create (Name : Name_Type) return Qualified_Name;
private
type Qualified_Name is new Name_Type;
end GPR2.Attribute;
---
with Ada.Containers.Indefinite_Ordered_Maps;
package body GPR2.Attribute is
type Def is null record;
package Attribute_Definitions is new Ada.Containers.Indefinite_Ordered_Maps
(Qualified_Name, Def);
function Create (Name : Name_Type) return Qualified_Name is
begin
return Qualified_Name (Name);
end Create;
end GPR2.Attribute;
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-22 Ed Schonberg
* einfo.ads, einfo.adb (Is_Actual_Subtype): New flag, defined
on subtypes that are created within subprogram bodies to handle
unconstrained composite formals.
* checks.adb (Apply_Predicate_Check): Do not generate a check on
an object whose type is an actual subtype.
* sem_ch6.adb (Set_Actual_Subtypes): Do not generate an
actual subtype for a formal whose base type is private.
Set Is_Actual_Subtype on corresponding entity after analyzing
its declaration.
Index: einfo.adb
===
--- einfo.adb (revision 237680)
+++ einfo.adb (working copy)
@@ -607,8 +607,8 @@
--Has_Inherited_InvariantsFlag291
--Is_Partial_Invariant_Procedure Flag292
+ --Is_Actual_Subtype Flag293
- --(unused)Flag293
--(unused)Flag294
--(unused)Flag295
--(unused)Flag296
@@ -2014,6 +2014,12 @@
return Flag69 (Id);
end Is_Access_Constant;
+ function Is_Actual_Subtype (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag293 (Id);
+ end Is_Actual_Subtype;
+
function Is_Ada_2005_Only (Id : E) return B is
begin
return Flag185 (Id);
@@ -5036,6 +5042,12 @@
Set_Flag69 (Id, V);
end Set_Is_Access_Constant;
+ procedure Set_Is_Actual_Subtype (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag293 (Id, V);
+ end Set_Is_Actual_Subtype;
+
procedure Set_Is_Ada_2005_Only (Id : E; V : B := True) is
begin
Set_Flag185 (Id, V);
@@ -9186,6 +9198,7 @@
W ("Is_Abstract_Subprogram", Flag19 (Id));
W ("Is_Abstract_Type",Flag146 (Id));
W ("Is_Access_Constant", Flag69 (Id));
+ W ("Is_Actual_Subtype", Flag293 (Id));
W ("Is_Ada_2005_Only",Flag185 (Id));
W ("Is_Ada_2012_Only",Flag199 (Id));
W ("Is_Aliased", Flag15 (Id));
Index: einfo.ads
===
--- einfo.ads (revision 237680)
+++ einfo.ads (working copy)
@@ -2232,6 +2232,10 @@
--Is_Access_Type (synthesized)
-- Applies to all entities, true for access types and subtypes
+--Is_Actual_Subtype (Flag293)
+-- Defined on all types, true for the generated constrained subtypes
+-- that are built for unconstrained composite actuals.
+
--Is_Ada_2005_Only (Flag185)
-- Defined in all entities, true if a valid pragma Ada_05 or Ada_2005
-- applies to the entity which specifically names the entity, indicating
@@ -7017,6 +7021,7 @@
function Is_Abstract_Subprogram (Id : E) return B;
function Is_Abstract_Type(Id : E) return B;
function Is_Access_Constant (Id : E) return B;
+ function Is_Actual_Subtype (Id : E) return B;
function Is_Ada_2005_Only(Id : E) return B;
function Is_Ada_2012_Only(Id : E) return B;
function Is_Aliased (Id : E) return B;
@@ -7689,6 +7694,7 @@
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True);
procedure Set_Is_Abstract_Type(Id : E; V : B := True);
procedure Set_Is_Access_Constant (Id : E; V : B := True);
+ procedure Set_Is_Actual_Subtype (Id : E; V : B := True);
procedure Set_Is_Ada_2005_Only(Id : E; V : B := True);
procedure Set_Is_Ada_2012_Only(Id : E; V : B := True);
procedure Set_Is_Aliased (Id : E; V : B := True);
@@ -8477,6 +8483,7 @@
pragma Inlin
[Ada] Analysis of pragmas containing integer expressions not verified properly
If a string is used as an argument instead of an integer,
Check_Arg_Is_OK_Static_Expression with Any_Integer will falsely verify causing
the compiler to halt compilation when the caller acts on the assumption that it
was verified. This patch creates checks so that Any_Integer works properly and
documentation to explain how unresolved types get handled.
-- Source --
-- static_int_test.adb
pragma C_Pass_By_Copy("JUNK"); -- Expects a static integer expression
procedure Static_Int_Test is
Another_Error : String := 1;
begin
null;
end Static_Int_Test;
-- Compilation and output --
$ gnatmake -q -f static_int_test.adb
static_int_test.adb:1:23: expected an integer type
static_int_test.adb:1:23: found a string type
static_int_test.adb:3:30: expected type "Standard.String"
static_int_test.adb:3:30: found type universal integer
gnatmake: "static_int_test.adb" compilation error
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-22 Justin Squirek
* sem_prag.adb (Check_Expr_Is_OK_Static_Expression): Fix ordering
of if-block and add in a condition to test for errors during
resolution.
* sem_res.adb (Resolution_Failed): Add comment to explain why
the type of a node which failed to resolve is set to the desired
type instead of Any_Type.
* sem_ch8.adb (Analyze_Object_Renaming): Add a check for Any_Type
to prevent crashes on Is_Access_Constant.
Index: sem_prag.adb
===
--- sem_prag.adb(revision 237686)
+++ sem_prag.adb(working copy)
@@ -5060,12 +5060,15 @@
Analyze_And_Resolve (Expr);
end if;
- if Is_OK_Static_Expression (Expr) then
-return;
+ -- An expression cannot be considered static if its resolution failed
+ -- or if it erroneous. Stop the analysis of the related pragma.
- elsif Etype (Expr) = Any_Type then
+ if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
raise Pragma_Exit;
+ elsif Is_OK_Static_Expression (Expr) then
+return;
+
-- An interesting special case, if we have a string literal and we
-- are in Ada 83 mode, then we allow it even though it will not be
-- flagged as static. This allows the use of Ada 95 pragmas like
@@ -5077,12 +5080,6 @@
then
return;
- -- Static expression that raises Constraint_Error. This has already
- -- been flagged, so just exit from pragma processing.
-
- elsif Is_OK_Static_Expression (Expr) then
-raise Pragma_Exit;
-
-- Finally, we have a real error
else
Index: sem_res.adb
===
--- sem_res.adb (revision 237680)
+++ sem_res.adb (working copy)
@@ -1974,7 +1974,12 @@
procedure Resolution_Failed is
begin
Patch_Up_Value (N, Typ);
+
+ -- Set the type to the desired one to minimize cascaded errors. Note
+ -- that this is an approximation and does not work in all cases.
+
Set_Etype (N, Typ);
+
Debug_A_Exit ("resolving ", N, " (done, resolution failed)");
Set_Is_Overloaded (N, False);
Index: sem_ch8.adb
===
--- sem_ch8.adb (revision 237680)
+++ sem_ch8.adb (working copy)
@@ -1022,22 +1022,30 @@
Resolve (Nam, T);
+ -- Do not perform the legality checks below when the resolution of
+ -- the renaming name failed because the associated type is Any_Type.
+
+ if Etype (Nam) = Any_Type then
+null;
+
-- Ada 2005 (AI-231): In the case where the type is defined by an
-- access_definition, the renamed entity shall be of an access-to-
-- constant type if and only if the access_definition defines an
-- access-to-constant type. ARM 8.5.1(4)
- if Constant_Present (Access_Definition (N))
+ elsif Constant_Present (Access_Definition (N))
and then not Is_Access_Constant (Etype (Nam))
then
-Error_Msg_N ("(Ada 2005): the renamed object is not "
- & "access-to-constant (RM 8.5.1(6))", N);
+Error_Msg_N
+ ("(Ada 2005): the renamed object is not access-to-constant "
+& "(RM 8.5.1(6))", N);
elsif not Constant_Present (Access_Definition (N))
and then Is_Access_Constant (Etype (Nam))
then
-Error_Msg_N ("(Ada 2005): the renamed object is not "
- & "access-to-variable (RM 8.5.1(6))", N);
+Error_Msg_N
+ ("(Ada 2005): the renamed object is not access-to-variable "
+ & "(RM 8.5.1(6))", N);
end if;
if
[Ada] Crash on config pragma Component_Alignment
Pragma Component_Alignment was not implemented properly and caused a crash
when used in a configuration file due to how it was applied via the scope
table. This patch correctly identifies this case and uses a global variable
Configuration_Component_Alignment to capture the value set during
configuration analysis and applies it in place of the default value.
-- Source --
-- stor_unit.adc
pragma Component_Alignment (Form => Storage_Unit);
-- pack_storage_unit.ads
package Pack_Storage_Unit is
pragma Component_Alignment (Form => Storage_Unit);
type Small_Int is new Integer range 0 .. 1;
for Small_Int'Size use 1;
type Rec is record
Comp_1 : Small_Int;
Comp_2 : Small_Int;
Comp_3 : Boolean;
Comp_4 : Integer;
Comp_5 : Long_Integer;
end record;
end Pack_Storage_Unit;
-- pack.ads
package Pack is
type Small_Int is new Integer range 0 .. 1;
for Small_Int'Size use 1;
type Rec is record
Comp_1 : Small_Int;
Comp_2 : Small_Int;
Comp_3 : Boolean;
Comp_4 : Integer;
Comp_5 : Long_Integer;
end record;
end Pack;
-- Compilation and output --
$ gcc -c -gnatR pack_storage_unit.ads > output1.txt
$ gcc -c -gnatR pack.ads -gnatec=stor_unit.adc > output2.txt
$ grep -v -F -x -f output1.txt output2.txt
Representation information for unit Pack (spec)
for Rec'Size use 128;
for Rec'Alignment use 8;
Comp_4 at 4 range 0 .. 31;
Comp_5 at 8 range 0 .. 63;
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-22 Justin Squirek
* sem_ch8.adb (Push_Scope): Add a check for when the
scope table is empty to assign the global variable
Configuration_Component_Alignment.
* sem.adb (Do_Analyze): Add Configuration_Component_Alignment
to be assigned when the environment is cleaned instead of the
default.
* sem.ads Add a global variable Configuration_Component_Alignment
to store the value given by pragma Component_Alignment in the
context of a configuration file.
* sem_prag.adb (Analyze_Pragma): Correct the case for
Component_Alignment so that the pragma is verified and add
comments to explain how it is applied to the scope stack.
Index: sem.adb
===
--- sem.adb (revision 237680)
+++ sem.adb (working copy)
@@ -1355,7 +1355,8 @@
Outer_Generic_Scope := Empty;
Scope_Suppress := Suppress_Options;
Scope_Stack.Table
- (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
+ (Scope_Stack.Last).Component_Alignment_Default :=
+ Configuration_Component_Alignment;
Scope_Stack.Table
(Scope_Stack.Last).Is_Active_Stack_Base := True;
Index: sem.ads
===
--- sem.ads (revision 237680)
+++ sem.ads (working copy)
@@ -461,6 +461,11 @@
-- Transient blocks have three associated actions list, to be inserted
-- before and after the block's statements, and as cleanup actions.
+ Configuration_Component_Alignment : Component_Alignment_Kind :=
+ Calign_Default;
+ -- Used for handling the pragma Component_Alignment in the context of a
+ -- configuration file.
+
type Scope_Stack_Entry is record
Entity : Entity_Id;
-- Entity representing the scope
Index: sem_ch8.adb
===
--- sem_ch8.adb (revision 237693)
+++ sem_ch8.adb (working copy)
@@ -8192,10 +8192,22 @@
SST.Save_Default_SSO := Default_SSO;
SST.Save_Uneval_Old := Uneval_Old;
+ -- Each new scope pushed onto the scope stack inherits the component
+ -- alignment of the previous scope. This emulates the "visibility"
+ -- semantics of pragma Component_Alignment.
+
if Scope_Stack.Last > Scope_Stack.First then
SST.Component_Alignment_Default := Scope_Stack.Table
(Scope_Stack.Last - 1).
Component_Alignment_Default;
+
+ -- Otherwise, this is the first scope being pushed on the scope
+ -- stack. Inherit the component alignment from the configuration
+ -- form of pragma Component_Alignment (if any).
+
+ else
+SST.Component_Alignment_Default :=
+ Configuration_Component_Alignment;
end if;
SST.Last_Subprogram_Name := null;
Index: sem_prag.adb
===
--- sem_prag.adb(revision 237693)
+++ sem_prag.adb(working copy)
@@ -12787,9 +12787,21 @@
("invalid Form parameter for pragma%", Form);
Re: [PATCH] gcc: ada: delete old $(P) reference
> From: Mike Frysinger > > The P variable was deleted back in Nov 2015 (svn rev 231062), > but its expansion was missed. Delete those now too. > > 2017-07-18 Mike Frysinger > > * gcc-interface/Makefile.in ($(P)): Delete OK, thanks.
Re: [PATCH] Adjust function name dumping
Richard, > When enabling free-lang-data the lang_hooks.decl_printable_name hook > gets reset. The following patch reduces the noise from that by > using verbosity 1 (do not print arguments) from the places where > we dump the function name and then follow by arguments manually. > > This makes dumping consistent with calls in the IL so you can > cut&paste & search in dumps easier (Ada dumps had case differences > for example). This requires a few changes in the testsuite dump scans > (but not too many to make the change controversical). > > Bootstrapped and tested on x86_64-unknown-linux-gnu, applied to trunk. > > Richard. > > 2017-08-23 Richard Biener > > * function.c (fndecl_name): Use verbosity 1 (no arguments) for > lang_hooks.decl_printable_name. > * print-rtl-function.c (print_rtx_function): Likewise. > * tree-pretty-print.c (dump_function_header): Likewise. > > * g++.dg/cpp1y/constexpr-instantiate.C: Adjust. > * g++.dg/tree-ssa/pr45605.C: Likewise. > * gnat.dg/noinline2.ad: Likewise.b > * gnat.dg/renaming6.ad: Likewise.b > * gnat.dg/renaming6.ad: Likewise.s > * gnat.dg/specs/noinline3.ad: Likewise.s You have typos in the a bove changelog BTW, the "b" and "s" should be part of the filenames (e.g. gnat.dg/noinline2.adb: Likewise.) I do not understand the changes in the ada testsuite: cana you explain why you renames some variables? Arno
Re: [PATCH] Adjust function name dumping
> > You have typos in the a bove changelog BTW, the "b" and "s" should be > > part of the filenames (e.g. gnat.dg/noinline2.adb: Likewise.) > > Ooops. Will fix. > > > I do not understand the changes in the ada testsuite: cana you explain why > > you renames some variables? > > Because the scan for not 'j' now breaks as the dump contains get_j > vs Get_J before. Rather than changing it for expected n times > I chose to rename the variable that shouldn't appear. OK, thanks for the answers. Arno
[Ada] Compiler crash on call to eliminated protected operation.
This patch fixes an omission in the handling of pragma Eliminate when applied to a protected operation. The pragma was properly processed, but a call to an eliminated protected operation was not flagged as an error, and the code generator aborted on a call to an undefined operation. Compiling: gcc -c -gnatec=gnat.adc data.adb must yield: data.adb:12:14: cannot reference subprogram "Some_Protected_Data" eliminated at Global_Pragmas.adc:4 data.adb:20:21: cannot reference subprogram "Some_Protected_Data" eliminated at Global_Pragmas.adc:4 --- -- List of unused entities to be placed in gnat.adc. -- pragma Eliminate (Data, Some_Protected_Data, Source_Location => "data.ads:12"); --- package Data is type Data_Type_T is new Natural; function Get_Private_Data return Data_Type_T; private protected type Some_Type is function Some_Protected_Data return Data_Type_T; private Data : Data_Type_T := 0; end Some_Type; end Data; --- package body Data is protected body Some_Type is function Some_Protected_Data return Data_Type_T is begin return Data; end Some_Protected_Data; function Redundant return Data_Type_T is begin return Some_Protected_Data; end; end Some_Type; My_Data : Some_Type; function Get_Private_Data return Data_Type_T is begin return My_Data.Some_Protected_Data; end Get_Private_Data; end Data; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * sem_res.adb (Resolve_Entry_Call): Check whether a protected operation is subject to a pragma Eliminate. Index: sem_res.adb === --- sem_res.adb (revision 251753) +++ sem_res.adb (working copy) @@ -7519,10 +7519,15 @@ if Nkind (Entry_Name) = N_Selected_Component then - -- Simple entry call + -- Simple entry or protected operation call Nam := Entity (Selector_Name (Entry_Name)); Obj := Prefix (Entry_Name); + + if Is_Subprogram (Nam) then +Check_For_Eliminated_Subprogram (Entry_Name, Nam); + end if; + Was_Over := Is_Overloaded (Selector_Name (Entry_Name)); else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
[Ada] Extension of 'Image in Ada2020.
AI12-0124 adds the notation Object'Image to the language, following the semantics of GNAT-defined attribute 'Img. This patch fixes an omission in the characterization of objects, which must include function calls and thus attribute references for attributes that are functions, as well as predefined operators. The following must compile and execute quietly: gnatmake -q img img --- procedure Img is type Enum is (A, BC, ABC, A_B_C, abcd, 'd'); type New_Enum is new Enum; function Ident (X : Enum) return Enum is begin return X; end Ident; E1 : New_Enum := New_Enum (Ident (BC)); type Int is new Long_Integer; type Der is new Int; function Ident (X : Der) return Der is begin return X; end Ident; V : Der := Ident (123); begin if New_Enum'Pred (E1)'Img /= "A" then raise Program_Error; end if; if New_Enum'Pred (E1)'Image /= "A" then raise Program_Error; end if; if Der'(V - 23)'Image /= "100" then raise Program_Error; end if; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * sem_util.adb (Is_Object_Reference): A function call is an object reference, and thus attribute references for attributes that are functions (such as Pred and Succ) as well as predefined operators are legal in contexts that require an object, such as the prefix of attribute Img and the Ada2020 version of 'Image. Index: sem_util.adb === --- sem_util.adb(revision 251753) +++ sem_util.adb(working copy) @@ -14153,18 +14153,21 @@ -- In Ada 95, a function call is a constant object; a procedure -- call is not. -when N_Function_Call => +-- Note that predefined operators are functions as well, and so +-- are attributes that are (can be renamed as) functions. + +when N_Function_Call | N_Binary_Op | N_Unary_Op => return Etype (N) /= Standard_Void_Type; --- Attributes 'Input, 'Loop_Entry, 'Old, and 'Result produce --- objects. +-- Attributes references 'Loop_Entry, 'Old, and 'Result yield +-- objects, even though they are not functions. when N_Attribute_Reference => return - Nam_In (Attribute_Name (N), Name_Input, - Name_Loop_Entry, + Nam_In (Attribute_Name (N), Name_Loop_Entry, Name_Old, - Name_Result); + Name_Result) + or else Is_Function_Attribute_Name (Attribute_Name (N)); when N_Selected_Component => return
[Ada] Spurious error with formal incomplete types
This patch fixes a spurious error on the use of of a generic unit with formal incomplete types, as a formal package in another generic unit, when the actuals for the incomplete types are themselves formal incomplete types. The treatment of incomplete subtypes that are created for such formals is now more consistent with the handling of other subtypes, given their increased use in Ada2012. The following must compile quietly: --- gcc -c promote_2_streams.ads generic type Data_Stream_Type; type Data_Type; with function Has_Data (Stream : not null access Data_Stream_Type) return Boolean; with function Consume (Stream : not null access Data_Stream_Type) return Data_Type; package Data_Streams is end; --- with Data_Streams; generic type Data1_Type is private; type Data2_Type is private; with package DS1 is new Data_Streams (Data_Type => Data1_Type, others => <>); with package DS2 is new Data_Streams (Data_Type => Data2_Type, others => <>); package Promote_2_Streams is type Which_Type is range 1 .. 2; type Data_Type (Which : Which_Type := 1) is record case Which is when 1 => Data1 : Data1_Type; when 2 => Data2 : Data2_Type; end case; end record; function Consume1 (Stream : not null access DS1.Data_Stream_Type) return Data_Type is ((Which => 1, Data1 => DS1.Consume (Stream))); function Consume2 (Stream : not null access DS2.Data_Stream_Type) return Data_Type is ((Which => 2, Data2 => DS2.Consume (Stream))); package PS1 is new Data_Streams (DS1.Data_Stream_Type, Data_Type, DS1.Has_Data, Consume1); package PS2 is new Data_Streams (DS2.Data_Stream_Type, Data_Type, DS2.Has_Data, Consume2); end Promote_2_Streams; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * einfo.adb (Designated_Type): Use Is_Incomplete_Type to handle properly incomplete subtypes that may be created by explicit or implicit declarations. (Is_Base_Type): Take E_Incomplete_Subtype into account. (Subtype_Kind): Ditto. * sem_ch3.adb (Build_Discriminated_Subtype): Set properly the Ekind of a subtype of a discriminated incomplete type. (Fixup_Bad_Constraint): Use Subtype_Kind in all cases, including incomplete types, to preserve error reporting. (Process_Incomplete_Dependents): Do not create a subtype declaration for an incomplete subtype that is created internally. * sem_ch7.adb (Analyze_Package_Specification): Handle properly incomplete subtypes that do not require a completion, either because they are limited views, of they are generic actuals. Index: sem_ch3.adb === --- sem_ch3.adb (revision 251753) +++ sem_ch3.adb (working copy) @@ -10094,7 +10094,11 @@ -- elaboration, because only the access type is needed in the -- initialization procedure. - Set_Ekind (Def_Id, Ekind (T)); + if Ekind (T) = E_Incomplete_Type then +Set_Ekind (Def_Id, E_Incomplete_Subtype); + else +Set_Ekind (Def_Id, Ekind (T)); + end if; if For_Access and then Within_Init_Proc then null; @@ -13629,15 +13633,9 @@ procedure Fixup_Bad_Constraint is begin - -- Set a reasonable Ekind for the entity. For an incomplete type, - -- we can't do much, but for other types, we can set the proper - -- corresponding subtype kind. + -- Set a reasonable Ekind for the entity, including incomplete types. - if Ekind (T) = E_Incomplete_Type then -Set_Ekind (Def_Id, Ekind (T)); - else -Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); - end if; + Set_Ekind (Def_Id, Subtype_Kind (Ekind (T))); -- Set Etype to the known type, to reduce chances of cascaded errors @@ -20802,7 +20800,9 @@ -- Ada 2005 (AI-412): Transform a regular incomplete subtype into a -- corresponding subtype of the full view. - elsif Ekind (Priv_Dep) = E_Incomplete_Subtype then + elsif Ekind (Priv_Dep) = E_Incomplete_Subtype +and then Comes_From_Source (Priv_Dep) + then Set_Subtype_Indication (Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep))); Set_Etype (Priv_Dep, Full_T); Index: sem_ch7.adb === --- sem_ch7.adb (revision 251753) +++ sem_ch7.adb (working copy) @@ -1441,11 +1441,14 @@ -- Check on incomplete types - -- AI05-0213: A formal incomplete type has no completion + -- AI05-0213: A formal incomplete type has no completion, + -- and neither does the corresponding subtype in an instance. - if Ekind (E) = E_Incomplete_Type + if Is_Incomplete_Type (E)
[Ada] Enable automatic reordering of components in record types
This activates the reordering of components in record types with convention Ada that was implemented some time ago in the compiler. The idea is to get rid of blatant inefficiencies that the layout in textual order of the source code can bring about, typically when the offset of components is not fixed or not a multiple of the storage unit. The reordering is automatic and silent by default, but both aspects can be toggled: pragma No_Component_Reordering disables it either on a per-record- type or on a global basis, while -gnatw.q gives a warning for each affected component in record types. When pragma No_Component_Reordering is used as a configuration pragma to disable it, there is a requirement that the pragma be used consistently within a partition. The typical example is a discriminated record type with an array component, which yields with -gnatw.q -gnatl: 1. package P is 2. 3. type R (D : Positive) is record 4. S : String (1 .. D); | >>> warning: record layout may cause performance issues >>> warning: component "S" whose length depends on a discriminant >>> warning: comes too early and was moved down 5. I : Integer; 6. end record; 7. 8. end P; In this case, the compiler moves component S to the last position in the record so that every component is at a fixed offset from the start. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Eric Botcazou * ali.ads (ALIs_Record): Add No_Component_Reordering component. (No_Component_Reordering_Specified): New switch. * ali.adb (Initialize_ALI): Set No_Component_Reordering_Specified. (Scan_ALI): Set No_Component_Reordering and deal with NC marker. * bcheck.adb (Check_Consistent_No_Component_Reordering): New check. (Check_Configuration_Consistency): Invoke it. * debug.adb (d.r): Toggle the effect of the switch. (d.v): Change to no-op. * einfo.ads (Has_Complex_Representation): Restrict to record types. (No_Reordering): New alias for Flag239. (OK_To_Reorder_Components): Delete. (No_Reordering): Declare. (Set_No_Reordering): Likewise. (OK_To_Reorder_Components): Delete. (Set_OK_To_Reorder_Components): Likewise. * einfo.adb (Has_Complex_Representation): Expect record types. (No_Reordering): New function. (OK_To_Reorder_Components): Delete. (Set_Has_Complex_Representation): Expect base record types. (Set_No_Reordering): New procedure. (Set_OK_To_Reorder_Components): Delete. (Write_Entity_Flags): Adjust to above change. * fe.h (Debug_Flag_Dot_R): New macro and declaration. * freeze.adb (Freeze_Record_Type): Remove conditional code setting OK_To_Reorder_Components on record types with convention Ada. * lib-writ.adb (Write_ALI): Deal with NC marker. * opt.ads (No_Component_Reordering): New flag. (No_Component_Reordering_Config): Likewise. (Config_Switches_Type): Add No_Component_Reordering component. * opt.adb (Register_Opt_Config_Switches): Copy No_Component_Reordering onto No_Component_Reordering_Config. (Restore_Opt_Config_Switches): Restore No_Component_Reordering. (Save_Opt_Config_Switches): Save No_Component_Reordering. (Set_Opt_Config_Switches): Set No_Component_Reordering. * par-prag.adb (Prag): Deal with Pragma_No_Component_Reordering. * sem_ch3.adb (Analyze_Private_Extension_Declaration): Also set the No_Reordering flag from the default. (Build_Derived_Private_Type): Likewise. (Build_Derived_Record_Type): Likewise. Then inherit it for untagged types and clean up handling of similar flags. (Record_Type_Declaration): Likewise. * sem_ch13.adb (Same_Representation): Deal with No_Reordering and remove redundant test on Is_Tagged_Type. * sem_prag.adb (Analyze_Pragma): Handle No_Component_Reordering. (Sig_Flags): Likewise. * snames.ads-tmpl (Name_No_Component_Reordering): New name. (Pragma_Id): Add Pragma_No_Component_Reordering value. * warnsw.adb (Set_GNAT_Mode_Warnings): Enable -gnatw.q as well. * gcc-interface/decl.c (gnat_to_gnu_entity) : Copy the layout of the parent type only if the No_Reordering settings match. (components_to_record): Reorder record types with convention Ada by default unless No_Reordering is set or -gnatd.r is specified and do not warn if No_Reordering is set in GNAT mode. Index: sem_ch3.adb === --- sem_ch3.adb (revision 251759) +++ sem_ch3.adb (working copy) @@ -5015,6 +5015,7 @@ Set_Ekind(T, E_Record_Type_With_Private); Init_Size_Align (T); Set_Default_SSO (T); + Set_No_Reordering
[Ada] Resolution of set membersip operations with overloaded alternatives
This patch fixes a bug in the resolution of set membership operations when
the expression and/or the alternatives on the right-hand side are overloaded.
If a given overloaded alternative is resolved to a unique type by intersection
with the types of previous alternatives, the type is used subsequently to
resolve the expression itself. If the alternative is an enumeration literal,
it must be replaced by the literal correspoding to the selected interpretation,
because subsequent resolution will not replace the entity itself.
The following must compile and run quietly:
gnatmake -q -gnatws c45
c45
---
with Text_IO; use Text_IO;
procedure C45 is
procedure Failed (Msg : String) is
begin
Put_Line (Msg);
end;
type Month is (Jan, Feb, Mar, Apr, May, Jun, Jul, Aug, Sep, Oct, Nov, Dec);
type Radix is (Bin, Oct, Dec, Hex);
type Shape is (Tri, Sqr, Pnt, Hex, Oct);
-- Oct is defined for all three types; Dec for all but Shape; and Hex for
-- all but Month.
-- Three identical functions, one for each type. These provide no
-- overloading information at all.
function Item return Month is
begin
return Aug;
end Item;
function Item return Radix is
begin
return Dec;
end Item;
function Item return Shape is
begin
return Hex;
end Item;
begin
-- No overloading in the choices:
if Item in Jan .. Mar then -- type Month
Failed ("Wrong result - no choice overloading (1)");
end if;
if Item in Tri | Sqr | Pnt then -- type Radix
Failed ("Wrong result - no choice overloading (2)");
end if;
-- A single overloaded choice:
if Item not in May .. Oct then -- type Month
Failed ("Wrong result - single overloaded choice (3)");
end if;
if Item not in Bin | Dec then -- type Radix
Failed ("Wrong result - single overloaded choice (4)");
end if;
if Item not in Tri | Sqr | Hex then -- type Shape
Failed ("Wrong result - single overloaded choice (5)");
end if;
-- At least one choice without overloading:
if Item in Jan | Oct .. Dec then -- type Month
Failed ("Wrong result - a non-overloaded choice (6)");
end if;
if Item not in Oct .. Hex | Bin then -- type Radix
Failed ("Wrong result - a non-overloaded choice (7)");
end if;
if Item not in Oct | Sqr | Hex then -- type Shape
Failed ("Wrong result - a non-overloaded choice (8)");
end if;
if Item not in Oct | Sqr | Hex | Tri then -- type Shape
Failed ("Wrong result - a non-overloaded choice (9)");
end if;
if Item not in Dec | Hex | Oct | Bin then -- type Radix
Failed ("Wrong result - a non-overloaded choice (10");
end if;
-- The ultimate: everything is overloaded, but there still is only
-- one possible solution.
if Item not in Oct | Dec | Hex then -- type Radix
Failed ("Wrong result - everything overloaded (11)");
end if;
end C45;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Ed Schonberg
* sem_ch4.adb (Analyze_Set_Membership): If an alternative
in a set membership is an overloaded enumeration literal, and
the type of the alternative is resolved from a previous one,
replace the entity of the alternative as well as the type,
to prevent inconsistencies between the entity and the type.
Index: sem_ch4.adb
===
--- sem_ch4.adb (revision 251753)
+++ sem_ch4.adb (working copy)
@@ -2935,11 +2935,20 @@
-- for all of them.
Set_Etype (Alt, It.Typ);
+
+ -- If the alternative is an enumeration literal, use
+ -- the one for this interpretation.
+
+ if Is_Entity_Name (Alt) then
+ Set_Entity (Alt, It.Nam);
+ end if;
+
Get_Next_Interp (Index, It);
if No (It.Typ) then
Set_Is_Overloaded (Alt, False);
Common_Type := Etype (Alt);
+
end if;
Candidate_Interps := Alt;
[Ada] Minor cleanup in support machinery for inter-unit inlining
The inter-unit inlining done by the compiler requires a dedicated machinery to deal with the public status of library-level entities, since it breaks the private/plublic semantic barrier of the language. This is a minor cleanup to this machinery, no functional changes. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Eric Botcazou * sem_ch7.adb (Has_Referencer): Move up and expand comment explaining the test used to detect inlining. Use same test in second occurrence. (Analyze_Package_Body_Helper): Minor formatting fixes. Index: sem_ch7.adb === --- sem_ch7.adb (revision 251762) +++ sem_ch7.adb (working copy) @@ -392,6 +392,13 @@ -- An inlined subprogram body acts as a referencer + -- Note that we test Has_Pragma_Inline here in addition + -- to Is_Inlined. We are doing this for a client, since + -- we are computing which entities should be public, and + -- it is the client who will decide if actual inlining + -- should occur, so we need to catch all cases where the + -- subprogram may be inlined by the client. + if Is_Inlined (Decl_Id) or else Has_Pragma_Inline (Decl_Id) then @@ -413,18 +420,13 @@ else Decl_Id := Defining_Entity (Decl); - -- An inlined body acts as a referencer. Note that an - -- inlined subprogram remains Is_Public as gigi requires - -- the flag to be set. + -- An inlined body acts as a referencer, see above. Note + -- that an inlined subprogram remains Is_Public as gigi + -- requires the flag to be set. - -- Note that we test Has_Pragma_Inline here rather than - -- Is_Inlined. We are compiling this for a client, and - -- it is the client who will decide if actual inlining - -- should occur, so we need to assume that the procedure - -- could be inlined for the purpose of accessing global - -- entities. - - if Has_Pragma_Inline (Decl_Id) then + if Is_Inlined (Decl_Id) + or else Has_Pragma_Inline (Decl_Id) + then if Top_Level and then not Contains_Subprograms_Refs (Decl) then @@ -915,11 +917,11 @@ -- down the number of global symbols that do not neet public visibility -- as this has two beneficial effects: --(1) It makes the compilation process more efficient. - --(2) It gives the code generatormore freedom to optimize within each + --(2) It gives the code generator more leeway to optimize within each --unit, especially subprograms. - -- This is done only for top level library packages or child units as - -- the algorithm does a top down traversal of the package body. + -- This is done only for top-level library packages or child units as + -- the algorithm does a top-down traversal of the package body. if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id)) and then not Is_Generic_Unit (Spec_Id)
[Ada] Spurious errors on derived untagged types with partial constraints
This patch fixes the handling of untagged discriminated derived types that constrain some parent discriminants and rename others. The compiler failed to handle a change of representation on the derived type, and generated faulty code for the initialization procedure or such a derived type. Executing: --- gnatmake -q p p -- must yield: -- 1234 TRUE 20 discriminant rules!! --- with Q; use Q; with Text_IO; use Text_IO; procedure P is procedure Inner (B : Base) is begin null; -- Put_Line (B.S); Put_Line (Integer'Image (B.I)); Put_Line (Boolean'Image (B.B)); Put_Line (Integer'Image (B.D)); Put_Line (B.S); end; D1 : Derived (True); begin D1.S := "discriminant rules!!"; Inner (Base (D1)); end; --- package Q is type Base (D : Positive; B : Boolean) is record I : Integer := 1234; S : String (1 .. D); -- := (1 .. D => 'Q'); end record; type Derived (B : Boolean) is new Base (D => 20, B => B); for Derived use record I at 0 range 0 .. 31; end record; Thing : Derived (False); end Q; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * exp_ch4.adb (Handle_Changed_Representation): For an untagged derived type with a mixture of renamed and constrained parent discriminants, the constraint for the target must obtain the discriminant values from both the operand and from the stored constraint for it, given that the constrained discriminants are not visible in the object. * exp_ch5.adb (Make_Field_Assign): The type of the right-hand side may be derived from that of the left-hand side (as in the case of an assignment with a change of representation) so the discriminant to be used in the retrieval of the value of the component must be the entity in the type of the right-hand side. Index: exp_ch5.adb === --- exp_ch5.adb (revision 251753) +++ exp_ch5.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1448,9 +1448,21 @@ U_U : Boolean := False) return Node_Id is A: Node_Id; +Disc : Entity_Id; Expr : Node_Id; begin + +-- The discriminant entity to be used in the retrieval below must +-- be one in the corresponding type, given that the assignment +-- may be between derived and parent types. + +if Is_Derived_Type (Etype (Rhs)) then + Disc := Find_Component (R_Typ, C); +else + Disc := C; +end if; + -- In the case of an Unchecked_Union, use the discriminant -- constraint value as on the right-hand side of the assignment. @@ -1463,7 +1475,7 @@ Expr := Make_Selected_Component (Loc, Prefix=> Duplicate_Subexpr (Rhs), - Selector_Name => New_Occurrence_Of (C, Loc)); + Selector_Name => New_Occurrence_Of (Disc, Loc)); end if; A := Index: exp_ch4.adb === --- exp_ch4.adb (revision 251758) +++ exp_ch4.adb (working copy) @@ -10627,7 +10627,6 @@ Temp : Entity_Id; Decl : Node_Id; Odef : Node_Id; - Disc : Node_Id; N_Ix : Node_Id; Cons : List_Id; @@ -10657,23 +10656,70 @@ if not Is_Constrained (Target_Type) then if Has_Discriminants (Operand_Type) then - Disc := First_Discriminant (Operand_Type); - if Disc /= First_Stored_Discriminant (Operand_Type) then - Disc := First_Stored_Discriminant (Operand_Type); - end if; + -- A change of representation can only apply to untagged + -- types. We need to build the constraint that applies to + -- the target type, using the constraints of the operand. + -- The analysis is complicated if there are both inherited + -- discriminants and constrained discriminants. + -- We iterate over the discriminants of the target, and + -- find the discriminant of the same name
[Ada] Restore original implementation of internal Table package
This wasn't explicitly mentioned but the previous changes also replaced the
internal Table package used in the compiler by GNAT.Tables, resulting in a
large performance hit for the compiler because the memory management scheme
of the latter is very inefficient.
This restores the original implementation, which brings about a 10% speedup
in clock time on a typical compilation at -O0.
In addition, also use Table instead of GNAT.Table consistently in compiler
units: most compiler units instantiate the Table package when they need a
resizable array but a few of them were instantiating GNAT.Table instead, which
is less efficient and creates an additional dependency on the runtime.
This changes these units to using the Table package, which is immediate since
the interface is (essentially) the same.
No functional changes.
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Eric Botcazou
* table.ads, table.adb: Restore original implementation.
* namet.h (Names_Ptr): Adjust back.
(Name_Chars_Ptr): Likewise.
* uintp.h (Uints_Ptr): Likewise.
(Udigits_Ptr): Likewise.
* g-table.ads: Remove pragma Compiler_Unit_Warning.
* par_sco.adb: Do not with GNAT.Table and use Table consistently.
* scos.ads: Replace GNAT.Table with Table and adjust instantiations.
* spark_xrefs.ads: Likewise.
* scos.h: Undo latest changes.
* gcc-interfaces/trans.c (gigi): Likewise.
Index: g-table.ads
===
--- g-table.ads (revision 251753)
+++ g-table.ads (working copy)
@@ -41,8 +41,6 @@
-- GNAT.Table
-- Table (the compiler unit)
-pragma Compiler_Unit_Warning;
-
with GNAT.Dynamic_Tables;
generic
Index: namet.h
===
--- namet.h (revision 251753)
+++ namet.h (working copy)
@@ -45,11 +45,11 @@
};
/* Pointer to names table vector. */
-#define Names_Ptr namet__name_entries__tab__the_instance
+#define Names_Ptr namet__name_entries__table
extern struct Name_Entry *Names_Ptr;
/* Pointer to name characters table. */
-#define Name_Chars_Ptr namet__name_chars__tab__the_instance
+#define Name_Chars_Ptr namet__name_chars__table
extern char *Name_Chars_Ptr;
/* This is Hostparm.Max_Line_Length. */
Index: par_sco.adb
===
--- par_sco.adb (revision 251753)
+++ par_sco.adb (working copy)
@@ -44,7 +44,6 @@
with GNAT.HTable; use GNAT.HTable;
with GNAT.Heap_Sort_G;
-with GNAT.Table;
package body Par_SCO is
@@ -76,12 +75,13 @@
-- running some steps multiple times (the second pass has to be started
-- from multiple places).
- package SCO_Raw_Table is new GNAT.Table
+ package SCO_Raw_Table is new Table.Table
(Table_Component_Type => SCO_Table_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial=> 500,
- Table_Increment => 300);
+ Table_Increment => 300,
+ Table_Name => "Raw_Table");
---
-- Unit Number Table --
Index: scos.ads
===
--- scos.ads(revision 251753)
+++ scos.ads(working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,10 +29,9 @@
-- is used in the ALI file.
with Namet; use Namet;
+with Table;
with Types; use Types;
-with GNAT.Table;
-
package SCOs is
-- SCO information can exist in one of two forms. In the ALI file, it is
@@ -383,12 +382,13 @@
-- For the SCO for a pragma/aspect, gives the pragma/apsect name
end record;
- package SCO_Table is new GNAT.Table (
+ package SCO_Table is new Table.Table (
Table_Component_Type => SCO_Table_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial=> 500,
- Table_Increment => 300);
+ Table_Increment => 300,
+ Table_Name => "Table");
Is_Decision : constant array (Character) of Boolean :=
('E' | 'G' | 'I' | 'P' | 'a' | 'A' | 'W' | 'X' => True,
@@ -530,12 +530,13 @@
end record;
- package SCO_Unit_Table is new GNAT.Table (
+ package SCO_Unit_Table is new Table.Table (
Table_Component_Type => SCO_Unit_Table_Entry,
Table_I
[Ada] Primitive functions that require one formal and return an array
Primitive functions whose first formal is a controlling parameter, whose
other formals have defaults and whose result is an array type can lead to
ambiguities when the result of such a call is the prefix of an indexed
component. The interpretation that analyzes Obj.F (X, Y) into F (Obj)(X, Y)
is only legal if the first parameter of F is a controlling parameter. This
additional guard was previously missing from the predicate, leading to
malformed trees and a compiler crash.
Compiling huckel.adb must yield:
huckel.adb:135:27: expected type "Real" defined at huckel.ads:9
huckel.adb:135:27: found type "Ada.Numerics.Generic_Real_Arrays.Real_Matrix"
from instance at huckel.ads:16
-- Huckel package
-- This is a translation from Fortran II code documented in the
-- book "Computing Methods for Quantum Organic Chemistry"
with Ada.Numerics.Generic_Real_Arrays;
package Huckel is
type Real is digits 15;
type Molecule (Atoms : Positive) is tagged private;
function Input return Molecule;
procedure Compute_Energies(Item : in out Molecule);
procedure Output(Item : in Molecule);
private
package Matrices is new Ada.Numerics.Generic_Real_Arrays(Real);
use Matrices;
type Molecule (Atoms : Positive) is tagged record
Orbitals: Positive;
Atomic_Matrix : Real_Matrix(1..Atoms, 1..Atoms);
Atomic_Diagonal : Real_Vector(1..Atoms);
Unit_Matrix : Real_Matrix(1..Atoms, 1..Atoms);
Bond_Orders : Real_Matrix(1..Atoms, 1..Atoms);
Free_Valences : Real_vector(1..Atoms);
end record;
end Huckel;
---
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
with Ada.Text_IO;
with Ada.Numerics.Generic_Elementary_Functions;
package body Huckel is
package Real_IO is new Ada.Text_IO.Float_IO(Real);
use Real_Io;
---
-- Input --
---
function Input return Molecule is
Num_Atoms : Positive;
Num_Orbs : Positive;
begin
Get(Item => Num_Atoms);
Get(Item => Num_Orbs);
declare
Temp : Molecule(Atoms => Num_Atoms);
begin
Temp.Orbitals := Num_Orbs;
-- Read the atomic matrix into the upper semi-matrix of Atomic_Matrix
for I in 1..Num_Atoms loop
for J in 1..I loop
Get(Item => Temp.Atomic_Matrix(J, I));
-- Print the input matrix in lower semi-matrix format
Put(Item =>
Temp.Atomic_Matrix(J,I), Aft => 0, Fore => 2, Exp => 0);
-- Make all bonding terms negative
Temp.Atomic_Matrix(I, J) := -Temp.Atomic_Matrix(I,J);
end loop;
New_Line;
end loop;
return Temp;
end;
end Input;
-- Modify --
procedure Modify(Item : in out Molecule) is
Num_Mods : natural;
I, J : Positive;
Modification : Real;
begin
Get(Item => Num_Mods);
if Num_Mods > 0 then
New_Line(3);
Put_Line("Modifications");
for Num in 1..Num_Mods loop
Get(Item => I);
Get(Item => J);
Get(Item => Modification);
Put(Item => I, Width => 3);
Put(Item => J, Width => 6);
Put(Item => Modification, Aft => 3, Fore => 7, Exp => 0);
New_Line;
if I = J then
Item.Atomic_Diagonal(J) := Modification;
elsif I < J then
Item.Atomic_Matrix(I, J) := Modification;
else
Item.Atomic_Matrix(J, I) := Modification;
end if;
end loop;
end if;
end Modify;
--
-- Pahy --
--
procedure Pahy(Item : in out Molecule) is
begin
for J in 1..Item.Atoms loop
for I in 1..J loop
Item.Atomic_Matrix(I, J) := Item.Atomic_Matrix(J, I);
Item.Atomic_Diagonal(J) := Item.Atomic_Matrix(J,J);
end loop;
end loop;
end Pahy;
-- Scofi1 --
procedure Scofi1(Item : in out Molecule) is
package elem_funcs is new Ada.Numerics.Generic_Elementary_Functions(real);
use elem_funcs;
Max : Real := 0.0;
J_up : Natural;
Aii : Real;
Ajj : Real;
Aod : Real;
Asq : Real;
Eps : constant Real := 1.0e-16;
diffr : Real;
sign : Real;
tden : Real;
Tank : Real;
C: Real;
S : Real;
xj : Real;
begin
-- initialize unit matrix
Item.Unit_Matrix := (Others => (Others => 0.0));
for I in 1..Item.Atoms loop
Item.Unit_Matrix(I, I) := 1.0;
end loop;
for I in 2..Item.Atoms loop
J_Up := I - 1;
for J in 1..J_Up loop
Aii := Item.Atomic_Diagonal(I);
Ajj := Item.Atomic_Diagonal(J);
Aod := Item.Atomic_Matrix(J, I);
Asq := Aod * Aod;
if Asq > Max then
[Ada] Inherited aspects that may be delayed in a parent type
This patch fixes an omission in the handling of delayed aspects on derived types. The type may inherit a representation aspect from its parent, but have no explicit aspect specifications. At the point it is frozen, the parent is frozen as well and its explicit aspects have been analyzed. The inherited aspects of the derived type can then be captured properly. Tested in ACATS test C35A001. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * freeze.adb (Freeze_Entity): For a derived type that has no explicit delayed aspects but may inherit delayed aspects from its parent type, analyze aspect at freeze point for proper capture of an inherited aspect. Index: freeze.adb === --- freeze.adb (revision 251760) +++ freeze.adb (working copy) @@ -5266,8 +5266,12 @@ -- pragma or attribute definition clause in the tree at this point. We -- also analyze the aspect specification node at the freeze point when -- the aspect doesn't correspond to pragma/attribute definition clause. + -- In addition, a derived type may have inherited aspects that were + -- delayed in the parent, so these must also be captured now. - if Has_Delayed_Aspects (E) then + if Has_Delayed_Aspects (E) + or else May_Inherit_Delayed_Rep_Aspects (E) + then Analyze_Aspects_At_Freeze_Point (E); end if;
[Ada] Pragma No_Return on generic units
This patch ensures that if a pragma No_Return applies to a generic subprogram , all its instantiations are treated as No_Return subprograms as well. Tested in ACATS 4.1D C651001. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * sem_ch12.adb (Analyze_Subprogram_Instantiation): Propagate No_Return flag to instance if pragma applies to generic unit. This must be done explicitly because the pragma does not appear directly in the generic declaration (unlike the corresponding aspect specification). Index: sem_ch12.adb === --- sem_ch12.adb(revision 251753) +++ sem_ch12.adb(working copy) @@ -5382,6 +5382,15 @@ Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); + -- Propagate No_Return if pragma applied to generic unit. This must + -- be done explicitly because pragma does not appear in generic + -- declaration (unlike the aspect case). + + if No_Return (Gen_Unit) then +Set_No_Return (Act_Decl_Id); +Set_No_Return (Anon_Id); + end if; + Set_Has_Pragma_Inline_Always (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); Set_Has_Pragma_Inline_Always
[Ada] Crash on generic subprogram with aspect No_Return.
This patch fixes a compiler abort on a generic unit to which the aspect No_Return applies. Tested in ACATS 4.1D C651002. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * freeze.adb (Freeze_Entity): Do not generate a freeze node for a generic unit, even if it includes delayed aspect specifications. Freeze nodes for generic entities must never appear in the tree that reaches the back-end of the compiler. Index: freeze.adb === --- freeze.adb (revision 251765) +++ freeze.adb (working copy) @@ -5489,6 +5489,13 @@ then Explode_Initialization_Compound_Statement (E); end if; + +-- Do not generate a freeze node for a generic unit. + +if Is_Generic_Unit (E) then + Result := No_List; + goto Leave; +end if; end if; -- Case of a type or subtype being frozen
[Ada] Improve error message when function is used in a call statement
A typical error for new users of Ada is to call functions in a call
statement. Improve the error message for these users, to better indicate
what the error is in that case.
The following compilation raises the new message.
$ gcc -c main.adb
1. procedure Main is
2.function Lol return Integer is (0);
3. begin
4.Lol;
|
>>> cannot use call to function "Lol" as a statement
>>> return value of a function call cannot be ignored
5. end Main;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Yannick Moy
* sem_res.adb (Resolve): Update message for function call as statement.
Index: sem_res.adb
===
--- sem_res.adb (revision 251755)
+++ sem_res.adb (working copy)
@@ -2533,8 +2533,11 @@
and then Ekind (Entity (Name (N))) = E_Function
then
Error_Msg_NE
-("cannot use function & in a procedure call",
+("cannot use call to function & as a statement",
Name (N), Entity (Name (N)));
+ Error_Msg_N
+("\return value of a function call cannot be ignored",
+ Name (N));
-- Otherwise give general message (not clear what cases this
-- covers, but no harm in providing for them).
[Ada] No_Return procedures in renaming declarations.
This patch implements legality rule in 6.5.1 (7/2): if a renaming as body
completes a nonreturning procedure declaration, the renamed procedure must
be nonreturning as well. Previously GNAT only produced a warning in such
cases.
Tested in ACATS test B651002.
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Ed Schonberg
* sem_ch6.adb (Check_Returns): Clean up warnings coming from
generated bodies for renamings that are completions, when renamed
procedure is No_Return.
* sem_ch8.adb (Analyze_Subprogram_Renaming): Implement legality
rule in 6.5.1 (7/2): if a renaming is a completion of a subprogram
with No_Return, the renamed entity must be No_Return as well.
Index: sem_ch6.adb
===
--- sem_ch6.adb (revision 251762)
+++ sem_ch6.adb (working copy)
@@ -6693,7 +6693,11 @@
Error_Msg_N
("implied return after this statement "
& "would have raised Program_Error", Last_Stm);
- else
+
+ -- In normal compilation mode, do not warn on a generated
+ -- call (e.g. in the body of a renaming as completion).
+
+ elsif Comes_From_Source (Last_Stm) then
Error_Msg_N
("implied return after this statement "
& "will raise Program_Error??", Last_Stm);
Index: sem_ch8.adb
===
--- sem_ch8.adb (revision 251762)
+++ sem_ch8.adb (working copy)
@@ -2946,6 +2946,14 @@
Check_Fully_Conformant (New_S, Rename_Spec);
Set_Public_Status (New_S);
+ if No_Return (Rename_Spec)
+and then not No_Return (Entity (Nam))
+ then
+Error_Msg_N ("renaming completes a No_Return procedure", N);
+Error_Msg_N
+ ("\renamed procedure must be nonreturning (RM 6.5.1 (7/2))", N);
+ end if;
+
-- The specification does not introduce new formals, but only
-- repeats the formals of the original subprogram declaration.
-- For cross-reference purposes, and for refactoring tools, we
[Ada] Better warning on access to string at negative or null index
The warning issued when accessing a string at a negative or null index
was misleading, suggesting to use S'First - 1 as correct index, which
it is obviously not. Add a detection for negative or null index when
accessing a standard string, so that an appropriate warning is issued.
Also add a corresponding warning for other arrays, which is currently
not triggered by this detection mechanism under -gnatww
The following compilation shows the new warning:
$ gcc -c cstr.adb
1. procedure Cstr (X : in out String; J : Integer := -1) is
2. begin
3.X(0 .. J) := "";
|
>>> warning: string index should be positive
>>> warning: static expression fails Constraint_Check
4.X(0) := 'c';
|
>>> warning: string index should be positive
>>> warning: static expression fails Constraint_Check
5.X(0 .. 4) := "hello";
13
>>> warning: string index should be positive
>>> warning: static expression fails Constraint_Check
>>> warning: index for "X" may assume lower bound of 1
>>> warning: suggested replacement: "X'First + 3"
6. end Cstr;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Yannick Moy
* sem_warn.adb (Warn_On_Suspicious_Index): Improve warning when the
literal index used to access a string is null or negative.
Index: sem_warn.adb
===
--- sem_warn.adb(revision 251772)
+++ sem_warn.adb(working copy)
@@ -46,6 +46,7 @@
with Snames; use Snames;
with Stand;use Stand;
with Stringt; use Stringt;
+with Tbuild; use Tbuild;
with Uintp;use Uintp;
package body Sem_Warn is
@@ -3878,6 +3879,13 @@
procedure Warn1;
-- Generate first warning line
+ procedure Warn_On_Index_Below_Lower_Bound;
+ -- Generate a warning on indexing the array with a literal value
+ -- below the lower bound of the index type.
+
+ procedure Warn_On_Literal_Index;
+ -- Generate a warning on indexing the array with a literal value
+
--
-- Length_Reference --
--
@@ -3903,21 +3911,31 @@
("?w?index for& may assume lower bound of^", X, Ent);
end Warn1;
- -- Start of processing for Test_Suspicious_Index
+ -
+ -- Warn_On_Index_Below_Lower_Bound --
+ -
- begin
- -- Nothing to do if subscript does not come from source (we don't
- -- want to give garbage warnings on compiler expanded code, e.g. the
- -- loops generated for slice assignments. Such junk warnings would
- -- be placed on source constructs with no subscript in sight).
+ procedure Warn_On_Index_Below_Lower_Bound is
+ begin
+if Is_Standard_String_Type (Typ) then
+ Discard_Node
+ (Compile_Time_Constraint_Error
+ (N => X,
+Msg => "?w?string index should be positive"));
+else
+ Discard_Node
+ (Compile_Time_Constraint_Error
+ (N => X,
+Msg => "?w?index out of the allowed range"));
+end if;
+ end Warn_On_Index_Below_Lower_Bound;
- if not Comes_From_Source (Original_Node (X)) then
-return;
- end if;
+ ---
+ -- Warn_On_Literal_Index --
+ ---
- -- Case where subscript is a constant integer
-
- if Nkind (X) = N_Integer_Literal then
+ procedure Warn_On_Literal_Index is
+ begin
Warn1;
-- Case where original form of subscript is an integer literal
@@ -4037,7 +4055,35 @@
Error_Msg_FE -- CODEFIX
("\?w?suggested replacement: `&~`", Original_Node (X), Ent);
end if;
+ end Warn_On_Literal_Index;
+ -- Start of processing for Test_Suspicious_Index
+
+ begin
+ -- Nothing to do if subscript does not come from source (we don't
+ -- want to give garbage warnings on compiler expanded code, e.g. the
+ -- loops generated for slice assignments. Such junk warnings would
+ -- be placed on source constructs with no subscript in sight).
+
+ if not Comes_From_Source (Original_Node (X)) then
+return;
+ end if;
+
+ -- Case where subscript is a constant integer
+
+ if Nkind (X) = N_Integer_Literal then
+
+-- Case where subscript is lower than the lowest possible bound.
+-- This might be the case for example when programmers try to
+-- access a string at index 0, as they are used to in other
+-- programming
[Ada] Missing finalization of cursor in "of" iterator loop
This patch modifies the finalization machinery to ensure that the cursor of an
"of" iterator loop is properly finalized at the end of the loop. Previously it
was incorrectly assumed that such a cursor will never need finalization
ctions.
-- Source --
-- leak.adb
pragma Warnings (Off);
with Ada.Unchecked_Deallocation;
with Ada.Finalization;
with Ada.Iterator_Interfaces;
with Ada.Text_IO; use Ada.Text_IO;
procedure Leak is
type El is tagged null record;
type Integer_Access is access all Integer;
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Integer, Integer_Access);
type Cursor is new Ada.Finalization.Controlled with record
Count : Integer_Access := new Integer'(1);
end record;
overriding procedure Adjust (C : in out Cursor);
overriding procedure Finalize (C : in out Cursor);
overriding procedure Adjust (C : in out Cursor) is
begin
C.Count.all := C.Count.all + 1;
Put_Line ("Adjust Cursor. Count = " & C.Count.all'Img);
end Adjust;
overriding procedure Finalize (C : in out Cursor) is
begin
C.Count.all := C.Count.all - 1;
Put_Line ("Finalize Cursor. Count = " & C.Count.all'Img);
if C.Count.all = 0 then
Unchecked_Free (C.Count);
end if;
end Finalize;
function Has_Element (C : Cursor) return Boolean is (False);
package Child is
package Iterators is new Ada.Iterator_Interfaces
(Cursor => Cursor,
Has_Element => Has_Element);
type Iterator is
new Ada.Finalization.Controlled
and Iterators.Forward_Iterator
with record
Count : Integer_Access := new Integer'(1);
end record;
overriding function First (I : Iterator) return Cursor
is (Ada.Finalization.Controlled with others => <>);
overriding function Next (I : Iterator; C : Cursor) return Cursor
is (Ada.Finalization.Controlled with others => <>);
overriding procedure Adjust (I : in out Iterator);
end Child;
package body Child is
overriding procedure Adjust (I : in out Iterator) is
begin
I.Count.all := I.Count.all + 1;
Put_Line ("Adjust Iterator. Count = " & I.Count.all'Img);
end Adjust;
overriding procedure Finalize (I : in out Iterator) is
begin
I.Count.all := I.Count.all - 1;
Put_Line ("Finalize Iterator. Count = " & I.Count.all'Img);
if I.Count.all = 0 then
Unchecked_Free (I.Count);
end if;
end Finalize;
end Child;
type Iterable is tagged null record
with Default_Iterator => Iterate,
Iterator_Element => El'Class,
Constant_Indexing => El_At;
function Iterate
(O : Iterable) return Child.Iterators.Forward_Iterator'Class
is (Child.Iterator'(Ada.Finalization.Controlled with others => <>));
function El_At (Self : Iterable; Pos : Cursor'Class) return El'Class
is (El'(others => <>));
Seq : Iterable;
begin
Put_Line ("START");
for V of Seq loop
null;
end loop;
Put_Line ("END");
end Leak;
-- Compilation and output --
$ gnatmake -q leak.adb -largs -lgmem
$ ./leak
$ gnatmem ./leak > leaks.txt
$ grep -c "Number of non freed allocations" leaks.txt
START
Adjust Iterator. Count = 2
Finalize Iterator. Count = 1
Adjust Cursor. Count = 2
Finalize Cursor. Count = 1
Adjust Cursor. Count = 2
Finalize Cursor. Count = 1
Finalize Cursor. Count = 0
Finalize Iterator. Count = 0
END
0
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Hristian Kirtchev
* einfo.adb (Status_Flag_Or_Transient_Decl): The attribute is now
allowed on loop parameters.
(Set_Status_Flag_Or_Transient_Decl): The attribute is now allowed
on loop parameters.
(Write_Field15_Name): Update the output for
Status_Flag_Or_Transient_Decl.
* einfo.ads: Attribute Status_Flag_Or_Transient_Decl now applies
to loop parameters. Update the documentation of the attribute
and the E_Loop_Parameter entity.
* exp_ch7.adb (Process_Declarations): Remove the bogus guard
which assumes that cursors can never be controlled.
* exp_util.adb (Requires_Cleanup_Actions): Remove the bogus
guard which assumes that cursors can never be controlled.
Index: exp_ch7.adb
===
--- exp_ch7.adb (revision 251753)
+++ exp_ch7.adb (working copy)
@@ -2100,15 +2100,6 @@
elsif Is_Ignored_Ghost_Entity (Obj_Id) then
null;
- -- The expansion of iterator loops generates an object
- -- declaration where the Ekind is explicitly set to loop
- -- parameter. This is to ensure that the loop parameter behaves
- -- as a constant from user code point of view. Such object are
[Ada] Derived iterable types with noniterable parent
This patch fixes a bug in which if a derived type has a Default_Iterator specified, and the parent type does not, then a "for ... of" loop causes the compiler to crash. No small test case available. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Bob Duff * exp_ch5.adb (Get_Default_Iterator): Replace "Assert(False)" with "return Iter", because if an iterable type is derived from a noniterable one, then we won't find an overriding or inherited default iterator. Index: exp_ch5.adb === --- exp_ch5.adb (revision 251767) +++ exp_ch5.adb (working copy) @@ -3934,9 +3934,9 @@ function Get_Default_Iterator (T : Entity_Id) return Entity_Id; --- If the container is a derived type, the aspect holds the parent --- operation. The required one is a primitive of the derived type --- and is either inherited or overridden. Also sets Container_Arg. +-- Return the default iterator for a specific type. If the type is +-- derived, we return the inherited or overridden one if +-- appropriate. -- -- Get_Default_Iterator -- @@ -3953,11 +3953,11 @@ begin Container_Arg := New_Copy_Tree (Container); - -- A previous version of GNAT allowed indexing aspects to - -- be redefined on derived container types, while the - -- default iterator was inherited from the parent type. - -- This non-standard extension is preserved temporarily for - -- use by the modelling project under debug flag d.X. + -- A previous version of GNAT allowed indexing aspects to be + -- redefined on derived container types, while the default + -- iterator was inherited from the parent type. This + -- nonstandard extension is preserved for use by the + -- modelling project under debug flag -gnatd.X. if Debug_Flag_Dot_XX then if Base_Type (Etype (Container)) /= @@ -3995,9 +3995,11 @@ Next_Elmt (Prim); end loop; - -- Default iterator must exist + -- If we didn't find it, then our parent type is not + -- iterable, so we return the Default_Iterator aspect of + -- this type. - pragma Assert (False); + return Iter; -- Otherwise not a derived type
[Ada] Extension of 'Image in Ada2020
Refactor of all 'Image attributes for better error diagnostics and clarity. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Justin Squirek * exp_imgv.adb (Expand_Image_Attribute), (Expand_Wide_Image_Attribute), (Expand_Wide_Wide_Image_Attribute): Added case to handle new-style 'Image expansion (Rewrite_Object_Image): Moved from exp_attr.adb * exp_attr.adb (Expand_N_Attribute_Reference): Modified Image attribute cases so that the relevant subprograms in exp_imgv.adb handle all expansion. (Rewrite_Object_Reference_Image): Moved to exp_imgv.adb * sem_attr.adb (Analyze_Attribute): Modified Image attribute cases to call common function Analyze_Image_Attribute. (Analyze_Image_Attribute): Created as a common path for all image attributes (Check_Object_Reference_Image): Removed * sem_util.ads, sem_util.adb (Is_Image_Applied_To_Object): Removed and refactored into Is_Object_Image (Is_Object_Image): Created as a replacement for Is_Image_Applied_To_Object Index: exp_imgv.adb === --- exp_imgv.adb(revision 251753) +++ exp_imgv.adb(working copy) @@ -36,6 +36,7 @@ with Rtsfind; use Rtsfind; with Sem_Aux; use Sem_Aux; with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; with Sinfo;use Sinfo; with Snames; use Snames; with Stand;use Stand; @@ -52,6 +53,17 @@ -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten. -- Shouldn't this be in einfo.adb or sem_aux.adb??? + procedure Rewrite_Object_Image + (N : Node_Id; + Pref : Entity_Id; + Attr_Name : Name_Id; + Str_Typ : Entity_Id); + -- AI12-00124: Rewrite attribute 'Image when it is applied to an object + -- reference as an attribute applied to a type. N denotes the node to be + -- rewritten, Pref denotes the prefix of the 'Image attribute, and Name + -- and Str_Typ specify which specific string type and 'Image attribute to + -- apply (e.g. Name_Wide_Image and Standard_Wide_String). + -- Build_Enumeration_Image_Tables -- @@ -254,10 +266,10 @@ Loc : constant Source_Ptr := Sloc (N); Exprs : constant List_Id:= Expressions (N); Pref : constant Node_Id:= Prefix (N); - Ptyp : constant Entity_Id := Entity (Pref); - Rtyp : constant Entity_Id := Root_Type (Ptyp); Expr : constant Node_Id:= Relocate_Node (First (Exprs)); Imid : RE_Id; + Ptyp : Entity_Id; + Rtyp : Entity_Id; Tent : Entity_Id; Ttyp : Entity_Id; Proc_Ent : Entity_Id; @@ -273,6 +285,14 @@ Pnn : constant Entity_Id := Make_Temporary (Loc, 'P'); begin + if Is_Object_Image (Pref) then + Rewrite_Object_Image (N, Pref, Name_Image, Standard_String); + return; + end if; + + Ptyp := Entity (Pref); + Rtyp := Root_Type (Ptyp); + -- Build declarations of Snn and Pnn to be inserted Ins_List := New_List ( @@ -791,11 +811,19 @@ procedure Expand_Wide_Image_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); - Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); - Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + Pref : constant Entity_Id := Prefix (N); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + Rtyp : Entity_Id; begin + if Is_Object_Image (Pref) then + Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String); + return; + end if; + + Rtyp := Root_Type (Entity (Pref)); + Insert_Actions (N, New_List ( -- Rnn : Wide_String (1 .. base_typ'Width); @@ -882,12 +910,20 @@ procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); + Pref : constant Entity_Id := Prefix (N); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + Rtyp : Entity_Id; - Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); - Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + begin + if Is_Object_Image (Pref) then + Rewrite_Object_Image + (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String); + return; + end if; - begin + Rtyp := Root_Type (Entity (Pref)); + Insert_Actions (N, New_List ( -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); @@ -1373,4 +1409,23 @@ and then Ur
[Ada] Crash when issuing warning on uninitialized value
When issuing a warning on a read of an uninitialized variable through reading an attribute such as Loop_Entry, GNAT could crash. Now fixed. GNAT issues a warning as expected on the following code: $ gcc -c s.adb 1. package S is 2. 3.type Array_Range is range 1 .. 10; 4. 5.type IntArray is array (Array_Range) of Integer; 6. 7.procedure Move (Dest, Src : aliased out IntArray); 8. 9. end S; 1. package body S is 2. 3.procedure Move (Dest, Src : aliased out IntArray) is 4.begin 5. for Index in Dest'Range loop 6. pragma Assert (for all J in Dest'First .. Index - 1 => 7. Dest (J) = Src'Loop_Entry (J)); 1 2 >>> warning: "Dest" may be referenced before it has a value >>> warning: "Src" may be referenced before it has a value 8. 9. Dest (Index) := Src (Index); 10. Src (Index) := 0; 11. end loop; 12.end Move; 13. 14. end S; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Yannick Moy * sem_warn.adb (Check_References): Take into account possibility of attribute reference as original node. Index: sem_warn.adb === --- sem_warn.adb(revision 251773) +++ sem_warn.adb(working copy) @@ -1382,16 +1382,22 @@ -- deal with case where original unset reference has been -- rewritten during expansion. - -- In some cases, the original node may be a type conversion - -- or qualification, and in this case we want the object - -- entity inside. + -- In some cases, the original node may be a type + -- conversion, a qualification or an attribute reference and + -- in this case we want the object entity inside. Same for + -- an expression with actions. UR := Original_Node (UR); while Nkind (UR) = N_Type_Conversion or else Nkind (UR) = N_Qualified_Expression or else Nkind (UR) = N_Expression_With_Actions +or else Nkind (UR) = N_Attribute_Reference loop - UR := Expression (UR); + if Nkind (UR) = N_Attribute_Reference then +UR := Prefix (UR); + else +UR := Expression (UR); + end if; end loop; -- Don't issue warning if appearing inside Initial_Condition
[Ada] Eliminate out-of-line body of local inlined subprograms
This improves a little the algorithm used to compute the set of externally visible entities in package bodies to make it less conservative in the presence of local inlined subprograms. The typical effect is to eliminate the out-of-line body if the subprogram is inlined at every call site: package Q3 is procedure Caller; end Q3; package body Q3 is I : Integer := 0; procedure Inner is begin I := 1; end; procedure Proc; pragma Inline (Proc); procedure Proc is begin Inner; end; procedure Caller is begin Proc; end; end Q3; The out-of-line body of Proc is now eliminated at -O1 and above. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Eric Botcazou * inline.adb (Split_Unconstrained_Function): Also set Is_Inlined on the procedure created to encapsulate the body. * sem_ch7.adb: Add with clause for GNAT.HTable. (Entity_Table_Size): New constant. (Entity_Hash): New function. (Subprogram_Table): New instantiation of GNAT.Htable.Simple_HTable. (Is_Subprogram_Ref): Rename into... (Scan_Subprogram_Ref): ...this. Record references to subprograms in the table instead of bailing out on them. Scan the value of constants if it is not known at compile time. (Contains_Subprograms_Refs): Rename into... (Scan_Subprogram_Refs): ...this. (Has_Referencer): Scan the body of all inlined subprograms. Reset the Is_Public flag on subprograms if they are not actually referenced. (Hide_Public_Entities): Beef up comment on the algorithm. Reset the table of subprograms on entry. Index: inline.adb === --- inline.adb (revision 251779) +++ inline.adb (working copy) @@ -1607,7 +1607,7 @@ -- N is an inlined function body that returns an unconstrained type and -- has a single extended return statement. Split N in two subprograms: -- a procedure P' and a function F'. The formals of P' duplicate the - -- formals of N plus an extra formal which is used return a value; + -- formals of N plus an extra formal which is used to return a value; -- its body is composed by the declarations and list of statements -- of the extended return statement of N. @@ -1915,6 +1915,7 @@ Pop_Scope; Build_Procedure (Proc_Id, Decl_List); Insert_Actions (N, Decl_List); +Set_Is_Inlined (Proc_Id); Push_Scope (Scope); end; Index: sem_ch7.adb === --- sem_ch7.adb (revision 251763) +++ sem_ch7.adb (working copy) @@ -70,6 +70,8 @@ with Style; with Uintp; use Uintp; +with GNAT.HTable; + package body Sem_Ch7 is --- @@ -187,6 +189,38 @@ end if; end Analyze_Package_Body; + -- + -- Analyze_Package_Body_Helper Data and Subprograms -- + -- + + Entity_Table_Size : constant := 4096; + -- Number of headers in hash table + + subtype Entity_Header_Num is Integer range 0 .. Entity_Table_Size - 1; + -- Range of headers in hash table + + function Entity_Hash (Id : Entity_Id) return Entity_Header_Num; + -- Simple hash function for Entity_Ids + + package Subprogram_Table is new GNAT.Htable.Simple_HTable + (Header_Num => Entity_Header_Num, + Element=> Boolean, + No_Element => False, + Key=> Entity_Id, + Hash => Entity_Hash, + Equal => "="); + -- Hash table to record which subprograms are referenced. It is declared + -- at library level to avoid elaborating it for every call to Analyze. + + - + -- Entity_Hash -- + - + + function Entity_Hash (Id : Entity_Id) return Entity_Header_Num is + begin + return Entity_Header_Num (Id mod Entity_Table_Size); + end Entity_Hash; + - -- Analyze_Package_Body_Helper -- - @@ -200,8 +234,8 @@ -- Attempt to hide all public entities found in declarative list Decls -- by resetting their Is_Public flag to False depending on whether the -- entities are not referenced by inlined or generic bodies. This kind - -- of processing is a conservative approximation and may still leave - -- certain entities externally visible. + -- of processing is a conservative approximation and will still leave + -- entities externally visible if the package is not simple enough. procedure Install_Composite_Operations (P : Entity_Id); -- Composite types declared in the current scope may depend on types @@ -214,11 +248,6 @@ -- procedure Hide_Public_Entities (Decls : List_Id) is -
[Ada] Time_IO.Value enhanced to parse ISO-8861 UTC date and time
The function Value of package GNAT.Calendar.Time_IO has been enhanced
to parse strings containing UTC date and time.
After this patch the following test works fine.
with Ada.Calendar; use Ada.Calendar;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Calendar.Time_IO; use GNAT.Calendar.Time_IO;
procedure Do_Test is
Picture : Picture_String := "%Y-%m-%dT%H:%M:%S,%i";
T1 : Time;
T2 : Time;
T3 : Time;
T4 : Time;
T5 : Time;
begin
T1 := Value ("2017-04-14T14:47:06");
pragma Assert (Image (T1, Picture) = "2017-04-14T14:47:06,000");
T2 := Value ("2017-04-14T14:47:06Z");
pragma Assert (Image (T2, Picture) = "2017-04-14T14:47:06,000");
T3 := Value ("2017-04-14T14:47:06,999");
pragma Assert (Image (T3, Picture) = "2017-04-14T14:47:06,999");
T4 := Value ("2017-04-14T19:47:06+05");
pragma Assert (Image (T4, Picture) = "2017-04-14T14:47:06,000");
T5 := Value ("2017-04-14T09:00:06-05:47");
pragma Assert (Image (T5, Picture) = "2017-04-14T14:47:06,000");
end;
Command: gnatmake -gnata do_test.adb; ./do_test
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Javier Miranda
* g-catiio.ads, g-catiio.adb (Value): Extended to parse an UTC time
following ISO-8861.
Index: g-catiio.adb
===
--- g-catiio.adb(revision 251753)
+++ g-catiio.adb(working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2016, AdaCore --
+-- Copyright (C) 1999-2017, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -93,6 +93,26 @@
Length : Natural := 0) return String;
-- As above with N provided in Integer format
+ procedure Parse_ISO_8861_UTC
+ (Date: String;
+ Time: out Ada.Calendar.Time;
+ Success : out Boolean);
+ -- Subsidiary of function Value. It parses the string Date, interpreted as
+ -- an ISO 8861 time representation, and returns corresponding Time value.
+ -- Success is set to False when the string is not a supported ISO 8861
+ -- date. The following regular expression defines the supported format:
+ --
+ --(mmdd | '-'mm'-'dd)'T'(hhmmss | hh':'mm':'ss)
+ -- [ ('Z' | ('.' | ',') s{s} | ('+'|'-')hh':'mm) ]
+ --
+ -- Trailing characters (in particular spaces) are not allowed.
+ --
+ -- Examples:
+ --
+ --2017-04-14T14:47:0620170414T14:47:0620170414T144706
+ --2017-04-14T14:47:06,12 20170414T14:47:06.12
+ --2017-04-14T19:47:06+05 20170414T09:00:06-05:47
+
---
-- Am_Pm --
---
@@ -531,7 +551,7 @@
"JUL", "AUG", "SEP", "OCT", "NOV", "DEC");
-- Short version of the month names, used when parsing date strings
- S : String := Str;
+ S : String := Str;
begin
GNAT.Case_Util.To_Upper (S);
@@ -545,6 +565,390 @@
return Abbrev_Upper_Month_Names'First;
end Month_Name_To_Number;
+
+ -- Parse_ISO_8861_UTC --
+
+
+ procedure Parse_ISO_8861_UTC
+ (Date: String;
+ Time: out Ada.Calendar.Time;
+ Success : out Boolean)
+ is
+ Index : Positive := Date'First;
+ -- The current character scan index. After a call to Advance, Index
+ -- points to the next character.
+
+ End_Of_Source_Reached : exception;
+ -- An exception used to signal that the scan pointer has reached the
+ -- end of the source string.
+
+ Wrong_Syntax : exception;
+ -- An exception used to signal that the scan pointer has reached an
+ -- unexpected character in the source string.
+
+ procedure Advance;
+ pragma Inline (Advance);
+ -- Past the current character of Date
+
+ procedure Advance_Digits (Num_Digits : Positive);
+ pragma Inline (Advance_Digits);
+ -- Past the given number of digit characters
+
+ function Scan_Day return Day_Number;
+ pragma Inline (Scan_Day);
+ -- Scan the two digits of a day number and return its value
+
+ function Scan_Hour return Hour_Number;
+ pragma Inline (Scan_Hour);
+ -- Scan the two digits of an hour number and return its value
+
+ function Scan_Minute return Minute_Number;
+ pragma Inline (Scan_Minute);
+ -- Scan the two digits of a minute number and return its value
+
+
[Ada] Dimensional checking and generic subprograms
This patch enahnces dimensionality checking to cover generic subprograms that are intended to apply to types of different dimensions, such as an integration function. Dimensionality checking is performed in each instance. and rely on a special handling of conversion operations to prevent spurious dimensional errors in the generic unit itself. The following must compile quietly: gcc -c -gnatws integrate.adb --- package Dims with SPARK_Mode is - -- Setup Dimension System - type Unit_Type is new Float with Dimension_System => ((Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Theta"), (Unit_Name => Radian, Unit_Symbol => "Rad", Dim_Symbol => "A")), Default_Value => 0.0; -- Base Dimensions subtype Length_Type is Unit_Type with Dimension => (Symbol => 'm', Meter => 1, others => 0); subtype Time_Type is Unit_Type with Dimension => (Symbol => 's', Second => 1, others => 0); subtype Linear_Velocity_Type is Unit_Type with Dimension => (Meter => 1, Second => -1, others => 0); -- Base Units Meter: constant Length_Type := Length_Type (1.0); Second : constant Time_Type := Time_Type (1.0); end dims; --- with Dims; use Dims; procedure Integrate is generic type Op1 is new Unit_Type; type Op2 is new Unit_Type; type Res is new Unit_Type; function I (X : op1; Y : Op2) return Res; function I (X : op1; Y : Op2) return Res is begin return Res (Unit_Type (X) * Unit_type (Y)); end I; function Distance is new I (Time_Type, Linear_Velocity_Type, Length_Type); Secs : Time_Type := 5.0; Speed : Linear_Velocity_Type := 10.0; Covered : Length_Type; begin Covered := Distance (Secs, Speed); declare subtype Area is Unit_Type with dimension => (Meter => 2, others => 0); My_Little_Acre : Area; function Acres is new I (Length_Type, Length_Type, Area); begin My_Little_Acre := Covered * Covered; My_Little_Acre := Acres (Covered, Covered); end; end Integrate; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * sem_dim.adb (Analyze_Dimension): In an instance, a type conversion takes its dimensions from the expression, not from the context type. (Dimensions_Of_Operand): Ditto. Index: sem_dim.adb === --- sem_dim.adb (revision 251753) +++ sem_dim.adb (working copy) @@ -1161,7 +1161,6 @@ | N_Qualified_Expression | N_Selected_Component | N_Slice -| N_Type_Conversion | N_Unchecked_Type_Conversion => Analyze_Dimension_Has_Etype (N); @@ -1191,7 +1190,17 @@ when N_Subtype_Declaration => Analyze_Dimension_Subtype_Declaration (N); + when N_Type_Conversion => +if In_Instance + and then Exists (Dimensions_Of (Expression (N))) +then + Set_Dimensions (N, Dimensions_Of (Expression (N))); +else + Analyze_Dimension_Has_Etype (N); +end if; + when N_Unary_Op => + Analyze_Dimension_Unary_Op (N); when others => @@ -1378,11 +1387,24 @@ -- A type conversion may have been inserted to rewrite other -- expressions, e.g. function returns. Dimensions are those of - -- the target type. + -- the target type, unless this is a conversion in an instance, + -- in which case the proper dimensions are those of the operand, elsif Nkind (N) = N_Type_Conversion then -return Dimensions_Of (Etype (N)); +if In_Instance + and then Is_Generic_Actual_Type (Etype (Expression (N))) +then + return Dimensions_Of (Etype (Expression (N))); +elsif In_Instance + and then Exists (Dimensions_Of (Expression (N))) +then + return Dimensions_Of (Expression (N)); + +else + return Dimensions_Of (Etype (N)); +end if; + -- Otherwise return the default dimensions else
[Ada] Handling of inherited and explicit postconditions
This patch fixes the handling of overriding operations that have both an explicit postcondition and an inherited classwide one. Executing: gnatmake -q -gnata post_class.adb post_class must yield: raised SYSTEM.ASSERTIONS.ASSERT_FAILURE : failed inherited postcondition from the_package.ads:4 --- with The_Package; use The_Package; procedure Post_Class is X : D; begin Proc (X); end Post_Class; --- package The_Package is type T is tagged null record; function F (X : T) return Boolean is (True); procedure Proc (X : in out T) with Post => True, post'class => F (X); type D is new T with null record; overriding function F (X : D) return Boolean is (False); end The_Package; --- package body The_Package is procedure Proc (X : in out T) is begin null; end Proc; end The_Package; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * einfo.ads, einfo.adb (Get_Classwwide_Pragma): New utility, to retrieve the inherited classwide precondition/postcondition of a subprogram. * freeze.adb (Freeze_Entity): Use Get_Classwide_Pragma when freezing a subprogram, to complete the generation of the corresponding checking code. Index: einfo.adb === --- einfo.adb (revision 251783) +++ einfo.adb (working copy) @@ -7481,6 +7481,39 @@ return Empty; end Get_Pragma; + -- + -- Get_Classwide_Pragma -- + -- + + function Get_Classwide_Pragma + (E : Entity_Id; + Id : Pragma_Id) return Node_Id +is + Item : Node_Id; + Items : Node_Id; + + begin + Items := Contract (E); + if No (Items) then + return Empty; + end if; + + Item := Pre_Post_Conditions (Items); + + while Present (Item) loop + if Nkind (Item) = N_Pragma + and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id + and then Class_Present (Item) + then +return Item; + else +Item := Next_Pragma (Item); + end if; + end loop; + + return Empty; + end Get_Classwide_Pragma; + -- -- Get_Record_Representation_Clause -- -- Index: einfo.ads === --- einfo.ads (revision 251783) +++ einfo.ads (working copy) @@ -8295,6 +8295,12 @@ --Test_Case --Volatile_Function + function Get_Classwide_Pragma + (E : Entity_Id; + Id : Pragma_Id) return Node_Id; + -- Examine Rep_Item chain to locate a classwide pre- or postcondition + -- of a primitive operation. Returns Empty if not present. + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id; -- Searches the Rep_Item chain for a given entity E, for a record -- representation clause, and if found, returns it. Returns Empty Index: freeze.adb === --- freeze.adb (revision 251781) +++ freeze.adb (working copy) @@ -1418,8 +1418,8 @@ New_Prag : Node_Id; begin - A_Pre := Get_Pragma (Par_Prim, Pragma_Precondition); - if Present (A_Pre) and then Class_Present (A_Pre) then + A_Pre := Get_Classwide_Pragma (Par_Prim, Pragma_Precondition); + if Present (A_Pre) then New_Prag := New_Copy_Tree (A_Pre); Build_Class_Wide_Expression (Prag => New_Prag, @@ -1436,9 +1436,9 @@ end if; end if; - A_Post := Get_Pragma (Par_Prim, Pragma_Postcondition); + A_Post := Get_Classwide_Pragma (Par_Prim, Pragma_Postcondition); - if Present (A_Post) and then Class_Present (A_Post) then + if Present (A_Post) then New_Prag := New_Copy_Tree (A_Post); Build_Class_Wide_Expression (Prag => New_Prag,
[Ada] Missing finalization of generalized indexed element
This patch modifies the finalization mechanism to recognize a heavily expanded
generalized indexing where the element type requires finalization actions.
-- Source --
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Element is new Controlled with record
Id : Natural := 0;
end record;
procedure Adjust (Obj : in out Element);
procedure Finalize (Obj : in out Element);
procedure Initialize (Obj : In out Element);
subtype Index is Integer range 1 .. 3;
type Collection is array (Index) of Element;
type Vector is new Controlled with record
Id : Natural := 0;
Elements : Collection;
end record
with Constant_Indexing => Element_At;
procedure Adjust (Obj : in out Vector);
procedure Finalize (Obj : in out Vector);
procedure Initialize (Obj : In out Vector);
function Element_At
(Obj : Vector;
Pos : Index) return Element'Class;
function Make_Vector return Vector'Class;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Id_Gen : Natural := 10;
procedure Adjust (Obj : in out Element) is
Old_Id : constant Natural := Obj.Id;
New_Id : constant Natural := Old_Id + 1;
begin
if Old_Id = 0 then
Put_Line (" Element adj ERROR");
else
Put_Line (" Element adj" & Old_Id'Img & " ->" & New_Id'Img);
Obj.Id := New_Id;
end if;
end Adjust;
procedure Adjust (Obj : in out Vector) is
Old_Id : constant Natural := Obj.Id;
New_Id : constant Natural := Old_Id + 1;
begin
if Old_Id = 0 then
Put_Line (" Vector adj ERROR");
else
Put_Line (" Vector adj" & Old_Id'Img & " ->" & New_Id'Img);
Obj.Id := New_Id;
end if;
end Adjust;
function Element_At
(Obj : Vector;
Pos : Index) return Element'Class
is
begin
return Obj.Elements (Pos);
end Element_At;
procedure Finalize (Obj : in out Element) is
begin
if Obj.Id = 0 then
Put_Line (" Element fin ERROR");
else
Put_Line (" Element fin" & Obj.Id'Img);
Obj.Id := 0;
end if;
end Finalize;
procedure Finalize (Obj : in out Vector) is
begin
if Obj.Id = 0 then
Put_Line (" Vector fin ERROR");
else
Put_Line (" Vector fin" & Obj.Id'Img);
Obj.Id := 0;
end if;
end Finalize;
procedure Initialize (Obj : In out Element) is
begin
Obj.Id := Id_Gen;
Id_Gen := Id_Gen + 10;
Put_Line (" Element ini" & Obj.Id'Img);
end Initialize;
procedure Initialize (Obj : In out Vector) is
begin
Obj.Id := Id_Gen;
Id_Gen := Id_Gen + 10;
Put_Line (" Vector ini" & Obj.Id'Img);
end Initialize;
function Make_Vector return Vector'Class is
Result : Vector;
begin
return Result;
end Make_Vector;
end Types;
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Types; use Types;
procedure Main is
begin
Put_Line ("Main");
declare
Vec : Vector'Class := Make_Vector;
Elem : Element'Class := Vec (1);
begin
Put_Line ("Main middle");
end;
Put_Line ("Main end");
end Main;
-- Compilation and output --
$ gnatmake -q main.adb
$ ./main.adb
Main
Element ini 10
Element ini 20
Element ini 30
Vector ini 40
Element adj 10 -> 11
Element adj 20 -> 21
Element adj 30 -> 31
Vector adj 40 -> 41
Vector fin 40
Element fin 30
Element fin 20
Element fin 10
Element adj 11 -> 12
Element adj 21 -> 22
Element adj 31 -> 32
Vector adj 41 -> 42
Vector fin 41
Element fin 31
Element fin 21
Element fin 11
Element adj 12 -> 13
Element adj 13 -> 14
Element fin 13
Main middle
Element fin 14
Vector fin 42
Element fin 32
Element fin 22
Element fin 12
Main end
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Hristian Kirtchev
* exp_util.adb (Is_Controlled_Indexing): New routine.
(Is_Displace_Call): Use routine Strip to remove indirections.
(Is_Displacement_Of_Object_Or_Function_Result): Code clean up. Add a
missing case of controlled generalized indexing.
(Is_Source_Object): Use routine Strip to remove indirections.
(Strip): New routine.
Index: exp_util.adb
===
--- exp_util.adb(revision 251784)
+++ exp_util.adb(working copy)
@@ -7590,22 +7590,28 @@
(Obj_Id : Entity_Id) return Boolean
is
function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
- -- Determine if particular node denotes a controlled function call. The
- -- call may have been heavily expanded.
+ -- Determine whether node N denotes a controlled function call
+ function Is_Controlled_Indexing (N : Node_Id) return Boolean;
+ -- Det
[Ada] Reject invalid use of Global/Depends on object declaration
GNAT failed to issue an error on a Global/Depends aspect put on an object declaration, which is only allowed for a task object. Instead it crashed. Now fixed. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Yannick Moy * sem_prag.adb (Analyze_Depends_Global): Reinforce test on object declarations to only consider valid uses of Global/Depends those on single concurrent objects. Index: sem_prag.adb === --- sem_prag.adb(revision 251778) +++ sem_prag.adb(working copy) @@ -4080,7 +4080,10 @@ -- Object declaration of a single concurrent type - elsif Nkind (Subp_Decl) = N_Object_Declaration then + elsif Nkind (Subp_Decl) = N_Object_Declaration + and then Is_Single_Concurrent_Object + (Unique_Defining_Entity (Subp_Decl)) + then null; -- Single task type
[Ada] Issue error message on invalid representation clause for extension
This makes the compiler generate an error message also in the case where one
of the specified components overlaps the parent field because its size has
been explicitly set by a size clause.
The compiler must issue an error on 32-bit platforms for the package:
1. package P is
2.
3. type Byte is mod 2**8;
4. for Byte'Size use 8;
5.
6. type Root is tagged record
7. Status : Byte;
8. end record;
9. for Root use record
10. Status at 4 range 0 .. 7;
11. end record;
12. for Root'Size use 64;
13.
14. type Ext is new Root with record
15. Thread_Status : Byte;
16. end record;
17. for Ext use record
18. Thread_Status at 5 range 0 .. 7;
|
>>> component overlaps parent field of "Ext"
19. end record;
20.
21. end P;
21 lines: 1 error
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Eric Botcazou
* sem_ch13.adb (Check_Record_Representation_Clause): Give an
error as soon as one of the specified components overlaps the
parent field.
Index: sem_ch13.adb
===
--- sem_ch13.adb(revision 251784)
+++ sem_ch13.adb(working copy)
@@ -9806,12 +9806,12 @@
-- checking for overlap, since no overlap is possible.
Tagged_Parent : Entity_Id := Empty;
- -- This is set in the case of a derived tagged type for which we have
- -- Is_Fully_Repped_Tagged_Type True (indicating that all components are
- -- positioned by record representation clauses). In this case we must
- -- check for overlap between components of this tagged type, and the
- -- components of its parent. Tagged_Parent will point to this parent
- -- type. For all other cases Tagged_Parent is left set to Empty.
+ -- This is set in the case of an extension for which we have either a
+ -- size clause or Is_Fully_Repped_Tagged_Type True (indicating that all
+ -- components are positioned by record representation clauses) on the
+ -- parent type. In this case we check for overlap between components of
+ -- this tagged type and the parent component. Tagged_Parent will point
+ -- to this parent type. For all other cases, Tagged_Parent is Empty.
Parent_Last_Bit : Uint;
-- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
@@ -9959,19 +9959,23 @@
if Rectype = Any_Type then
return;
- else
- Rectype := Underlying_Type (Rectype);
end if;
+ Rectype := Underlying_Type (Rectype);
+
-- See if we have a fully repped derived tagged type
declare
PS : constant Entity_Id := Parent_Subtype (Rectype);
begin
- if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
+ if Present (PS) and then Known_Static_RM_Size (PS) then
Tagged_Parent := PS;
+Parent_Last_Bit := RM_Size (PS) - 1;
+ elsif Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
+Tagged_Parent := PS;
+
-- Find maximum bit of any component of the parent type
Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
@@ -10063,7 +10067,7 @@
("bit number out of range of specified size",
Last_Bit (CC));
- -- Check for overlap with tag component
+ -- Check for overlap with tag or parent component
else
if Is_Tagged_Type (Rectype)
@@ -10073,27 +10077,20 @@
("component overlaps tag field of&",
Component_Name (CC), Rectype);
Overlap_Detected := True;
+
+ elsif Present (Tagged_Parent)
+ and then Fbit <= Parent_Last_Bit
+ then
+ Error_Msg_NE
+("component overlaps parent field of&",
+ Component_Name (CC), Rectype);
+ Overlap_Detected := True;
end if;
if Hbit < Lbit then
Hbit := Lbit;
end if;
end if;
-
--- Check parent overlap if component might overlap parent field
-
-if Present (Tagged_Parent) and then Fbit <= Parent_Last_Bit then
- Pcomp := First_Component_Or_Discriminant (Tagged_Parent);
- while Present (Pcomp) loop
- if not Is_Tag (Pcomp)
-and then Chars (Pcomp) /= Name_uParent
- then
- Check_Component_Overlap (Comp, Pcomp);
- end if;
-
- Next_Component_Or_Discriminant (Pcomp);
- end loop;
-end if;
end if;
Next (CC);
[Ada] Volatile component not treated as such
This patch corrects an issue where attributes applied to records were not propagated to components within the records - causing incorrect code to be generated by the backend. Additionally, this ticket fixes another issue with pragma Volatile_Full_Access that allowed the attribute to be applied to a type with aliased components. -- Source -- -- p.ads with System; use System; package P is type Int8_t is mod 2**8; type Rec is record A,B,C,D : aliased Int8_t; end record; type VFA_Rec is new Rec with Volatile_Full_Access; -- ERROR R : Rec with Volatile_Full_Access; -- ERROR type Arr is array (1 .. 4) of aliased Int8_t; type VFA_Arr is new Arr with Volatile_Full_Access; -- ERROR A : Arr with Volatile_Full_Access; -- ERROR type Priv_VFA_Rec is private with Volatile_Full_Access; -- ERROR type Priv_Ind_Rec is private with Independent; -- ERROR type Priv_Vol_Rec is private with Volatile; -- ERROR type Priv_Atomic_Rec is private with Atomic; -- ERROR type Aliased_Rec is tagged record X : aliased Integer; end record with Volatile_Full_Access; -- OK type Atomic_And_VFA_Int is new Integer with Atomic, Volatile_Full_Access; -- ERROR type Atomic_And_VFA_Rec is record X : Integer with Atomic; end record with Volatile_Full_Access; -- ERROR type Atomic_T is tagged record X : Integer with Atomic; -- OK end record; type Atomic_And_VFA_T is new Atomic_T with record Y : Integer; end record with Volatile_Full_Access; -- ERROR type Aliased_And_VFA_T is new Aliased_Rec with record Y : Integer; end record with Volatile_Full_Access; -- ERROR Aliased_And_VFA_Obj : aliased Integer with Volatile_Full_Access; -- ERROR Atomic_And_VFA_Obj: Integer with Atomic, Volatile_Full_Access; -- ERROR Aliased_And_VFA_Obj_B : Aliased_Rec with Volatile_Full_Access; -- ERROR Atomic_And_VFA_Obj_B : Atomic_T with Volatile_Full_Access;-- ERROR private type Priv_VFA_Rec is record X : Integer; end record; type Priv_Ind_Rec is record X : Integer; end record; type Priv_Vol_Rec is record X : Integer; end record; type Priv_Atomic_Rec is record X : Integer; end record; end; -- p2.adb with System; procedure P2 is type Type1_T is record Field_1 : Integer; Field_2 : Integer; Field_3 : Integer; Field_4 : Short_Integer; end record; for Type1_T use record Field_1 at 0 range 0 .. 31; Field_2 at 4 range 0 .. 31; Field_3 at 8 range 0 .. 31; Field_4 at 12 range 0 .. 15; end record; for Type1_T'Size use (14) * System.Storage_Unit; pragma Volatile(Type1_T); type Type2_T is record Type1 : Type1_T; Field_1 : Integer; Field_2 : Integer; Field_3 : Integer; Field_4 : Short_Integer; end record; for Type2_T use record Type1 at 0 range 0 .. 111; Field_1 at 14 range 0 .. 31; Field_2 at 18 range 0 .. 31; Field_3 at 22 range 0 .. 31; Field_4 at 26 range 0 .. 15; end record; for Type2_T'Size use (28) * System.Storage_Unit; pragma Volatile(Type2_T); -- ERROR Type1 : Type1_T := (0,0,0,0); Type2 : Type2_T:= ((0,0,0,0),0,0,0,0); begin Type1.Field_1 := Type1.Field_1 +1; Type2.Field_1 := Type2.Field_1 +1; end; -- Compilation and output -- & gcc -c p.ads & gnatmake -q p2.adb p.ads:8:33: cannot apply Volatile_Full_Access (aliased component present) p.ads:10:17: cannot apply Volatile_Full_Access (aliased component present) p.ads:13:33: cannot apply Volatile_Full_Access (aliased component present) p.ads:15:17: cannot apply Volatile_Full_Access (aliased component present) p.ads:18:11: representation item must be after full type declaration p.ads:21:11: representation item must be after full type declaration p.ads:24:11: representation item must be after full type declaration p.ads:27:11: representation item must be after full type declaration p.ads:31:20: cannot apply Volatile_Full_Access (aliased component present) p.ads:34:19: cannot have Volatile_Full_Access and Atomic for same entity p.ads:38:20: cannot have Volatile_Full_Access and Atomic for same entity p.ads:46:20: cannot have Volatile_Full_Access and Atomic for same entity p.ads:50:20: cannot apply Volatile_Full_Access (aliased component present) p.ads:53:49: cannot have Volatile_Full_Access and Atomic for same entity p.ads:54:45: cannot apply Volatile_Full_Access (aliased component present) p.ads:55:42: cannot have Volatile_Full_Access and Atomic for same entity p2.adb:30:31: size of volatile field "Type1" must be at least 128 bits p2.adb:31:27: position of volatile field "Field_1" must be multiple of 32 bits p2.adb:32:27: position of volatile field "Field_2" must be multiple of 32 bits p2.adb:33:27: position of volatile field "Field_3" mu
[Ada] Spurious warning in formal package when use clause is present.
This patch removes a spurious style warning on an operator declared in a generic package when the package is used as a formal of a generic subprogram, and the subprogream body includes a use clause on that package. The following must compile quietly: gcc -c -gnatyO generic_test.adb --- with Generic_2; procedure Generic_Test is generic with package P_1 is new Generic_2 (<>); procedure S_1_G; procedure S_1_G is use P_1; begin null; end S_1_G; pragma Unreferenced (S_1_G); begin null; end Generic_Test; --- with Dummy; pragma Unreferenced (Dummy); with Generic_1; generic package Generic_2 is package P_1 is new Generic_1 (T_1 => Natural); end Generic_2; --- generic type T_1 is limited private; package Generic_1 is private type T_2 is record X : T_1; end record; function "=" (Left, Right : T_2) return Boolean is (True); end Generic_1; -- package Dummy is generic type T is range <>; package Dummy is function Foo (Of_Image : String) return T renames T'Value; end Dummy; end Dummy; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * sem_aux.adb (Is_Geeric_Formal): Handle properly formal packages. * sem_ch3.adb (Analyze_Declarations): In a generic subprogram body. do not freeze the formals of the generic unit. Index: sem_ch3.adb === --- sem_ch3.adb (revision 251789) +++ sem_ch3.adb (working copy) @@ -2649,9 +2649,27 @@ -- in order to perform visibility checks on delayed aspects. Adjust_Decl; - Freeze_All (First_Entity (Current_Scope), Decl); - Freeze_From := Last_Entity (Current_Scope); + -- If the current scope is a generic subprogram body. skip + -- the generic formal parameters that are not frozen here. + + if Is_Subprogram (Current_Scope) + and then Nkind (Unit_Declaration_Node (Current_Scope)) + = N_Generic_Subprogram_Declaration + and then Present (First_Entity (Current_Scope)) + then + while Is_Generic_Formal (Freeze_From) loop + Freeze_From := Next_Entity (Freeze_From); + end loop; + + Freeze_All (Freeze_From, Decl); + Freeze_From := Last_Entity (Current_Scope); + + else + Freeze_All (First_Entity (Current_Scope), Decl); + Freeze_From := Last_Entity (Current_Scope); + end if; + -- Current scope is a package specification elsif Scope (Current_Scope) /= Standard_Standard Index: sem_aux.adb === --- sem_aux.adb (revision 251753) +++ sem_aux.adb (working copy) @@ -1053,9 +1053,13 @@ return Nkind_In (Kind, N_Formal_Object_Declaration, - N_Formal_Package_Declaration, N_Formal_Type_Declaration) - or else Is_Formal_Subprogram (E); + or else Is_Formal_Subprogram (E) + + or else + (Ekind (E) = E_Package + and then Nkind (Original_Node (Unit_Declaration_Node (E))) = +N_Formal_Package_Declaration); end if; end Is_Generic_Formal;
[Ada] Wrong code on assignment of conditional expression to a mutable obkect
This patch fixes an error in an assignmen statement to an entity of a mutable
type (variable or in-out parameter) when the righ-hand side of the assignment
is a conditioal expression, some of whose alternatives are aggregates. Prior
to this patch, not all components of the mutable object were properly
assigned the corresponding values of the aggregate.
Executing:
gnatmake -q bug
./bug
must yield:
local var 72
local var 42
in_out parameter 72
in_out parameter 42
---
with Ada.Text_IO;
procedure Bug is
type Yoyo (Exists : Boolean := False) is record
case Exists is
when False =>
null;
when True =>
Value : Integer := 5;
end case;
end record;
Var1 : Yoyo;
Var2 : Yoyo;
procedure Test (Condition : in Boolean;
Value : in Integer;
Yo: in out Yoyo) is
Var3 : Yoyo;
begin
Yo := (if Condition then
(Exists => True,
Value => Value)
else
(Exists => False));
Var3 := (case condition is
when True => (Exists => True, Value => Value),
when False => (Exists => False));
if Condition and then
Yo.Value /= Value then
Ada.Text_IO.Put_Line ("Compiler bug exposed");
end if;
if Condition then
Ada.Text_IO.Put_Line ("local var " & Integer'Image (Var3.Value));
end if;
end;
begin
Test (True, 72, Var1);
Test (True, 42, Var2);
Ada.Text_IO.Put_Line ("in_out parameter " & Var1.Value'Img);
Ada.Text_IO.Put_Line ("in_out parameter " & Var2.Value'Img);
Test (False, 1000, Var1);
end Bug;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Ed Schonberg
* sem_ch5.adb (Analyze_Assigment): If the left-hand side is an
entity of a mutable type and the right-hand side is a conditional
expression, resolve the alternatives of the conditional using
the base type of the target entity, because the alternatives
may have distinct subtypes. This is particularly relevant if
the alternatives are aggregates.
Index: sem_ch5.adb
===
--- sem_ch5.adb (revision 251789)
+++ sem_ch5.adb (working copy)
@@ -580,8 +580,27 @@
Set_Assignment_Type (Lhs, T1);
- Resolve (Rhs, T1);
+ -- If the target of the assignment is an entity of a mutable type
+ -- and the expression is a conditional expression, its alternatives
+ -- can be of different subtypes of the nominal type of the LHS, so
+ -- they must be resolved with the base type, given that their subtype
+ -- may differ frok that of the target mutable object.
+ if Is_Entity_Name (Lhs)
+and then Ekind_In (Entity (Lhs),
+ E_Variable,
+ E_Out_Parameter,
+ E_In_Out_Parameter)
+and then Is_Composite_Type (T1)
+and then not Is_Constrained (Etype (Entity (Lhs)))
+and then Nkind_In (Rhs, N_If_Expression, N_Case_Expression)
+ then
+ Resolve (Rhs, Base_Type (T1));
+
+ else
+ Resolve (Rhs, T1);
+ end if;
+
-- This is the point at which we check for an unset reference
Check_Unset_Reference (Rhs);
[Ada] Improved error message on malformed null procedure with aspect
This patch improve the error reporting on a null procedure with misplaced
aspect specification, which the parser first attempts to interpret as a
malformed expression function, in spite of the initial keyword in the
declaration.
Compiling
---
package Null_Proc_With_Contract is
procedure Proc with Global => null is null;
end;
---
must yield:
null_proc_with_contract.ads:2:28:
aspect specifications must come after subprogram specification
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-07 Ed Schonberg
* par-ch6.adb (P_Subprogram): Improve error message on null
procedure with misplaced aspect specification, which the parser
first attempts to interpret as a malformed expression function.
Index: par-ch6.adb
===
--- par-ch6.adb (revision 251753)
+++ par-ch6.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -810,10 +810,15 @@
end if;
end if;
- -- Fall through if we have a likely expression function
+ -- Fall through if we have a likely expression function.
+ -- If the starting keyword is not "function" the error
+ -- will be reported elsewhere.
- Error_Msg_SC
-("expression function must be enclosed in parentheses");
+ if Func then
+ Error_Msg_SC
+ ("expression function must be enclosed in parentheses");
+ end if;
+
return True;
end Likely_Expression_Function;
@@ -844,12 +849,20 @@
-- This case is correctly processed by the parser because
-- the expression function first appears as a subprogram
- -- declaration to the parser.
+ -- declaration to the parser. The starting keyword may
+ -- not have been "function" in which case the error is
+ -- on a malformed procedure.
if Is_Non_Empty_List (Aspects) then
- Error_Msg
- ("aspect specifications must come after parenthesized "
-& "expression", Sloc (First (Aspects)));
+ if Func then
+Error_Msg ("aspect specifications must come after "
+ & "parenthesized expression",
+Sloc (First (Aspects)));
+ else
+Error_Msg ("aspect specifications must come after "
+ & "subprogram specification",
+Sloc (First (Aspects)));
+ end if;
end if;
-- Parse out expression and build expression function
[Ada] Finalization for b-i-p that raises exception
This patch fixes a bug where if a limited object is initialized with a build-in-place function call, and the call does not return on the secondary stack, and the function raises an exception, so that the object is not (successfully) created, the uninitialized object is incorrectly finalized. The following test should compile and run quietly: with Ada.Finalization; use Ada.Finalization; package BIP_Fin_Uninit is type Inner is new Limited_Controlled with null record; type Outer is limited record Inn: Inner; end record; Heck: exception; function Make_Outer return Outer; procedure Finalize(X: in out Inner); end BIP_Fin_Uninit; package body BIP_Fin_Uninit is function Make_Outer return Outer is begin raise Heck; return Make_Outer; -- Bogus recursive call never happens. end Make_Outer; procedure Finalize(X: in out Inner) is begin -- This should never be called. raise Program_Error with "Finalize called"; end Finalize; end BIP_Fin_Uninit; procedure BIP_Fin_Uninit.Main is begin declare X: Outer := Make_Outer; -- Propagates an exception. begin raise Program_Error; -- Can't get here. end; exception when Heck => null; -- OK end BIP_Fin_Uninit.Main; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Bob Duff * exp_ch7.adb (Find_Last_Init): Check for the case where a build-in-place function call has been replaced by a 'Reference attribute reference. Index: exp_ch7.adb === --- exp_ch7.adb (revision 251773) +++ exp_ch7.adb (working copy) @@ -2763,9 +2763,30 @@ Stmt := Next_Suitable_Statement (Decl); --- Nothing to do for an object with suppressed initialization +-- For an object with suppressed initialization, we check whether +-- there is in fact no initialization expression. If there is not, +-- then this is an object declaration that has been turned into a +-- different object declaration that calls the build-in-place +-- function in a 'Reference attribute, as in "F(...)'Reference". +-- We search for that later object declaration, so that the +-- Inc_Decl will be inserted after the call. Otherwise, if the +-- call raises an exception, we will finalize the (uninitialized) +-- object, which is wrong. if No_Initialization (Decl) then + if No (Expression (Last_Init)) then + loop + Last_Init := Next (Last_Init); + exit when No (Last_Init); + exit when Nkind (Last_Init) = N_Object_Declaration + and then Nkind (Expression (Last_Init)) = N_Reference + and then Nkind (Prefix (Expression (Last_Init))) = + N_Function_Call + and then Is_Expanded_Build_In_Place_Call + (Prefix (Expression (Last_Init))); + end loop; + end if; + return; -- In all other cases the initialization calls follow the related @@ -2955,7 +2976,7 @@ if No (Finalizer_Insert_Nod) then --- Insertion after an abort deffered block +-- Insertion after an abort deferred block if Present (Body_Ins) then Finalizer_Insert_Nod := Body_Ins;
[Ada] Fix internal error on task allocation and inlining
This fixes a small regression introduced by the recent improvement to the algorithm used by Hide_Public_Entities to compute the final set of external visible entities of a package. It now needs to recurse on the Actions list of freeze nodes to find references to subprograms. The following procedure must compile quietly with -O -gnatn: with T; procedure P is begin T.S; end; package T is procedure S with Inline; end; package body T is task type TT; task body TT is begin null; end; type TTA is access TT; X : TTA; procedure S is begin X := new TT; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Eric Botcazou * sem_ch7.adb (Has_Referencer): Recurse on Actions of freeze nodes. Index: sem_ch7.adb === --- sem_ch7.adb (revision 251785) +++ sem_ch7.adb (working copy) @@ -402,6 +402,18 @@ end if; end if; + -- Freeze node + + elsif Nkind (Decl) = N_Freeze_Entity then + declare + Discard : Boolean; + pragma Unreferenced (Discard); + begin + -- Inspect the actions to find references to subprograms + + Discard := Has_Referencer (Actions (Decl)); + end; + -- Exceptions, objects and renamings do not need to be public -- if they are not followed by a construct which can reference -- and export them. The Is_Public flag is reset on top level @@ -484,7 +496,7 @@ -- Local variables - Discard : Boolean := True; + Discard : Boolean; pragma Unreferenced (Discard); -- Start of processing for Hide_Public_Entities
[Ada] Avoid secondary stack for nondispatching build-in-place calls
This patch fixes a performance regression. The compiler was using the secondary stack for a nondispatching build-in-place call, which is unnecessary, and indeed older compilers did not do so. The compiler no longer uses the secondary stack for such calls. Note that the secondary stack is necessary for dispatching calls, because the caller doesn't know the size of the result. The older compilers mentioned above did not do that, which was a bug. Fixing that bug caused the performance regression. No change in behavior; no test available. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Bob Duff * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration, Make_Build_In_Place_Call_In_Anonymous_Context): Do not use the secondary stack for all functions that return limited tagged types -- just do it for dispatching calls. Misc cleanup. * sem_util.ads, sem_util.adb (Unqual_Conv): New function to remove qualifications and type conversions. Fix various bugs where only a single level of qualification or conversion was removed, so e.g. "T1'(T2'(X))" would incorrectly return "T2'(X)" instead of "X". * checks.adb, exp_util.ads, exp_util.adb, sem_res.adb: Misc related cleanup. Index: exp_util.adb === --- exp_util.adb(revision 251786) +++ exp_util.adb(working copy) @@ -8274,79 +8274,6 @@ and then not Is_Build_In_Place_Function_Call (Prefix (Expr)); end Is_Non_BIP_Func_Call; - - -- Is_Object_Access_BIP_Func_Call -- - - - function Is_Object_Access_BIP_Func_Call - (Expr : Node_Id; - Obj_Id : Entity_Id) return Boolean - is - Access_Nam : Name_Id := No_Name; - Actual : Node_Id; - Call : Node_Id; - Formal : Node_Id; - Param : Node_Id; - - begin - -- Build-in-place calls usually appear in 'reference format. Note that - -- the accessibility check machinery may add an extra 'reference due to - -- side effect removal. - - Call := Expr; - while Nkind (Call) = N_Reference loop - Call := Prefix (Call); - end loop; - - if Nkind_In (Call, N_Qualified_Expression, - N_Unchecked_Type_Conversion) - then - Call := Expression (Call); - end if; - - if Is_Build_In_Place_Function_Call (Call) then - - -- Examine all parameter associations of the function call - - Param := First (Parameter_Associations (Call)); - while Present (Param) loop -if Nkind (Param) = N_Parameter_Association - and then Nkind (Selector_Name (Param)) = N_Identifier -then - Formal := Selector_Name (Param); - Actual := Explicit_Actual_Parameter (Param); - - -- Construct the name of formal BIPaccess. It is much easier to - -- extract the name of the function using an arbitrary formal's - -- scope rather than the Name field of Call. - - if Access_Nam = No_Name and then Present (Entity (Formal)) then - Access_Nam := -New_External_Name - (Chars (Scope (Entity (Formal))), - BIP_Formal_Suffix (BIP_Object_Access)); - end if; - - -- A match for BIPaccess => Obj_Id'Unrestricted_Access has been - -- found. - - if Chars (Formal) = Access_Nam - and then Nkind (Actual) = N_Attribute_Reference - and then Attribute_Name (Actual) = Name_Unrestricted_Access - and then Nkind (Prefix (Actual)) = N_Identifier - and then Entity (Prefix (Actual)) = Obj_Id - then - return True; - end if; -end if; - -Next (Param); - end loop; - end if; - - return False; - end Is_Object_Access_BIP_Func_Call; - -- -- Is_Possibly_Unaligned_Object -- -- @@ -8739,11 +8666,7 @@ Call := Prefix (Call); end loop; - if Nkind_In (Call, N_Qualified_Expression, - N_Unchecked_Type_Conversion) - then - Call := Expression (Call); - end if; + Call := Unqual_Conv (Call); if Is_Build_In_Place_Function_Call (Call) then Index: exp_util.ads === --- exp_util.ads(revision 251753) +++ exp_util.ads(working copy) @@ -774,12 +774,6 @@ function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean; -- Determine whether node Expr denotes a non build-in-place function call - function Is_Object_Access_BIP_Func_Call - (Expr : Node_
[Ada] Spurious errors on dynamic predicates and private declarations.
This patch fixes spurious visibility errors on the expression for a dynamic predicate in a subtype declaration, when the enclosing package includes private declarations. The following packages much compile quietly: --- package foo is type Kind_Type is (None, Known); type Auction_State_Type (Kind : Kind_Type) is record case Kind is when None => null; when Known => Bar : Integer; end case; end record; Null_Auction_State : constant Auction_State_Type; subtype Not_Null_Auction_State_Type is Auction_State_Type with Dynamic_Predicate => Not_Null_Auction_State_Type /= Auction_State_Type'(Kind => None); private Null_Auction_State : constant Auction_State_Type := (Kind => None); hing : Integer := 13; end foo; --- package TD is type T (N : Natural) is private; function Is_Null (X : T) return Boolean; subtype Not_Null_T is T with Dynamic_Predicate => not Is_Null (Not_Null_T); private type T (N : Natural) is null record; function Is_Null (X : T) return Boolean is (X.N = 0); end; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Ed Schonberg * sem_ch6.adb (setr_Actual_Subtypes): Within a predicate function do not create actual subtypes that may generate further predicate functions. * sem_ch13.adb (Build_Predicate_Functions): Indicate that entity of body is a predicate function as well. (Resolve_Aspect_Expressions, Resolve_Name): For a component association, only the expression needs resolution, not the name. (Resolve_Aspect_Expressions, case Predicates): Construct and analyze the predicate function declaration in the scope of the type, before making the type and its discriminants visible. Index: sem_ch6.adb === --- sem_ch6.adb (revision 251772) +++ sem_ch6.adb (working copy) @@ -11588,6 +11588,12 @@ if Ekind (Subp) = E_Procedure and then Is_Null_Init_Proc (Subp) then return; + + -- Within a predicate function we do not want to generate local + -- subtypes that may generate nested predicate functions. + + elsif Is_Subprogram (Subp) and then Is_Predicate_Function (Subp) then + return; end if; -- The subtype declarations may freeze the formals. The body generated Index: sem_ch13.adb === --- sem_ch13.adb(revision 251786) +++ sem_ch13.adb(working copy) @@ -8700,6 +8700,9 @@ FBody : Node_Id; begin +Set_Ekind (SIdB, E_Function); +Set_Is_Predicate_Function (SIdB); + -- The predicate function is shared between views of a type if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then @@ -12664,6 +12667,7 @@ -- function Resolve_Name (N : Node_Id) return Traverse_Result is + Dummy : Traverse_Result; begin if Nkind (N) = N_Selected_Component then if Nkind (Prefix (N)) = N_Identifier @@ -12681,6 +12685,12 @@ Set_Entity (N, Empty); end if; + -- The name is component association needs no resolution. + + elsif Nkind (N) = N_Component_Association then +Dummy := Resolve_Name (Expression (N)); +return Skip; + elsif Nkind (N) = N_Quantified_Expression then return Skip; end if; @@ -12722,14 +12732,19 @@ | Aspect_Static_Predicate => -- Build predicate function specification and preanalyze - -- expression after type replacement. + -- expression after type replacement. The function + -- declaration must be analyzed in the scope of the + -- type, but the expression must see components. if No (Predicate_Function (E)) then +Uninstall_Discriminants_And_Pop_Scope (E); declare FDecl : constant Node_Id := Build_Predicate_Function_Declaration (E); pragma Unreferenced (FDecl); + begin + Push_Scope_And_Install_Discriminants (E); Resolve_Aspect_Expression (Expr); end; end if;
[Ada] Fix handling of ghost entity in predicate
Ghost types are allowed to mention ghost entities in their predicate.
Because Ghost is propagated from type to the generated predicate function,
GNAT correctly identified valid from invalid cases, but this modification
simplifies the reason for correction.
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-07 Yannick Moy
* ghost.adb (Check_Ghost_Context): Do not err on ghost code inside
predicate procedure. Check predicate pragma/aspect with Ghost entity.
* exp_ch6.adb, par-ch6.adb, sem_ch13.adb, sem_prag.adb; Minor
reformatting.
Index: exp_ch6.adb
===
--- exp_ch6.adb (revision 251835)
+++ exp_ch6.adb (working copy)
@@ -137,7 +137,8 @@
-- there are no tasks.
function Caller_Known_Size
- (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean;
+ (Func_Call : Node_Id;
+ Result_Subt : Entity_Id) return Boolean;
-- True if result subtype is definite, or has a size that does not require
-- secondary stack usage (i.e. no variant part or components whose type
-- depends on discriminants). In particular, untagged types with only
@@ -837,11 +838,14 @@
---
function Caller_Known_Size
- (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean is
+ (Func_Call : Node_Id;
+ Result_Subt : Entity_Id) return Boolean
+ is
begin
- return (Is_Definite_Subtype (Underlying_Type (Result_Subt))
- and then No (Controlling_Argument (Func_Call)))
- or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
+ return
+ (Is_Definite_Subtype (Underlying_Type (Result_Subt))
+and then No (Controlling_Argument (Func_Call)))
+or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
end Caller_Known_Size;
@@ -8081,7 +8085,8 @@
declare
Definite : constant Boolean :=
- Caller_Known_Size (Func_Call, Result_Subt);
+ Caller_Known_Size (Func_Call, Result_Subt);
+
begin
-- Create an access type designating the function's result subtype.
-- We use the type of the original call because it may be a call to
Index: ghost.adb
===
--- ghost.adb (revision 251834)
+++ ghost.adb (working copy)
@@ -281,6 +281,13 @@
if Chars (Subp_Id) = Name_uPostconditions then
return True;
+ -- The context is the internally built predicate function,
+ -- which is OK because the real check was done before the
+ -- predicate function was generated.
+
+ elsif Is_Predicate_Function (Subp_Id) then
+ return True;
+
else
Subp_Decl :=
Original_Node (Unit_Declaration_Node (Subp_Id));
@@ -362,10 +369,12 @@
return True;
-- An assertion expression pragma is Ghost when it contains a
- -- reference to a Ghost entity (SPARK RM 6.9(10)).
+ -- reference to a Ghost entity (SPARK RM 6.9(10)), except for
+ -- predicate pragmas (SPARK RM 6.9(11)).
- elsif Assertion_Expression_Pragma (Prag_Id) then
-
+ elsif Assertion_Expression_Pragma (Prag_Id)
+ and then Prag_Id /= Pragma_Predicate
+ then
-- Ensure that the assertion policy and the Ghost policy are
-- compatible (SPARK RM 6.9(18)).
@@ -464,9 +473,16 @@
return True;
-- A reference to a Ghost entity can appear within an aspect
- -- specification (SPARK RM 6.9(10)).
+ -- specification (SPARK RM 6.9(10)). The precise checking will
+ -- occur when analyzing the corresponding pragma. We make an
+ -- exception for predicate aspects that only allow referencing
+ -- a Ghost entity when the corresponding type declaration is
+ -- Ghost (SPARK RM 6.9(11)).
- elsif Nkind (Par) = N_Aspect_Specification then
+ elsif Nkind (Par) = N_Aspect_Specification
+ and then not Same_Aspect
+(Get_Aspect_Id (Par), Aspect_Predicate)
+ then
return True;
elsif Is_OK_Declaration (Par) then
Index: par-ch6.adb
===
--- par-ch6.adb (revision 251835)
+++ par-ch6.adb (working copy)
@@ -855,13 +855,14 @@
if Is_Non_Empty_List (Aspects) then
if Func then
-Error_Msg ("aspect specifications must come after "
- & "parenthesized
[Ada] Fix internal error on package instantiation and inlining
This fixes a small regression introduced by the recent improvement to the algorithm used by Hide_Public_Entities to compute the final set of external visible entities of a package. Subprogram renamings not only need to be dealt with as declaring a subprogram but also as referencing another one. The following procedure must compile quietly with -O -gnatn: with Q; procedure P (I : Integer) is begin if Q.Derive (I) /= I then raise Program_Error; end if; end; with G; package Q is function Derive (I : Integer) return Integer; pragma Inline (Derive); end Q; with G; package body Q is function Value (I : Integer) return Integer is begin return I; end; package My_G is new G (Integer, Value); function Derive (I : Integer) return Integer is begin return My_G.Compute (I); end; end Q; generic type T is private; with function Value (Arg : T) return Integer; package G is function Compute (Arg : T) return Integer; pragma Inline (Compute); end G; package body G is function Compute (Arg : T) return Integer is begin return Value (Arg); end; end G; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Eric Botcazou * sem_ch7.adb (Has_Referencer): For a subprogram renaming, also mark the renamed subprogram as referenced. Index: sem_ch7.adb === --- sem_ch7.adb (revision 251835) +++ sem_ch7.adb (working copy) @@ -439,6 +439,23 @@ then Set_Is_Public (Decl_Id, False); end if; + + -- For a subprogram renaming, if the entity is referenced, + -- then so is the renamed subprogram. But there is an issue + -- with generic bodies because instantiations are not done + -- yet and, therefore, cannot be scanned for referencers. + -- That's why we use an approximation and test that we have + -- at least one subprogram referenced by an inlined body + -- instead of precisely the entity of this renaming. + + if Nkind (Decl) = N_Subprogram_Renaming_Declaration +and then Subprogram_Table.Get_First +and then Is_Entity_Name (Name (Decl)) +and then Present (Entity (Name (Decl))) +and then Is_Subprogram (Entity (Name (Decl))) + then + Subprogram_Table.Set (Entity (Name (Decl)), True); + end if; end if; Prev (Decl);
[Ada] Spurious error in precondition and classwide parameter
This patch fixes a spurious error on a classwide precondition for a subprogram S that is a primitive of some type T, when the precondition includes a dispatching call on a classwide formal of S whose type is urelated to T. The following must compile quietly: gnatmake -q main --- with Derived_Objects; with Using_Interfaces; with Using_Objects; procedure Main is D : aliased Derived_Objects.Derived_Object; U : aliased Using_Objects.Using_Object; UI : not null access Using_Interfaces.Using_Interface'Class := U'Access; begin U.Use_An_Object (D); UI.Use_An_Object (D); U.Use_A_Valid_Object (D); UI.Use_A_Valid_Object (D); end Main; --- package Base_Objects is type Base_Object is tagged null record; function Is_Valid (This : in Base_Object) return Boolean is (True); end Base_Objects; --- with Base_Objects; package Derived_Objects is type Derived_Object is new Base_Objects.Base_Object with null record; end Derived_Objects; --- with Base_Objects; package Using_Interfaces is type Using_Interface is limited interface; procedure Use_An_Object (This : aliased in out Using_Interface; Obj : in Base_Objects.Base_Object'Class) is abstract; procedure Use_A_Valid_Object (This : aliased in out Using_Interface; Obj : in Base_Objects.Base_Object'Class) is abstract with Pre'Class => Obj.Is_Valid; end Using_Interfaces; --- with Base_Objects; with Using_Interfaces; package Using_Objects is type Using_Object is limited new Using_Interfaces.Using_Interface with null record; procedure Use_An_Object (This : aliased in out Using_Object; Base : in Base_Objects.Base_Object'Class) is null; procedure Use_A_Valid_Object (This : aliased in out Using_Object; Base : in Base_Objects.Base_Object'Class) is null; end Using_Objects; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Ed Schonberg * exp_disp.adb (Replace_Formals): If thr formal is classwide, and thus not a controlling argument, preserve its type after rewriting because it may appear in an nested call with a classwide parameter. Index: exp_disp.adb === --- exp_disp.adb(revision 251838) +++ exp_disp.adb(working copy) @@ -701,6 +701,16 @@ while Present (F) loop if F = Entity (N) then Rewrite (N, New_Copy_Tree (A)); + +-- If the formal is class-wide, and thus not a +-- controlling argument, preserve its type because +-- it may appear in a nested call with a class-wide +-- parameter. + +if Is_Class_Wide_Type (Etype (F)) then + Set_Etype (N, Etype (F)); +end if; + exit; end if;
[Ada] Return raise with access class-wide interface
This patches fixes a bug in which a function returns an anonymous access type whose designated type is a class-wide interface type, and the return statement returns a raise expression, the compiler crashes. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Bob Duff * sem_ch6.adb (Analyze_Function_Return): Do not insert an explicit conversion to force the displacement of the "this" pointer to reference the secondary dispatch table in the case where the return statement is returning a raise expression, as in "return raise ...". Index: sem_ch6.adb === --- sem_ch6.adb (revision 251835) +++ sem_ch6.adb (working copy) @@ -910,7 +910,7 @@ if Expander_Active and then Serious_Errors_Detected = 0 and then Is_Access_Type (R_Type) - and then Nkind (Expr) /= N_Null + and then not Nkind_In (Expr, N_Null, N_Raise_Expression) and then Is_Interface (Designated_Type (R_Type)) and then Is_Progenitor (Designated_Type (R_Type), Designated_Type (Etype (Expr)))
[Ada] Adding switch to disable implicit Elaborate_All in task case
This patch adds switch -gnatd.y to disable the generation of implicit Elaborate_All on a package X when a task body calls a procedure in the same package, and that procedure calls a procedure in another package X. As documented in the GNAT User Guide, when sources cannot be modified, the recommended solution is the use of restriction No_Entry_Calls_In_Elaboration_Code. This switch provides a way to disable the generation of the implicit Elaborate_All when that restriction is not applicable to the sources. The following test now compiles without errors: with Utils; package body Decls is procedure Put_Val (Arg : Decls.My_Int) is begin Utils.Put_Val(Arg); end Put_Val; task body Lib_Task is begin accept Start; Put_Val (2); -- Utils.Put_Val(Arg); end Lib_Task; function Ident (M : My_Int) return My_Int is begin return M; end Ident; end Decls; package Decls is task Lib_Task is entry Start; end Lib_Task; type My_Int is new Integer; function Ident (M : My_Int) return My_Int; end Decls; with Decls; procedure Main is begin Decls.Lib_Task.Start; end; with Text_IO; package body Utils is procedure Put_Val (Arg : Decls.My_Int) is begin Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg))); end Put_Val; end Utils; with Decls; package Utils is procedure Put_Val (Arg : Decls.My_Int); end Utils; Command: gnatmake main.adb -gnatd.y Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Javier Miranda * sem_elab.adb (Check_Task_Activation): Adding switch -gnatd.y to allow disabling the generation of implicit pragma Elaborate_All on task bodies. Index: debug.adb === --- debug.adb (revision 251834) +++ debug.adb (working copy) @@ -115,7 +115,7 @@ -- d.v -- d.w Do not check for infinite loops -- d.x No exception handlers - -- d.y + -- d.y Disable implicit pragma Elaborate_All on task bodies -- d.z Restore previous support for frontend handling of Inline_Always -- d.A Read/write Aspect_Specifications hash table to tree @@ -603,6 +603,12 @@ -- fully compiled and analyzed, they just get eliminated from the -- code generation step. + -- d.y Disable implicit pragma Elaborate_All on task bodies. When a task + -- body calls a procedure in the same package, and that procedure + -- calls a procedure in another package, the static elaboration + -- machinery adds an implicit Elaborate_All on the other package. This + -- switch disables the addition of the implicit pragma in such cases. + -- -- d.z Restore previous front-end support for Inline_Always. In default -- mode, for targets that use the GCC back end, Inline_Always is -- handled by the back end. Use of this switch restores the previous Index: sem_elab.adb === --- sem_elab.adb(revision 251834) +++ sem_elab.adb(working copy) @@ -2961,19 +2961,21 @@ Next_Elmt (Elmt); end loop; - -- For tasks declared in the current unit, trace other calls within - -- the task procedure bodies, which are available. + -- For tasks declared in the current unit, trace other calls within the + -- task procedure bodies, which are available. - In_Task_Activation := True; + if not Debug_Flag_Dot_Y then + In_Task_Activation := True; - Elmt := First_Elmt (Intra_Procs); - while Present (Elmt) loop - Ent := Node (Elmt); - Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); - Next_Elmt (Elmt); - end loop; + Elmt := First_Elmt (Intra_Procs); + while Present (Elmt) loop +Ent := Node (Elmt); +Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); +Next_Elmt (Elmt); + end loop; - In_Task_Activation := False; + In_Task_Activation := False; + end if; end Check_Task_Activation; --- Index: sem_elab.ads === --- sem_elab.ads(revision 251834) +++ sem_elab.ads(working copy) @@ -71,7 +71,7 @@ -- output a warning. -- For calls to a subprogram in a with'ed unit or a 'Access or variable - -- refernece (SPARK mode case), we require that a pragma Elaborate_All + -- reference (SPARK mode case), we require that a pragma Elaborate_All -- or pragma Elaborate be present, or that the referenced unit have a -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none -- of these conditions is met, then a warning is generated that a pragma
[Ada] Proper handling of dimension information in a type conversion.
This patch implements the proper handling of dimension information on type conversions. Given a conversion T (Expr), where the expression has type TE, the following cases arise: a) If TE has dimension information, the dimensions of the conversion are those of TE. b) If TE has no dimension information, dimensions of conversion are those of T. c) If T and TE belong to different dimension systems, they must have identical dimensions, unless T is the root type of its system, in which case dimensions are those of TE, and the conversion can be seen as a "view conversion" that preserves the dimensions of its argument. d) If T is a non-dimensioned type, such a Standard.Float, the conversion has no dimension information. The following must compile quietly: gcc -c main.adb gcc -c -gnatd.F main.adb --- with Units; use Units; procedure main with SPARK_Mode is subtype Servo_Angle_Type is Units.Angle_Type range -40.0 * Degree .. 40.0 * Degree; function Sat_Servo_Angle is new Saturated_Cast (Servo_Angle_Type); begin null; end main; --- with Ada.Numerics; package units with SPARK_Mode is type Unit_Type is new Float with Dimension_System => ((Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Theta"), (Unit_Name => Radian, Unit_Symbol => "Rad", Dim_Symbol => "A")), Default_Value => 0.0; -- required for matrices subtype Angle_Type is Unit_Type with Dimension => (Symbol => "Rad", Radian => 1, others => 0); Degree : constant Angle_Type := Angle_Type (2.0 * Ada.Numerics.Pi / 360.0); generic type T is digits <>; function Saturated_Cast (val : Float) return T with Inline; -- convert a float into a more specific float type, and trim -- to the value range end units; --- package body units with SPARK_Mode is function Saturated_Cast (val : Float) return T is ret : T; begin if val >= Float (T'Last) then ret := T'Last; elsif val <= Float (T'First) then ret := T'First; else ret := T (val); end if; return ret; end Saturated_Cast; end units; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Ed Schonberg * sem_dim.adb (Analyze_Dimension_Type_Conversion): New procedure to handle properly various cases of type conversions where the target type and/or the expression carry dimension information. (Dimension_System_Root); If a subtype carries dimension information, obtain the source parent type that carries the Dimension aspect. Index: sem_dim.adb === --- sem_dim.adb (revision 251836) +++ sem_dim.adb (working copy) @@ -35,6 +35,7 @@ with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -280,6 +281,14 @@ -- both the identifier and the parent type of N are not dimensionless, -- return an error. + procedure Analyze_Dimension_Type_Conversion (N : Node_Id); + -- Type conversions handle conversions between literals and dimensioned + -- types, from dimensioned types to their base type, and between different + -- dimensioned systems. Dimensions of the conversion are obtained either + -- from those of the expression, or from the target type, and dimensional + -- consistency must be checked when converting between values belonging + -- to different dimensioned systems. + procedure Analyze_Dimension_Unary_Op (N : Node_Id); -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and -- Abs operators, propagate the dimensions from the operand to N. @@ -301,6 +310,11 @@ -- dimension" if Description_Needed. if N is dimensionless, return "'[']", -- or "is dimensionless" if Description_Needed. + function Dimension_System_Root (T : Entity_Id) return Entity_Id; + -- Given a type that has dimension information, return the type that is the + -- root of its dimension system, e.g. Mks_Type. If T is not a dimensioned + -- type, i.e. a standard numeric type, return Empty. + procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id); -- Issue a warning on the given numeric literal N to indicate that the -- compiler made the assumption that the literal is not dimensionless @@ -1191,13 +1205,7 @@ Analyze_Dimension_Subtype_Declaration (N); when N_Type_Conversion => -if In_Instance - and then Exists (Dimensions_Of (Expression (N))) -then - Set_Dimensio
[Ada] Use of renamings of function results in SPARK annotations
This patch changes the expansion of object renamings in SPARK to reuse the entity associated with the renaming when the name denotes a function call. The patch also modifies a routine used to extract the entity of references to abstract states and whole objects to handle renamings of function results. Together, both these changes allow for function result renamings in SPARK annotations. -- Source -- -- pack.ads package Pack with SPARK_Mode is type Lim_Rec is limited record Data : Integer; end record; function Get_Integer return Integer; function Get_Lim_Rec return Lim_Rec; function Get_String return String; end Pack; -- pack.adb package body Pack with SPARK_Mode is function Get_Integer return Integer is begin return 123; end Get_Integer; function Get_Lim_Rec return Lim_Rec is begin return Result : Lim_Rec; end Get_Lim_Rec; function Get_String return String is begin return "456"; end Get_String; package Nested with Initializes => (Int_Ren, Lim_Ren, Str_Ren) is Int_Ren : Integer renames Get_Integer; Lim_Ren : Lim_Rec renames Get_Lim_Rec; Str_Ren : String renames Get_String; procedure Proc with Global => (Int_Ren, Lim_Ren, Str_Ren), Depends => (null => (Int_Ren, Lim_Ren, Str_Ren)); end Nested; package body Nested is procedure Proc is begin null; end Proc; end Nested; end Pack; -- Compilation and output -- $ gcc -c pack.adb $ gcc -c pack.adb -gnatd.F pack.adb:9:14: warning: variable "Result" is read but never assigned pack.adb:9:14: warning: variable "Result" is read but never assigned Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-08 Hristian Kirtchev * exp_spark.adb (Expand_SPARK_N_Object_Renaming_Declaration): Reimplemented. (Expand_SPARK_Potential_Renaming): Code clean up. * sem_prag.adb (Analyze_Initialization_Item): Add a guard in case the item does not have a proper entity. (Analyze_Input_Item): Add a guard in case the item does not have a proper entity. (Collect_States_And_Objects): Include object renamings in the items being collected. (Resolve_State): Update the documentation of this routine. * sem_util.adb (Entity_Of): Add circuitry to handle renamings of function results. (Remove_Entity): New routine. (Remove_Overloaded_Entity): Take advantage of factorization. * sem_util.ads (Entity_Of): Update the documentation of this routine. (Remove_Entity): New routine. (Remove_Overloaded_Entity): Update the documentation of this routine. Index: exp_spark.adb === --- exp_spark.adb (revision 251863) +++ exp_spark.adb (working copy) @@ -292,10 +292,55 @@ procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id) is + CFS: constant Boolean:= Comes_From_Source (N); + Loc: constant Source_Ptr := Sloc (N); + Obj_Id : constant Entity_Id := Defining_Entity (N); + Nam: constant Node_Id:= Name (N); + Typ: constant Entity_Id := Etype (Subtype_Mark (N)); + begin - -- Unconditionally remove all side effects from the name + -- Transform a renaming of the form - Evaluate_Name (Name (N)); + --Obj_Id : renames ; + + -- into + + --Obj_Id : constant := ; + + -- Invoking Evaluate_Name and ultimately Remove_Side_Effects introduces + -- a temporary to capture the function result. Once potential renamings + -- are rewritten for SPARK, the temporary may be leaked out into source + -- constructs and lead to confusing error diagnostics. Using an object + -- declaration prevents this unwanted side effect. + + if Nkind (Nam) = N_Function_Call then + Rewrite (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Constant_Present=> True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Nam)); + + -- Inherit the original Comes_From_Source status of the renaming + + Set_Comes_From_Source (N, CFS); + + -- Sever the link to the renamed function result because the entity + -- will no longer alias anything. + + Set_Renamed_Object (Obj_Id, Empty); + + -- Remove the entity of the renaming declaration from visibility as + -- the analysis of the object declaration will reintroduce it again. + + Remove_Entity (Obj_Id); + Analyze (N); + + -- Otherwise unconditionally remove all side effects from the name + + else + Evaluate_Name (Nam); + end if; end Expand_S
[Ada] Small fix for couple of internal glitches with record layout
This change ensures that (1) -gnatR always displays the record layout that was used internally by the compiler for code generation and (2) the record layout is fully adjusted internally when the reverse bit order is specified. No functional changes expected because the first issue was papering over the second issue and the second issue was very likely harmless in practice since the normalized position is redundant with the bit offset, which was correct. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-08 Eric Botcazou * repinfo.adb (List_Record_Info): During first loop, do not override the normalized position and first bit if they have already been set. Move fallback code for the packed case to the case where it belongs. * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Also adjust the normalized position of components. (Adjust_Record_For_Reverse_Bit_Order_Ada_95): Likewise. Index: repinfo.adb === --- repinfo.adb (revision 251863) +++ repinfo.adb (working copy) @@ -894,30 +894,30 @@ Cfbit := Component_Bit_Offset (Comp); if Rep_Not_Constant (Cfbit) then - UI_Image_Length := 2; + -- If the record is not packed, then we know that all fields + -- whose position is not specified have a starting normalized + -- bit position of zero. + if Unknown_Normalized_First_Bit (Comp) + and then not Is_Packed (Ent) + then + Set_Normalized_First_Bit (Comp, Uint_0); + end if; + + UI_Image_Length := 2; -- For "??" marker else -- Complete annotation in case not done - Set_Normalized_Position (Comp, Cfbit / SSU); - Set_Normalized_First_Bit (Comp, Cfbit mod SSU); + if Unknown_Normalized_First_Bit (Comp) then + Set_Normalized_Position (Comp, Cfbit / SSU); + Set_Normalized_First_Bit (Comp, Cfbit mod SSU); + end if; Sunit := Cfbit / SSU; UI_Image (Sunit); end if; --- If the record is not packed, then we know that all fields --- whose position is not specified have a starting normalized --- bit position of zero. - -if Unknown_Normalized_First_Bit (Comp) - and then not Is_Packed (Ent) -then - Set_Normalized_First_Bit (Comp, Uint_0); -end if; - -Max_Suni_Length := - Natural'Max (Max_Suni_Length, UI_Image_Length); +Max_Suni_Length := Natural'Max (Max_Suni_Length, UI_Image_Length); end if; Next_Component_Or_Discriminant (Comp); Index: sem_ch13.adb === --- sem_ch13.adb(revision 251866) +++ sem_ch13.adb(working copy) @@ -627,6 +627,7 @@ end if; Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); + Set_Normalized_Position (Comp, Pos + NFB / SSU); Set_Normalized_First_Bit (Comp, NFB mod SSU); end; end loop; @@ -750,6 +751,9 @@ (System_Storage_Unit - 1) - (Start_Bit + CSZ - 1)); + Set_Normalized_Position (Comp, +Component_Bit_Offset (Comp) / System_Storage_Unit); + Set_Normalized_First_Bit (Comp, Component_Bit_Offset (Comp) mod System_Storage_Unit); end if;
[Ada] Infinite loop on an interface conversion involving private extensions.
This patch fixes a loop in the compiler, on an interface conversion from an interface declared as a synchronized private extension to one of its ancestors. databases-instantiations,adb below must compile quietly: --- package body Databases.Generics is New_Data_ID : Data_ID_Type := 1; protected body Database_Type is procedure Register (Data_Name : in Data_Name_Type; Data_ID : out Data_ID_Type) is Tmp_Data_ID : constant Data_ID_Type := New_Data_ID; begin Data_Names (Data_ID) := Data_Name; Data_Objects_Map (Data_ID) := Data_Object' (Data => Init_Data, Timestamp => Time_First); New_Data_ID := New_Data_ID + 1; Data_ID := Tmp_Data_ID; end Register; procedure Set (Data_ID : in Data_ID_Type; Raw_Data : in UInt8_Array) is Data : Data_Type with Address => Raw_Data'Address; begin Set (Data_ID => Data_ID, Data=> Data); end Set; function Get (Data_ID : in Data_ID_Type) return UInt8_Array is Data_Size : constant Natural := Data_Type'Size / 8; Data : constant Data_Type := Get (Data_ID); Raw_Data : UInt8_Array (1 .. Data_Size) with Address => Data'Address; begin return Raw_Data; end Get; procedure Set (Data_ID : in Data_ID_Type; Data: in Data_Type) is begin Data_Objects_Map (Data_ID).Timestamp := Clock; Data_Objects_Map (Data_ID).Data := Data; end Set; function Get (Data_ID : in Data_ID_Type) return Data_Type is begin return Data_Objects_Map (Data_ID).Data; end Get; function Get_Timestamp (Data_ID : in Data_ID_Type) return Ada.Real_Time.Time is begin return Data_Objects_Map (Data_ID).Timestamp; end Get_Timestamp; end Database_Type; function Get_Database_Instance return Database_Access is begin return Database_Instance'Access; end Get_Database_Instance; end Databases.Generics; with Ada.Real_Time; use Ada.Real_Time; with Databases; use Databases; generic type Data_Type is private; -- The data type that should be stored in the database Init_Data : Data_Type; -- The value that should be set just after the data registration Max_Nb_Data : Positive; -- The maximun number of data that can be stored in the database package Databases.Generics is type Typed_Database_Interface is synchronized interface; function Get (Database : Typed_Database_Interface; Data_ID : Data_ID_Type) return Data_Type is abstract; -- Get the currently set value for given Data_ID function Get_Timestamp (Database : Typed_Database_Interface; Data_ID : Data_ID_Type) return Time is abstract; procedure Set (Database : in out Typed_Database_Interface; Data_ID : Data_ID_Type; Data : Data_Type) is abstract; -- Set a value for the given Data_ID type Database_Type is synchronized new Root_Database_Type and Typed_Database_Interface with private; type Database_Access is access all Database_Type'Class; -- Database types for the given Data_Type. function Get_Database_Instance return Database_Access; -- Return the unique database instance for this package. private type Data_Object is record Data : Data_Type; Timestamp : Ada.Real_Time.Time; end record; type Data_Object_Array is array (Data_ID_Type'First .. Data_ID_Type (Max_Nb_Data)) of Data_Object; protected type Database_Type is new Root_Database_Type and Typed_Database_Interface with overriding procedure Register (Data_Name : in Data_Name_Type; Data_ID : out Data_ID_Type); overriding function Get (Data_ID : in Data_ID_Type) return UInt8_Array; overriding procedure Set (Data_ID : in Data_ID_Type; Raw_Data : UInt8_Array); overriding function Get (Data_ID : in Data_ID_Type) return Data_Type; -- Get the currently set value for given Data_ID overriding function Get_Timestamp (Data_ID : in Data_ID_Type) return Time; overriding procedure Set (Data_ID : in Data_ID_Type; Data: in Data_Type); -- Set a value for the given Data_ID private ID : Database_ID_Type := Get_New_Database_ID; Data_Objects_Map : Data_Object_Array; Data_Names : Data_Name_Array; end Database_Type; Database_Instance : aliased Database_Type; end Databases.Generics; package body Databases.Instantiations is procedure Set_Raw_Data (Database_ID : Database_ID_Type; Data_ID : Data_ID_Type; Raw_Data: UInt8_Array) is begin Databases (Database_ID).Set (Data_ID => Data_ID, Raw_Data => Raw_Data); end Set_Raw_Data; functio
