diff options
Diffstat (limited to 'gcc/ada/gcc-interface')
| -rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 398 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 25 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/a-assert.adb | 52 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/a-assert.ads | 50 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/ada-tree.h | 8 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/ada.h | 2 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/cuintp.c | 15 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/decl.c | 444 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/gadaint.h | 2 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/gigi.h | 39 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/lang-specs.h | 2 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/misc.c | 20 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/system.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/targtyps.c | 2 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.c | 489 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/utils.c | 52 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/utils2.c | 68 |
17 files changed, 1042 insertions, 644 deletions
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index d88c354..765654f 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -58,17 +58,45 @@ WARN_ADAFLAGS= -W -Wall # need to be built by a recent/matching native so we might as well leave the # checks fully active. +STAGE1=False +GNATBIND_FLAGS= +GNATLIB= + ifeq ($(CROSS),) -ADAFLAGS= $(COMMON_ADAFLAGS) -gnatwns + ADAFLAGS=$(COMMON_ADAFLAGS) -gnatwns + + ifeq ($(if $(wildcard ../stage_current),$(shell cat ../stage_current),stage1),stage1) + STAGE1=True + GNATBIND_FLAGS=-t + endif else -ADAFLAGS= $(COMMON_ADAFLAGS) + ADAFLAGS=$(COMMON_ADAFLAGS) endif ALL_ADAFLAGS = \ $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) $(CHECKING_ADAFLAGS) $(WARN_ADAFLAGS) FORCE_DEBUG_ADAFLAGS = -g ADA_CFLAGS = -ADA_INCLUDES = -nostdinc -I- -I. -Iada/generated -Iada -Iada/gcc-interface -I$(srcdir)/ada -I$(srcdir)/ada/gcc-interface -Iada/libgnat -I$(srcdir)/ada/libgnat +COMMON_ADA_INCLUDES = -I- -I. -Iada/generated -Iada -I$(srcdir)/ada + +STAGE1_LIBS= + +ifeq ($(strip $(filter-out linux%,$(host_os))),) + STAGE1_LIBS=-ldl +endif + +ifeq ($(strip $(filter-out hpux%,$(host_os))),) + STAGE1_LIBS=/usr/lib/libcl.a +endif + +ifeq ($(STAGE1),True) + ADA_INCLUDES=$(COMMON_ADA_INCLUDES) + adalib=$(dir $(shell $(CC) -print-libgcc-file-name))adalib + GNATLIB=$(adalib)/$(if $(wildcard $(adalib)/libgnat.a),libgnat.a,libgnat.so) $(STAGE1_LIBS) +else + ADA_INCLUDES=-nostdinc $(COMMON_ADA_INCLUDES) -Iada/libgnat -I$(srcdir)/ada/libgnat -Iada/gcc-interface -I$(srcdir)/ada/gcc-interface +endif + GNATLIBFLAGS= -W -Wall -gnatpg -nostdinc GNATLIBCFLAGS= -g -O2 $(TCFLAGS) ADA_INCLUDE_DIR = $(libsubdir)/adainclude @@ -242,22 +270,29 @@ GCC_LLINK=$(LLINKER) $(GCC_LINKERFLAGS) $(LDFLAGS) # Languages-specific object files for Ada. -# Object files for gnat1 from C sources. -GNAT1_C_OBJS = ada/adadecode.o ada/adaint.o ada/argv.o ada/cio.o \ - ada/cstreams.o ada/env.o ada/init.o ada/initialize.o ada/raise.o \ - ada/raise-gcc.o \ - ada/seh_init.o ada/targext.o ada/cuintp.o ada/decl.o ada/rtfinal.o \ - ada/rtinit.o ada/misc.o ada/utils.o ada/utils2.o ada/trans.o ada/targtyps.o +# Object files from C sources that are used by gnat1 +# Most of the non-gigi files are needed because of s-crtl.o and s-os_lib.o +# But adadecode.o should not be needed with sufficiently recent compilers +GNAT1_C_OBJS = \ + ada/cuintp.o \ + ada/decl.o \ + ada/misc.o \ + ada/utils.o \ + ada/utils2.o \ + ada/trans.o \ + ada/targtyps.o \ + ada/adadecode.o \ + ada/adaint.o \ + ada/argv.o \ + ada/cio.o \ + ada/cstreams.o \ + ada/env.o \ + ada/errno.o \ + ada/targext.o \ + ada/version.o # Object files from Ada sources that are used by gnat1 GNAT_ADA_OBJS = \ - ada/libgnat/a-charac.o \ - ada/libgnat/a-chlat1.o \ - ada/libgnat/a-elchha.o \ - ada/libgnat/a-except.o \ - ada/libgnat/a-exctra.o \ - ada/libgnat/a-ioexce.o \ - ada/libgnat/ada.o \ ada/spark_xrefs.o \ ada/ali.o \ ada/alloc.o \ @@ -272,6 +307,8 @@ GNAT_ADA_OBJS = \ ada/cstand.o \ ada/debug.o \ ada/debug_a.o \ + ada/einfo-entities.o \ + ada/einfo-utils.o \ ada/einfo.o \ ada/elists.o \ ada/err_vars.o \ @@ -316,25 +353,13 @@ GNAT_ADA_OBJS = \ ada/fname.o \ ada/freeze.o \ ada/frontend.o \ - ada/libgnat/g-byorma.o \ - ada/libgnat/g-dynhta.o \ - ada/libgnat/g-graphs.o \ - ada/libgnat/g-hesora.o \ - ada/libgnat/g-htable.o \ - ada/libgnat/g-lists.o \ - ada/libgnat/g-sets.o \ - ada/libgnat/g-spchge.o \ - ada/libgnat/g-speche.o \ - ada/libgnat/g-u3spch.o \ ada/get_targ.o \ ada/ghost.o \ ada/gnat_cuda.o \ - ada/libgnat/gnat.o \ ada/gnatvsn.o \ ada/hostparm.o \ ada/impunit.o \ ada/inline.o \ - ada/libgnat/interfac.o \ ada/itypes.o \ ada/krunch.o \ ada/layout.o \ @@ -362,67 +387,13 @@ GNAT_ADA_OBJS = \ ada/restrict.o \ ada/rident.o \ ada/rtsfind.o \ - ada/libgnat/s-addope.o \ - ada/libgnat/s-addima.o \ - ada/libgnat/s-assert.o \ - ada/libgnat/s-bitops.o \ - ada/libgnat/s-carun8.o \ - ada/libgnat/s-casuti.o \ - ada/libgnat/s-conca2.o \ - ada/libgnat/s-conca3.o \ - ada/libgnat/s-conca4.o \ - ada/libgnat/s-conca5.o \ - ada/libgnat/s-conca6.o \ - ada/libgnat/s-conca7.o \ - ada/libgnat/s-conca8.o \ - ada/libgnat/s-conca9.o \ - ada/libgnat/s-crc32.o \ - ada/libgnat/s-crtl.o \ - ada/libgnat/s-excdeb.o \ - ada/libgnat/s-except.o \ - ada/libgnat/s-exctab.o \ - ada/libgnat/s-excmac.o \ - ada/libgnat/s-htable.o \ - ada/libgnat/s-imenne.o \ - ada/libgnat/s-imgenu.o \ - ada/libgnat/s-imgint.o \ - ada/libgnat/s-mastop.o \ - ada/libgnat/s-memory.o \ - ada/libgnat/s-os_lib.o \ - ada/libgnat/s-parame.o \ - ada/libgnat/s-purexc.o \ - ada/libgnat/s-restri.o \ - ada/libgnat/s-secsta.o \ - ada/libgnat/s-soflin.o \ - ada/libgnat/s-soliin.o \ - ada/libgnat/s-sopco3.o \ - ada/libgnat/s-sopco4.o \ - ada/libgnat/s-sopco5.o \ - ada/libgnat/s-stache.o \ - ada/libgnat/s-stalib.o \ - ada/libgnat/s-stoele.o \ - ada/libgnat/s-strcom.o \ - ada/libgnat/s-strhas.o \ - ada/libgnat/s-string.o \ - ada/libgnat/s-strops.o \ - ada/libgnat/s-traceb.o \ - ada/libgnat/s-traent.o \ - ada/libgnat/s-trasym.o \ - ada/libgnat/s-unstyp.o \ - ada/libgnat/s-utf_32.o \ - ada/libgnat/s-valint.o \ - ada/libgnat/s-valuns.o \ - ada/libgnat/s-valuti.o \ - ada/libgnat/s-wchcnv.o \ - ada/libgnat/s-wchcon.o \ - ada/libgnat/s-wchjis.o \ - ada/libgnat/s-wchstw.o \ ada/scans.o \ ada/scil_ll.o \ ada/scn.o \ ada/scng.o \ ada/scos.o \ ada/sdefault.o \ + ada/seinfo.o \ ada/sem.o \ ada/sem_aggr.o \ ada/sem_attr.o \ @@ -458,6 +429,8 @@ GNAT_ADA_OBJS = \ ada/sem_warn.o \ ada/set_targ.o \ ada/sinfo-cn.o \ + ada/sinfo-nodes.o \ + ada/sinfo-utils.o \ ada/sinfo.o \ ada/sinput-d.o \ ada/sinput-l.o \ @@ -471,12 +444,10 @@ GNAT_ADA_OBJS = \ ada/stylesw.o \ ada/switch-c.o \ ada/switch.o \ - ada/gcc-interface/system.o \ ada/table.o \ ada/targparm.o \ ada/tbuild.o \ ada/treepr.o \ - ada/treeprs.o \ ada/ttypes.o \ ada/types.o \ ada/uintp.o \ @@ -486,7 +457,97 @@ GNAT_ADA_OBJS = \ ada/validsw.o \ ada/vast.o \ ada/warnsw.o \ - ada/widechar.o + ada/widechar.o \ + ada/gnat.o \ + ada/g-dynhta.o \ + ada/g-graphs.o \ + ada/g-lists.o \ + ada/g-sets.o \ + ada/s-casuti.o \ + ada/s-crtl.o \ + ada/s-os_lib.o \ + ada/s-pehage.o \ + ada/s-utf_32.o + +ifeq ($(STAGE1),False) +GNAT1_C_OBJS+= \ + ada/init.o \ + ada/initialize.o \ + ada/raise.o \ + ada/raise-gcc.o \ + ada/rtfinal.o \ + ada/rtinit.o \ + ada/seh_init.o + +GNAT_ADA_OBJS+= \ + ada/gcc-interface/system.o \ + ada/libgnat/a-assert.o \ + ada/libgnat/a-charac.o \ + ada/libgnat/a-chlat1.o \ + ada/libgnat/a-elchha.o \ + ada/libgnat/a-except.o \ + ada/libgnat/a-exctra.o \ + ada/libgnat/a-ioexce.o \ + ada/libgnat/ada.o \ + ada/libgnat/g-byorma.o \ + ada/libgnat/g-heasor.o \ + ada/libgnat/g-htable.o \ + ada/libgnat/g-spchge.o \ + ada/libgnat/g-speche.o \ + ada/libgnat/g-table.o \ + ada/libgnat/g-u3spch.o \ + ada/libgnat/interfac.o \ + ada/libgnat/s-addope.o \ + ada/libgnat/s-addima.o \ + ada/libgnat/s-assert.o \ + ada/libgnat/s-bitops.o \ + ada/libgnat/s-carun8.o \ + ada/libgnat/s-conca2.o \ + ada/libgnat/s-conca3.o \ + ada/libgnat/s-conca4.o \ + ada/libgnat/s-conca5.o \ + ada/libgnat/s-conca6.o \ + ada/libgnat/s-conca7.o \ + ada/libgnat/s-conca8.o \ + ada/libgnat/s-conca9.o \ + ada/libgnat/s-crc32.o \ + ada/libgnat/s-excdeb.o \ + ada/libgnat/s-except.o \ + ada/libgnat/s-excmac.o \ + ada/libgnat/s-exctab.o \ + ada/libgnat/s-htable.o \ + ada/libgnat/s-imenne.o \ + ada/libgnat/s-imgint.o \ + ada/libgnat/s-mastop.o \ + ada/libgnat/s-memory.o \ + ada/libgnat/s-parame.o \ + ada/libgnat/s-purexc.o \ + ada/libgnat/s-restri.o \ + ada/libgnat/s-secsta.o \ + ada/libgnat/s-soflin.o \ + ada/libgnat/s-soliin.o \ + ada/libgnat/s-sopco3.o \ + ada/libgnat/s-sopco4.o \ + ada/libgnat/s-sopco5.o \ + ada/libgnat/s-stache.o \ + ada/libgnat/s-stalib.o \ + ada/libgnat/s-stoele.o \ + ada/libgnat/s-strcom.o \ + ada/libgnat/s-strhas.o \ + ada/libgnat/s-string.o \ + ada/libgnat/s-strops.o \ + ada/libgnat/s-traceb.o \ + ada/libgnat/s-traent.o \ + ada/libgnat/s-trasym.o \ + ada/libgnat/s-unstyp.o \ + ada/libgnat/s-valint.o \ + ada/libgnat/s-valuns.o \ + ada/libgnat/s-valuti.o \ + ada/libgnat/s-wchcnv.o \ + ada/libgnat/s-wchcon.o \ + ada/libgnat/s-wchjis.o \ + ada/libgnat/s-wchstw.o +endif # Object files for gnat executables GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o @@ -494,14 +555,9 @@ GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) ada/b_gnat1.o GNATBIND_OBJS = \ - ada/libgnat/a-elchha.o \ - ada/libgnat/a-except.o \ - ada/libgnat/ada.o \ - ada/adaint.o \ ada/ali-util.o \ ada/ali.o \ ada/alloc.o \ - ada/argv.o \ ada/aspects.o \ ada/atree.o \ ada/bcheck.o \ @@ -520,13 +576,12 @@ GNATBIND_OBJS = \ ada/bindusg.o \ ada/butil.o \ ada/casing.o \ - ada/cio.o \ ada/csets.o \ - ada/cstreams.o \ ada/debug.o \ + ada/einfo-entities.o \ + ada/einfo-utils.o \ ada/einfo.o \ ada/elists.o \ - ada/env.o \ ada/err_vars.o \ ada/errout.o \ ada/erroutc.o \ @@ -535,20 +590,9 @@ GNATBIND_OBJS = \ ada/fmap.o \ ada/fname-uf.o \ ada/fname.o \ - ada/libgnat/g-byorma.o \ - ada/libgnat/g-dynhta.o \ - ada/libgnat/g-graphs.o \ - ada/libgnat/g-hesora.o \ - ada/libgnat/g-htable.o \ - ada/libgnat/g-lists.o \ - ada/libgnat/g-sets.o \ - ada/libgnat/gnat.o \ ada/gnatbind.o \ ada/gnatvsn.o \ ada/hostparm.o \ - ada/init.o \ - ada/initialize.o \ - ada/libgnat/interfac.o \ ada/krunch.o \ ada/lib.o \ ada/link.o \ @@ -558,16 +602,73 @@ GNATBIND_OBJS = \ ada/osint-b.o \ ada/osint.o \ ada/output.o \ - ada/raise.o \ - ada/raise-gcc.o \ ada/restrict.o \ ada/rident.o \ + ada/scans.o \ + ada/scil_ll.o \ + ada/scng.o \ + ada/sdefault.o \ + ada/seinfo.o \ + ada/sem_aux.o \ + ada/sinfo.o \ + ada/sinfo-nodes.o \ + ada/sinfo-utils.o \ + ada/sinput-c.o \ + ada/sinput.o \ + ada/snames.o \ + ada/stand.o \ + ada/stringt.o \ + ada/style.o \ + ada/styleg.o \ + ada/stylesw.o \ + ada/switch-b.o \ + ada/switch.o \ + ada/table.o \ + ada/targparm.o \ + ada/types.o \ + ada/uintp.o \ + ada/uname.o \ + ada/urealp.o \ + ada/widechar.o \ + ada/gnat.o \ + ada/g-dynhta.o \ + ada/g-lists.o \ + ada/g-graphs.o \ + ada/g-sets.o \ + ada/s-casuti.o \ + ada/s-os_lib.o \ + ada/s-resfil.o \ + ada/s-utf_32.o \ + ada/adaint.o \ + ada/argv.o \ + ada/cio.o \ + ada/cstreams.o \ + ada/env.o \ + ada/errno.o \ + ada/targext.o \ + ada/version.o + +ifeq ($(STAGE1),False) +GNATBIND_OBJS += \ + ada/init.o \ + ada/initialize.o \ + ada/raise.o \ + ada/raise-gcc.o \ ada/rtfinal.o \ ada/rtinit.o \ + ada/seh_init.o \ + ada/gcc-interface/system.o \ + ada/libgnat/a-assert.o \ + ada/libgnat/a-elchha.o \ + ada/libgnat/a-except.o \ + ada/libgnat/ada.o \ + ada/libgnat/g-byorma.o \ + ada/libgnat/g-hesora.o \ + ada/libgnat/g-htable.o \ + ada/libgnat/interfac.o \ ada/libgnat/s-addope.o \ ada/libgnat/s-assert.o \ ada/libgnat/s-carun8.o \ - ada/libgnat/s-casuti.o \ ada/libgnat/s-conca2.o \ ada/libgnat/s-conca3.o \ ada/libgnat/s-conca4.o \ @@ -577,20 +678,16 @@ GNATBIND_OBJS = \ ada/libgnat/s-conca8.o \ ada/libgnat/s-conca9.o \ ada/libgnat/s-crc32.o \ - ada/libgnat/s-crtl.o \ ada/libgnat/s-excdeb.o \ ada/libgnat/s-except.o \ ada/libgnat/s-excmac.o \ ada/libgnat/s-exctab.o \ ada/libgnat/s-htable.o \ ada/libgnat/s-imenne.o \ - ada/libgnat/s-imgenu.o \ ada/libgnat/s-imgint.o \ ada/libgnat/s-mastop.o \ ada/libgnat/s-memory.o \ - ada/libgnat/s-os_lib.o \ ada/libgnat/s-parame.o \ - ada/libgnat/s-resfil.o \ ada/libgnat/s-restri.o \ ada/libgnat/s-secsta.o \ ada/libgnat/s-soflin.o \ @@ -607,37 +704,11 @@ GNATBIND_OBJS = \ ada/libgnat/s-traent.o \ ada/libgnat/s-traceb.o \ ada/libgnat/s-unstyp.o \ - ada/libgnat/s-utf_32.o \ ada/libgnat/s-wchcnv.o \ ada/libgnat/s-wchcon.o \ ada/libgnat/s-wchjis.o \ - ada/libgnat/s-wchstw.o \ - ada/scans.o \ - ada/scil_ll.o \ - ada/scng.o \ - ada/sdefault.o \ - ada/seh_init.o \ - ada/sem_aux.o \ - ada/sinfo.o \ - ada/sinput-c.o \ - ada/sinput.o \ - ada/snames.o \ - ada/stand.o \ - ada/stringt.o \ - ada/style.o \ - ada/styleg.o \ - ada/stylesw.o \ - ada/switch-b.o \ - ada/switch.o \ - ada/gcc-interface/system.o \ - ada/table.o \ - ada/targext.o \ - ada/targparm.o \ - ada/types.o \ - ada/uintp.o \ - ada/uname.o \ - ada/urealp.o \ - ada/widechar.o + ada/libgnat/s-wchstw.o +endif # Language-independent object files. ADA_BACKEND = $(BACKEND) attribs.o @@ -671,13 +742,13 @@ ada/libgnat/s-excmac.adb: $(srcdir)/ada/libgnat/s-excmac__$(EH_MECHANISM).adb gnat1$(exeext): $(TARGET_ADA_SRCS) $(GNAT1_OBJS) $(ADA_BACKEND) libcommon-target.a \ $(LIBDEPS) $(ada.prev) @$(call LINK_PROGRESS,$(INDEX.ada),start) - +$(GCC_LLINK) -o $@ $(GNAT1_OBJS) $(ADA_BACKEND) \ - libcommon-target.a $(LIBS) $(SYSLIBS) $(BACKENDLIBS) $(CFLAGS) + +$(GCC_LLINK) -o $@ $(GNAT1_OBJS) $(ADA_BACKEND) $(CFLAGS) \ + libcommon-target.a $(LIBS) $(SYSLIBS) $(BACKENDLIBS) $(GNATLIB) $(RM) stamp-gnatlib2-rts stamp-tools @$(call LINK_PROGRESS,$(INDEX.ada),end) gnatbind$(exeext): ada/b_gnatb.o $(CONFIG_H) $(GNATBIND_OBJS) ggc-none.o libcommon-target.a $(LIBDEPS) - +$(GCC_LINK) -o $@ ada/b_gnatb.o $(GNATBIND_OBJS) ggc-none.o libcommon-target.a $(LIBS) $(SYSLIBS) $(CFLAGS) + +$(GCC_LINK) -o $@ $(CFLAGS) ada/b_gnatb.o $(GNATBIND_OBJS) ggc-none.o libcommon-target.a $(LIBS) $(SYSLIBS) $(GNATLIB) # use target-gcc target-gnatmake target-gnatbind target-gnatlink gnattools: $(GCC_PARTS) $(CONFIG_H) prefix.o force @@ -877,7 +948,7 @@ ada.mostlyclean: -$(RM) ada/*$(objext) ada/*.ali ada/b_gnat*.ads ada/b_gnat*.adb -$(RM) ada/*$(objext).gnatd.n -$(RM) ada/*$(coverageexts) - -$(RM) ada/sdefault.adb ada/stamp-sdefault ada/stamp-snames + -$(RM) ada/stamp-sdefault ada/stamp-snames ada/stamp-gen_il -$(RMDIR) ada/tools -$(RMDIR) ada/libgnat -$(RM) gnatbind$(exeext) gnat1$(exeext) @@ -905,7 +976,6 @@ ada.maintainer-clean: -$(RM) ada/einfo.h -$(RM) ada/nmake.adb -$(RM) ada/nmake.ads - -$(RM) ada/treeprs.ads -$(RM) ada/snames.ads ada/snames.adb ada/snames.h # Stage hooks: @@ -1011,7 +1081,7 @@ $(check_acats_targets): check-acats%: ada/b_gnat1.adb : $(GNAT1_ADA_OBJS) # Old gnatbind do not allow a path for -o. - $(GNATBIND) $(ADA_INCLUDES) -o b_gnat1.adb -n ada/gnat1drv.ali + $(GNATBIND) $(GNATBIND_FLAGS) $(ADA_INCLUDES) -o b_gnat1.adb -n ada/gnat1drv.ali $(MV) b_gnat1.adb b_gnat1.ads ada/ ada/b_gnat1.o : ada/b_gnat1.adb @@ -1020,9 +1090,9 @@ ada/b_gnat1.o : ada/b_gnat1.adb $(CC) -c $(CFLAGS) $(ADA_CFLAGS) -gnatp -gnatws $(ADA_INCLUDES) \ $< $(ADA_OUTPUT_OPTION) -ada/b_gnatb.adb : $(GNATBIND_OBJS) ada/gnatbind.o ada/libgnat/interfac.o +ada/b_gnatb.adb : $(GNATBIND_OBJS) ada/gnatbind.o # Old gnatbind do not allow a path for -o. - $(GNATBIND) $(ADA_INCLUDES) -o b_gnatb.adb ada/gnatbind.ali + $(GNATBIND) $(GNATBIND_FLAGS) $(ADA_INCLUDES) -o b_gnatb.adb ada/gnatbind.ali $(MV) b_gnatb.adb b_gnatb.ads ada/ ada/b_gnatb.o : ada/b_gnatb.adb @@ -1031,11 +1101,6 @@ ada/b_gnatb.o : ada/b_gnatb.adb include $(srcdir)/ada/Make-generated.in -update-sources : ada/treeprs.ads ada/einfo.h ada/sinfo.h ada/nmake.adb \ - ada/nmake.ads - $(RM) $(addprefix $(srcdir)/ada/,$(notdir $^)) - $(CP) $^ $(srcdir)/ada - ada/sdefault.o : ada/libgnat/ada.ads ada/libgnat/a-except.ads ada/libgnat/a-unccon.ads \ ada/libgnat/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads ada/namet.ads \ ada/opt.ads ada/osint.ads ada/output.ads ada/sdefault.ads ada/sdefault.adb \ @@ -1083,7 +1148,7 @@ ada/generated/gnatvsn.ads: ada/gnatvsn.ads BASE-VER ada/GNAT_DATE cat $< | sed -e "/Version/s/(\([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]\).*)/($$d$$s)/g" >$@ ada/gnatvsn.o : ada/gnatvsn.adb ada/generated/gnatvsn.ads - $(CC) -c $(ALL_ADAFLAGS) -Iada/generated -I../ada/generated $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) # Dependencies for windows specific tool (mdll) @@ -1097,13 +1162,30 @@ ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) -ada_generated_files = ada/sinfo.h ada/einfo.h ada/nmake.adb ada/nmake.ads \ - ada/treeprs.ads ada/snames.ads ada/snames.adb ada/snames.h \ - ada/generated/gnatvsn.ads +# All generated files. Perhaps we should build all of these in the same +# subdirectory, and get rid of ada/bldtools. +ADA_GENERATED_FILES = \ + ada/sinfo.h ada/einfo.h ada/nmake.adb ada/nmake.ads \ + ada/snames.ads ada/snames.adb ada/snames.h \ + ada/generated/gnatvsn.ads \ + ada/seinfo.ads ada/seinfo_tables.ads ada/seinfo_tables.adb \ + ada/sinfo-nodes.ads ada/sinfo-nodes.adb \ + ada/einfo-entities.ads ada/einfo-entities.adb \ + ada/gnat.ads ada/g-dynhta.ads ada/g-dynhta.adb \ + ada/g-dyntab.ads ada/g-dyntab.adb ada/g-graphs.ads ada/g-graphs.adb \ + ada/g-lists.ads ada/g-lists.adb ada/g-sets.ads ada/g-sets.adb \ + ada/s-casuti.ads ada/s-casuti.adb \ + ada/s-crtl.ads ada/s-rident.ads ada/s-pehage.ads ada/s-pehage.adb \ + ada/s-os_lib.ads ada/s-os_lib.adb ada/s-resfil.ads ada/s-resfil.adb \ + ada/s-utf_32.ads ada/s-utf_32.adb + +# Only used to manually trigger the creation of the generated files. +.PHONY: +ada_generated_files: $(ADA_GENERATED_FILES) # When building from scratch we don't have dependency files, the only thing # we need to ensure is that the generated files are created first. -$(GNAT1_OBJS) $(GNATBIND_OBJS): | $(ada_generated_files) +$(GNAT1_OBJS) $(GNATBIND_OBJS): | $(ADA_GENERATED_FILES) # Manually include the auto-generated dependencies for the Ada host objects. ADA_DEPFILES = $(foreach obj,$(GNAT1_ADA_OBJS) $(GNATBIND_OBJS),\ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 836fcbe..4ab71977 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -104,7 +104,7 @@ TEXI2DVI = texi2dvi TEXI2PDF = texi2pdf GNATBIND_FLAGS = -static -x ADA_CFLAGS = -ADAFLAGS = -W -Wall -gnatpg -gnata +ADAFLAGS = -W -Wall -gnatpg -gnata -gnatU FORCE_DEBUG_ADAFLAGS = -g NO_INLINE_ADAFLAGS = -fno-inline NO_OMIT_ADAFLAGS = -fno-omit-frame-pointer @@ -250,9 +250,10 @@ LIBS = $(LIBINTL) $(LIBICONV) $(LIBBACKTRACE) $(LIBIBERTY) $(SYSLIBS) LIBDEPS = $(LIBINTL_DEP) $(LIBICONV_DEP) $(LIBBACKTRACE) $(LIBIBERTY) # Default is no TGT_LIB; one might be passed down or something TGT_LIB = -TOOLS_LIBS = ../link.o ../targext.o ../../ggc-none.o ../../libcommon-target.a \ - ../../libcommon.a ../../../libcpp/libcpp.a $(LIBGNAT) $(LIBINTL) $(LIBICONV) \ - ../$(LIBBACKTRACE) ../$(LIBIBERTY) $(SYSLIBS) $(TGT_LIB) +TOOLS_LIBS = ../version.o ../link.o ../targext.o ../../ggc-none.o \ + ../../libcommon-target.a ../../libcommon.a ../../../libcpp/libcpp.a \ + $(LIBGNAT) $(LIBINTL) $(LIBICONV) ../$(LIBBACKTRACE) ../$(LIBIBERTY) \ + $(SYSLIBS) $(TGT_LIB) # Add -no-pie to TOOLS_LIBS since some of them are compiled with -fno-PIE. TOOLS_LIBS += @NO_PIE_FLAG@ @@ -302,7 +303,7 @@ ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir)/ada $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) # how to regenerate this file -Makefile: ../config.status $(srcdir)/ada/gcc-interface/Makefile.in $(srcdir)/ada/Makefile.in $(srcdir)/version.c +Makefile: ../config.status $(srcdir)/ada/gcc-interface/Makefile.in $(srcdir)/ada/Makefile.in $(srcdir)/ada/version.c cd ..; \ LANGUAGES="$(CONFIG_LANGUAGES)" \ CONFIG_HEADERS= \ @@ -332,6 +333,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o aspects.o s-casuti.o alloc.o \ snames.o stand.o stringt.o styleg.o stylesw.o system.o validsw.o \ switch.o switch-m.o table.o targparm.o tempdir.o types.o uintp.o \ uname.o urealp.o usage.o widechar.o \ + seinfo.o einfo-entities.o einfo-utils.o sinfo-nodes.o sinfo-utils.o \ $(EXTRA_GNATMAKE_OBJS) # Make arch match the current multilib so that the RTS selection code @@ -383,15 +385,20 @@ TOOLS_FLAGS_TO_PASS= \ GCC_LINK=$(CXX) $(GCC_LINK_FLAGS) $(LDFLAGS) -# Build directory for the tools. Let's copy the target-dependent -# sources using the same mechanism as for gnatlib. The other sources are -# accessed using the vpath directive below +# Build directory for the tools. We first need to copy the generated files, +# then the target-dependent sources using the same mechanism as for gnatlib. +# The other sources are accessed using the vpath directive below + +GENERATED_FILES_FOR_TOOLS = \ + einfo-entities.ads einfo-entities.adb sdefault.adb seinfo.ads \ + sinfo-nodes.ads sinfo-nodes.adb snames.ads snames.adb ../stamp-tools: -$(RM) tools/* -$(RMDIR) tools -$(MKDIR) tools - -(cd tools; $(LN_S) ../sdefault.adb ../snames.ads ../snames.adb .) + -(cd tools; $(foreach FILE,$(GENERATED_FILES_FOR_TOOLS), \ + $(LN_S) ../$(FILE) $(FILE);)) -$(foreach PAIR,$(TOOLS_TARGET_PAIRS), \ $(RM) tools/$(word 1,$(subst <, ,$(PAIR)));\ $(LN_S) $(fsrcpfx)ada/$(word 2,$(subst <, ,$(PAIR))) \ diff --git a/gcc/ada/gcc-interface/a-assert.adb b/gcc/ada/gcc-interface/a-assert.adb new file mode 100644 index 0000000..429b14b --- /dev/null +++ b/gcc/ada/gcc-interface/a-assert.adb @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . A S S E R T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2021, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Assertions is + + ------------ + -- Assert -- + ------------ + + procedure Assert (Check : Boolean) is + begin + if Check = False then + raise Ada.Assertions.Assertion_Error; + end if; + end Assert; + + procedure Assert (Check : Boolean; Message : String) is + begin + if Check = False then + raise Ada.Assertions.Assertion_Error with Message; + end if; + end Assert; + +end Ada.Assertions; diff --git a/gcc/ada/gcc-interface/a-assert.ads b/gcc/ada/gcc-interface/a-assert.ads new file mode 100644 index 0000000..55ed806 --- /dev/null +++ b/gcc/ada/gcc-interface/a-assert.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . A S S E R T I O N S -- +-- -- +-- Copyright (C) 2015-2021, Free Software Foundation, Inc. -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contracts that have been added. -- +-- -- +-- 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is used to bootstrap the compiler only. +-- It can be removed when we switch to using a GNAT from 2014 or later. + +pragma Compiler_Unit_Warning; + +package Ada.Assertions is + pragma Pure; + + Assertion_Error : exception; + + procedure Assert (Check : Boolean); + + procedure Assert (Check : Boolean; Message : String); + +end Ada.Assertions; diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h index 461fa2b..9fe52cf 100644 --- a/gcc/ada/gcc-interface/ada-tree.h +++ b/gcc/ada/gcc-interface/ada-tree.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * @@ -580,6 +580,6 @@ do { \ #define EXIT_STMT_LABEL(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXIT_STMT, 1) /* Small kludge to be able to define Ada built-in functions locally. - We overload them on top of the HSAIL/BRIG builtin functions. */ -#define BUILT_IN_LIKELY BUILT_IN_HSAIL_WORKITEMABSID -#define BUILT_IN_UNLIKELY BUILT_IN_HSAIL_GRIDSIZE + We overload them on top of the C++ coroutines builtin functions. */ +#define BUILT_IN_LIKELY BUILT_IN_CORO_PROMISE +#define BUILT_IN_UNLIKELY BUILT_IN_CORO_RESUME diff --git a/gcc/ada/gcc-interface/ada.h b/gcc/ada/gcc-interface/ada.h index c5a1916..242a14e 100644 --- a/gcc/ada/gcc-interface/ada.h +++ b/gcc/ada/gcc-interface/ada.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * diff --git a/gcc/ada/gcc-interface/cuintp.c b/gcc/ada/gcc-interface/cuintp.c index dada72a..6ac82d7 100644 --- a/gcc/ada/gcc-interface/cuintp.c +++ b/gcc/ada/gcc-interface/cuintp.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * @@ -49,8 +49,7 @@ For efficiency, this method is used only for integer values larger than the constant Uint_Bias. If a Uint is less than this constant, then it contains - the integer value itself. The origin of the Uints_Ptr table is adjusted so - that a Uint value of Uint_Bias indexes the first element. + the integer value itself. First define a utility function that is build_int_cst for integral types and does a conversion for floating-point types. */ @@ -85,9 +84,9 @@ UI_To_gnu (Uint Input, tree type) gnu_ret = build_cst_from_int (comp_type, Input - Uint_Direct_Bias); else { - Int Idx = Uints_Ptr[Input].Loc; - Pos Length = Uints_Ptr[Input].Length; - Int First = Udigits_Ptr[Idx]; + Int Idx = (*Uints_Ptr)[Input - Uint_Table_Start].Loc; + Pos Length = (*Uints_Ptr)[Input - Uint_Table_Start].Length; + Int First = (*Udigits_Ptr)[Idx]; tree gnu_base; gcc_assert (Length > 0); @@ -109,14 +108,14 @@ UI_To_gnu (Uint Input, tree type) fold_build2 (MULT_EXPR, comp_type, gnu_ret, gnu_base), build_cst_from_int (comp_type, - Udigits_Ptr[Idx])); + (*Udigits_Ptr)[Idx])); else for (Idx++, Length--; Length; Idx++, Length--) gnu_ret = fold_build2 (PLUS_EXPR, comp_type, fold_build2 (MULT_EXPR, comp_type, gnu_ret, gnu_base), build_cst_from_int (comp_type, - Udigits_Ptr[Idx])); + (*Udigits_Ptr)[Idx])); } gnu_ret = convert (type, gnu_ret); diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 27ef51a..5cedb74 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * @@ -217,7 +217,8 @@ static void set_reverse_storage_order_on_array_type (tree); static bool same_discriminant_p (Entity_Id, Entity_Id); static bool array_type_has_nonaliased_component (tree, Entity_Id); static bool compile_time_known_address_p (Node_Id); -static bool cannot_be_superflat (Node_Id); +static bool flb_cannot_be_superflat (Node_Id); +static bool range_cannot_be_superflat (Node_Id); static bool constructor_address_p (tree); static bool allocatable_size_p (tree, bool); static bool initial_value_needs_conversion (tree, tree); @@ -434,7 +435,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gcc_assert (!is_type || Known_Esize (gnat_entity) || Has_Size_Clause (gnat_entity) - || (!IN (kind, Numeric_Kind) + || (!Is_In_Numeric_Kind (kind) && !IN (kind, Enumeration_Kind) && (!IN (kind, Access_Kind) || kind == E_Access_Protected_Subprogram_Type @@ -443,8 +444,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) || type_annotate_only))); /* The RM size must be specified for all discrete and fixed-point types. */ - gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind) - && Unknown_RM_Size (gnat_entity))); + gcc_assert (!(Is_In_Discrete_Or_Fixed_Point_Kind (kind) + && !Known_RM_Size (gnat_entity))); /* If we get here, it means we have not yet done anything with this entity. If we are not defining it, it must be a type or an entity that is defined @@ -622,7 +623,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type, gnu_expr, true, Is_Public (gnat_entity), false, false, false, artificial_p, - debug_info_p, NULL, gnat_entity, true); + debug_info_p, NULL, gnat_entity); } break; @@ -736,16 +737,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (foreign && Is_Descendant_Of_Address (Underlying_Type (gnat_type))) gnu_type = ptr_type_node; else - { - gnu_type = gnat_to_gnu_type (gnat_type); - - /* If this is a standard exception definition, use the standard - exception type. This is necessary to make sure that imported - and exported views of exceptions are merged in LTO mode. */ - if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL - && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id) - gnu_type = except_type_node; - } + gnu_type = gnat_to_gnu_type (gnat_type); /* For a debug renaming declaration, build a debug-only entity. */ if (Present (Debug_Renaming_Link (gnat_entity))) @@ -1352,7 +1344,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) || (gnu_size && !allocatable_size_p (convert (sizetype, size_binop - (CEIL_DIV_EXPR, gnu_size, + (EXACT_DIV_EXPR, gnu_size, bitsize_unit_node)), global_bindings_p () || !definition @@ -1401,7 +1393,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_alloc_type))) - post_error ("?`Storage_Error` will be raised at run time!", + post_error ("??`Storage_Error` will be raised at run time!", gnat_entity); gnu_expr @@ -1536,7 +1528,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) imported_p || !definition, static_flag, volatile_flag, artificial_p, debug_info_p && definition, attr_list, - gnat_entity, true); + gnat_entity); DECL_BY_REF_P (gnu_decl) = used_by_ref; DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag; DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity); @@ -2006,7 +1998,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) so we use an intermediate step for standard DWARF. */ if (debug_info_p) { - if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + if (gnat_encodings != DWARF_GNAT_ENCODINGS_ALL) SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type); else if (DECL_PARALLEL_TYPE (t)) add_parallel_type (gnu_type, DECL_PARALLEL_TYPE (t)); @@ -2109,6 +2101,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) case E_Array_Type: { + const Entity_Id PAT = Packed_Array_Impl_Type (gnat_entity); const bool convention_fortran_p = (Convention (gnat_entity) == Convention_Fortran); const int ndim = Number_Dimensions (gnat_entity); @@ -2212,16 +2205,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } /* If the GNAT encodings are used, give the fat pointer type a name. - If this is a packed array, tell the debugger how to interpret the - underlying bits by fetching that of the implementation type. But - in any case, mark it as artificial so the debugger can skip it. */ + If this is a packed type implemented specially, tell the debugger + how to interpret the underlying bits by fetching the name of the + implementation type. But, in any case, mark it as artificial so + the debugger can skip it. */ const Entity_Id gnat_name - = (Present (Packed_Array_Impl_Type (gnat_entity)) - && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) - ? Packed_Array_Impl_Type (gnat_entity) + = Present (PAT) && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL + ? PAT : gnat_entity; tree xup_name - = (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + = gnat_encodings == DWARF_GNAT_ENCODINGS_ALL ? create_concat_name (gnat_name, "XUP") : gnu_entity_name; create_type_decl (xup_name, gnu_fat_type, true, debug_info_p, @@ -2246,13 +2239,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) index += (convention_fortran_p ? - 1 : 1), gnat_index = Next_Index (gnat_index)) { - char field_name[16]; + const bool is_flb + = Is_Fixed_Lower_Bound_Index_Subtype (Etype (gnat_index)); tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type); tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type); tree gnu_index_base_type = get_base_type (gnu_index_type); tree gnu_lb_field, gnu_hb_field; tree gnu_min, gnu_max, gnu_high; + char field_name[16]; /* Update the maximum size of the array in elements. */ if (gnu_max_size) @@ -2286,25 +2281,38 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* We can't use build_component_ref here since the template type isn't complete yet. */ - gnu_orig_min = build3 (COMPONENT_REF, TREE_TYPE (gnu_lb_field), - gnu_template_reference, gnu_lb_field, - NULL_TREE); + if (!is_flb) + { + gnu_orig_min = build3 (COMPONENT_REF, TREE_TYPE (gnu_lb_field), + gnu_template_reference, gnu_lb_field, + NULL_TREE); + TREE_READONLY (gnu_orig_min) = 1; + } + gnu_orig_max = build3 (COMPONENT_REF, TREE_TYPE (gnu_hb_field), gnu_template_reference, gnu_hb_field, NULL_TREE); - TREE_READONLY (gnu_orig_min) = TREE_READONLY (gnu_orig_max) = 1; + TREE_READONLY (gnu_orig_max) = 1; gnu_min = convert (sizetype, gnu_orig_min); gnu_max = convert (sizetype, gnu_orig_max); /* Compute the size of this dimension. See the E_Array_Subtype case below for the rationale. */ - gnu_high - = build3 (COND_EXPR, sizetype, - build2 (GE_EXPR, boolean_type_node, - gnu_orig_max, gnu_orig_min), - gnu_max, - size_binop (MINUS_EXPR, gnu_min, size_one_node)); + if (is_flb + && Nkind (gnat_index) == N_Subtype_Indication + && flb_cannot_be_superflat (gnat_index)) + gnu_high = gnu_max; + + else + gnu_high + = build3 (COND_EXPR, sizetype, + build2 (GE_EXPR, boolean_type_node, + gnu_orig_max, gnu_orig_min), + gnu_max, + TREE_CODE (gnu_min) == INTEGER_CST + ? int_const_binop (MINUS_EXPR, gnu_min, size_one_node) + : size_binop (MINUS_EXPR, gnu_min, size_one_node)); /* Make a range type with the new range in the Ada base type. Then make an index type with the size range in sizetype. */ @@ -2332,7 +2340,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If Component_Size is not already specified, annotate it with the size of the component. */ - if (Unknown_Component_Size (gnat_entity)) + if (!Known_Component_Size (gnat_entity)) Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (comp_type))); @@ -2354,11 +2362,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) set_nonaliased_component_on_array_type (tem); } - /* If an alignment is specified, use it if valid. But ignore it - for the original type of packed array types. If the alignment - was requested with an explicit alignment clause, state so. */ - if (No (Packed_Array_Impl_Type (gnat_entity)) - && Known_Alignment (gnat_entity)) + /* If this is a packed type implemented specially, then process the + implementation type so it is elaborated in the proper scope. */ + if (Present (PAT)) + gnat_to_gnu_entity (PAT, NULL_TREE, false); + + /* Otherwise, if an alignment is specified, use it if valid and, if + the alignment was requested with an explicit clause, state so. */ + else if (Known_Alignment (gnat_entity)) { SET_TYPE_ALIGN (tem, validate_alignment (Alignment (gnat_entity), @@ -2379,8 +2390,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) tem = change_qualified_type (tem, TYPE_QUAL_VOLATILE); /* Adjust the type of the pointer-to-array field of the fat pointer - and record the aliasing relationships if necessary. */ - TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); + and record the aliasing relationships if necessary. If this is + a packed type implemented specially, then use a ref-all pointer + type since the implementation type may vary between constrained + subtypes and unconstrained base type. */ + if (Present (PAT)) + TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) + = build_pointer_type_for_mode (tem, ptr_mode, true); + else + TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type)) record_component_aliases (gnu_fat_type); @@ -2402,11 +2420,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) template at a negative offset, but this was somewhat of a kludge; we now shift thin pointer values explicitly but only those which have a TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE. - Note that GDB can handle standard DWARF information for them, so we - don't have to name them as a GNAT encoding, except if specifically - asked to. */ + If the GNAT encodings are used, give it a name. */ tree xut_name - = (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + = (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL) ? create_concat_name (gnat_name, "XUT") : gnu_entity_name; obj = build_unc_object_type (gnu_template_type, tem, xut_name, @@ -2444,6 +2460,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ; else { + const Entity_Id PAT = Packed_Array_Impl_Type (gnat_entity); Entity_Id gnat_index, gnat_base_index; const bool convention_fortran_p = (Convention (gnat_entity) == Convention_Fortran); @@ -2592,7 +2609,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) this. If we can prove that the array can never be superflat, we can just use the high bound of the index type. */ else if ((Nkind (gnat_index) == N_Range - && cannot_be_superflat (gnat_index)) + && range_cannot_be_superflat (gnat_index)) /* Bit-Packed Array Impl. Types are never superflat. */ || (Is_Packed_Array_Impl_Type (gnat_entity) && Is_Bit_Packed_Array @@ -2654,7 +2671,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && TREE_CODE (TREE_TYPE (gnu_index_type)) != INTEGER_TYPE) || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)) - && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL) need_index_type_struct = true; } @@ -2831,7 +2848,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_entity_name = gnu_name; } - else if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + else if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL) { tree gnu_base_decl = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, @@ -2849,7 +2866,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If this is a packed type implemented specially, then replace our type with the implementation type. */ - if (Present (Packed_Array_Impl_Type (gnat_entity))) + if (Present (PAT)) { /* First finish the type we had been making so that we output debugging information for it. */ @@ -2874,12 +2891,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) this type again. */ save_gnu_tree (gnat_entity, gnu_tmp_decl, false); - gnu_type - = gnat_to_gnu_type (Packed_Array_Impl_Type (gnat_entity)); + gnu_type = gnat_to_gnu_type (PAT); save_gnu_tree (gnat_entity, NULL_TREE, false); /* Set the ___XP suffix for GNAT encodings. */ - if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL) gnu_entity_name = DECL_NAME (TYPE_NAME (gnu_type)); tree gnu_inner = gnu_type; @@ -3354,14 +3370,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = build_subst_list (gnat_entity, gnat_parent_type, definition); /* Set the layout of the type to match that of the parent type, - doing required substitutions. If we are in minimal GNAT - encodings mode, we don't need debug info for the inner record + doing required substitutions. Note that, if we do not use the + GNAT encodings, we don't need debug info for the inner record types, as they will be part of the embedding variant record's debug info. */ copy_and_substitute_in_layout (gnat_entity, gnat_parent_type, gnu_type, gnu_parent_type, gnu_subst_list, - debug_info_p && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL); + debug_info_p && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL); } else { @@ -3404,21 +3420,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Fill in locations of fields. */ annotate_rep (gnat_entity, gnu_type); - - /* If this is a record type associated with an exception definition, - equate its fields to those of the standard exception type. This - will make it possible to convert between them. */ - if (gnu_entity_name == exception_data_name_id) - { - tree gnu_std_field; - for (gnu_field = TYPE_FIELDS (gnu_type), - gnu_std_field = TYPE_FIELDS (except_type_node); - gnu_field; - gnu_field = DECL_CHAIN (gnu_field), - gnu_std_field = DECL_CHAIN (gnu_std_field)) - SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field); - gcc_assert (!gnu_std_field); - } } break; @@ -3515,11 +3516,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) annotate_rep (gnat_entity, gnu_type); /* If debugging information is being written for the type and if - we are asked to output such encodings, write a record that + we are asked to output GNAT encodings, write a record that shows what we are a subtype of and also make a variable that indicates our size, if still variable. */ if (debug_info_p - && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL) { tree gnu_subtype_marker = make_node (RECORD_TYPE); tree gnu_unpad_base_name @@ -3546,16 +3547,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = create_var_decl (create_concat_name (gnat_entity, "XVZ"), NULL_TREE, sizetype, gnu_size_unit, - false, false, false, false, false, - true, debug_info_p, - NULL, gnat_entity); + true, false, false, false, false, + true, true, NULL, gnat_entity, false); } - /* Or else, if the subtype is artificial and encodings are not - used, use the base record type as the debug type. */ + /* Or else, if the subtype is artificial and GNAT encodings are + not used, use the base record type as the debug type. */ else if (debug_info_p && artificial_p - && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + && gnat_encodings != DWARF_GNAT_ENCODINGS_ALL) SET_TYPE_DEBUG_TYPE (gnu_type, gnu_unpad_base_type); } @@ -4348,7 +4348,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ratio is greater or equal to the byte/bit ratio. */ if (tree_fits_uhwi_p (size) && align >= tree_to_uhwi (size) * BITS_PER_UNIT) - post_error_ne ("?suspiciously large alignment specified for&", + post_error_ne ("??suspiciously large alignment specified for&", Expression (Alignment_Clause (gnat_entity)), gnat_entity); } @@ -4383,7 +4383,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity); /* Back-annotate the alignment of the type if not already set. */ - if (Unknown_Alignment (gnat_entity)) + if (!Known_Alignment (gnat_entity)) { unsigned int double_align, align; bool is_capped_double, align_clause; @@ -4409,7 +4409,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } /* Likewise for the size, if any. */ - if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type)) + if (!Known_Esize (gnat_entity) && TYPE_SIZE (gnu_type)) { tree gnu_size = TYPE_SIZE (gnu_type); @@ -4431,9 +4431,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) const bool derived_p = Is_Derived_Type (gnat_entity); const Entity_Id gnat_parent = derived_p ? Etype (Base_Type (gnat_entity)) : Empty; + /* The following test for Known_Alignment preserves the old behavior, + but is probably wrong. */ const unsigned int inherited_align = derived_p - ? UI_To_Int (Alignment (gnat_parent)) * BITS_PER_UNIT + ? (Known_Alignment (gnat_parent) + ? UI_To_Int (Alignment (gnat_parent)) * BITS_PER_UNIT + : 0) : POINTER_SIZE; const unsigned int align = MAX (TYPE_ALIGN (gnu_type), inherited_align); @@ -4442,7 +4446,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If there is neither size clause nor representation clause, the sizes need to be adjusted. */ - if (Unknown_RM_Size (gnat_entity) + if (!Known_RM_Size (gnat_entity) && !VOID_TYPE_P (gnu_type) && (!TYPE_FIELDS (gnu_type) || integer_zerop (bit_position (TYPE_FIELDS (gnu_type))))) @@ -4462,7 +4466,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) Set_Esize (gnat_entity, annotate_value (gnu_size)); /* Tagged types are Strict_Alignment so RM_Size = Esize. */ - if (Unknown_RM_Size (gnat_entity)) + if (!Known_RM_Size (gnat_entity)) Set_RM_Size (gnat_entity, Esize (gnat_entity)); } @@ -4472,24 +4476,23 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } /* Likewise for the RM size, if any. */ - if (Unknown_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type)) + if (!Known_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type)) Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type))); - /* If we are at global level, GCC will have applied variable_size to - the type, but that won't have done anything. So, if it's not - a constant or self-referential, call elaborate_expression_1 to - make a variable for the size rather than calculating it each time. - Handle both the RM size and the actual size. */ + /* If we are at global level, GCC applied variable_size to the size but + this has done nothing. So, if it's not constant or self-referential, + call elaborate_expression_1 to make a variable for it rather than + calculating it each time. */ if (TYPE_SIZE (gnu_type) && !TREE_CONSTANT (TYPE_SIZE (gnu_type)) && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) && global_bindings_p ()) { - tree size = TYPE_SIZE (gnu_type); + tree orig_size = TYPE_SIZE (gnu_type); TYPE_SIZE (gnu_type) - = elaborate_expression_1 (size, gnat_entity, "SIZE", definition, - false); + = elaborate_expression_1 (TYPE_SIZE (gnu_type), gnat_entity, + "SIZE", definition, false); /* ??? For now, store the size as a multiple of the alignment in bytes so that we can see the alignment from the tree. */ @@ -4502,7 +4505,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) may not be marked by the call to create_type_decl below. */ MARK_VISITED (TYPE_SIZE_UNIT (gnu_type)); - if (TREE_CODE (gnu_type) == RECORD_TYPE) + /* For a record type, deal with the variant part, if any, and handle + the Ada size as well. */ + if (RECORD_OR_UNION_TYPE_P (gnu_type)) { tree variant_part = get_variant_part (gnu_type); tree ada_size = TYPE_ADA_SIZE (gnu_type); @@ -4555,7 +4560,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) DECL_SIZE_UNIT (variant_part) = TYPE_SIZE_UNIT (union_type); } - if (operand_equal_p (ada_size, size, 0)) + if (operand_equal_p (ada_size, orig_size, 0)) ada_size = TYPE_SIZE (gnu_type); else ada_size @@ -4568,7 +4573,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Similarly, if this is a record type or subtype at global level, call elaborate_expression_2 on any field position. Skip any fields that we haven't made trees for to avoid problems with class-wide types. */ - if (IN (kind, Record_Kind) && global_bindings_p ()) + if (Is_In_Record_Kind (kind) && global_bindings_p ()) for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp)) if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp)) @@ -4736,11 +4741,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)) && Present (gnat_annotate_type)) { - if (Unknown_Alignment (gnat_entity)) - Set_Alignment (gnat_entity, Alignment (gnat_annotate_type)); - if (Unknown_Esize (gnat_entity)) + if (!Known_Alignment (gnat_entity)) + Copy_Alignment (gnat_entity, gnat_annotate_type); + if (!Known_Esize (gnat_entity)) Set_Esize (gnat_entity, Esize (gnat_annotate_type)); - if (Unknown_RM_Size (gnat_entity)) + if (!Known_RM_Size (gnat_entity)) Set_RM_Size (gnat_entity, RM_Size (gnat_annotate_type)); } @@ -5463,7 +5468,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, input_location = saved_location; if (mech == By_Copy && (by_ref || by_component_ptr)) - post_error ("?cannot pass & by copy", gnat_param); + post_error ("??cannot pass & by copy", gnat_param); /* If this is an Out parameter that isn't passed by reference and whose type doesn't require the initialization of formals, we don't make a @@ -5761,16 +5766,16 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, tree gnu_cico_return_type = NULL_TREE; tree gnu_cico_field_list = NULL_TREE; bool gnu_cico_only_integral_type = true; - /* The semantics of "pure" in Ada essentially matches that of "const" - or "pure" in GCC. In particular, both properties are orthogonal - to the "nothrow" property if the EH circuitry is explicit in the - internal representation of the middle-end. If we are to completely - hide the EH circuitry from it, we need to declare that calls to pure - Ada subprograms that can throw have side effects since they can - trigger an "abnormal" transfer of control flow; therefore, they can - be neither "const" nor "pure" in the GCC sense. */ - bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_subprog)); - bool pure_flag = false; + /* Although the semantics of "pure" units in Ada essentially match those of + "const" in GNU C, the semantics of the Is_Pure flag in GNAT do not say + anything about access to global memory, that's why it needs to be mapped + to "pure" instead of "const" in GNU C. The property is orthogonal to the + "nothrow" property only if the EH circuitry is explicit in the internal + representation of the middle-end: if we are to completely hide the EH + circuitry from it, we need to declare that calls to pure Ada subprograms + that can throw have side effects, since they can trigger an "abnormal" + transfer of control; therefore they cannot be "pure" in the GCC sense. */ + bool pure_flag = Is_Pure (gnat_subprog) && Back_End_Exceptions (); bool return_by_direct_ref_p = false; bool return_by_invisi_ref_p = false; bool return_unconstrained_p = false; @@ -5923,14 +5928,14 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, } /* A procedure (something that doesn't return anything) shouldn't be - considered const since there would be no reason for calling such a + considered pure since there would be no reason for calling such a subprogram. Note that procedures with Out (or In Out) parameters have already been converted into a function with a return type. Similarly, if the function returns an unconstrained type, then the function will allocate the return value on the secondary stack and thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */ if (VOID_TYPE_P (gnu_return_type) || return_unconstrained_p) - const_flag = false; + pure_flag = false; /* Loop over the parameters and get their associated GCC tree. While doing this, build a copy-in copy-out structure if we need one. */ @@ -6058,18 +6063,16 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, save_gnu_tree (gnat_param, gnu_param, false); /* A pure function in the Ada sense which takes an access parameter - may modify memory through it and thus need be considered neither - const nor pure in the GCC sense. Likewise it if takes a by-ref - In Out or Out parameter. But if it takes a by-ref In parameter, - then it may only read memory through it and can be considered - pure in the GCC sense. */ - if ((const_flag || pure_flag) - && (POINTER_TYPE_P (gnu_param_type) + may modify memory through it and thus cannot be considered pure + in the GCC sense, unless it's access-to-function. Likewise it if + takes a by-ref In Out or Out parameter. But if it takes a by-ref + In parameter, then it may only read memory through it and can be + considered pure in the GCC sense. */ + if (pure_flag + && ((POINTER_TYPE_P (gnu_param_type) + && TREE_CODE (TREE_TYPE (gnu_param_type)) != FUNCTION_TYPE) || TYPE_IS_FAT_POINTER_P (gnu_param_type))) - { - const_flag = false; - pure_flag = DECL_POINTS_TO_READONLY_P (gnu_param); - } + pure_flag = DECL_POINTS_TO_READONLY_P (gnu_param); } /* If the parameter uses the copy-in copy-out mechanism, allocate a field @@ -6269,9 +6272,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, } } - if (const_flag) - gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST); - if (pure_flag) gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_RESTRICT); @@ -6296,7 +6296,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, if (!intrin_profiles_compatible_p (&inb)) post_error - ("?profile of& doesn''t match the builtin it binds!", + ("??profile of& doesn''t match the builtin it binds!", gnat_subprog); return gnu_builtin_decl; @@ -6309,7 +6309,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, on demand without risking false positives with common default sets of options. */ if (warn_shadow) - post_error ("?gcc intrinsic not found for&!", gnat_subprog); + post_error ("??gcc intrinsic not found for&!", gnat_subprog); } } @@ -6428,33 +6428,81 @@ compile_time_known_address_p (Node_Id gnat_address) return Compile_Time_Known_Value (gnat_address); } +/* Return true if GNAT_INDIC, a N_Subtype_Indication node for the index of a + FLB, cannot yield superflat objects, i.e. if the inequality HB >= LB - 1 + is true for these objects. LB and HB are the low and high bounds. */ + +static bool +flb_cannot_be_superflat (Node_Id gnat_indic) +{ + const Entity_Id gnat_type = Entity (Subtype_Mark (gnat_indic)); + const Entity_Id gnat_subtype = Etype (gnat_indic); + Node_Id gnat_scalar_range, gnat_lb, gnat_hb; + tree gnu_lb, gnu_hb, gnu_lb_minus_one; + + /* This is a FLB so LB is fixed. */ + if ((Ekind (gnat_subtype) == E_Signed_Integer_Subtype + || Ekind (gnat_subtype) == E_Modular_Integer_Subtype) + && (gnat_scalar_range = Scalar_Range (gnat_subtype))) + { + gnat_lb = Low_Bound (gnat_scalar_range); + gcc_assert (Nkind (gnat_lb) == N_Integer_Literal); + } + else + return false; + + /* The low bound of the type is a lower bound for HB. */ + if ((Ekind (gnat_type) == E_Signed_Integer_Subtype + || Ekind (gnat_type) == E_Modular_Integer_Subtype) + && (gnat_scalar_range = Scalar_Range (gnat_type))) + { + gnat_hb = Low_Bound (gnat_scalar_range); + gcc_assert (Nkind (gnat_hb) == N_Integer_Literal); + } + else + return false; + + /* We need at least a signed 64-bit type to catch most cases. */ + gnu_lb = UI_To_gnu (Intval (gnat_lb), sbitsizetype); + gnu_hb = UI_To_gnu (Intval (gnat_hb), sbitsizetype); + if (TREE_OVERFLOW (gnu_lb) || TREE_OVERFLOW (gnu_hb)) + return false; + + /* If the low bound is the smallest integer, nothing can be smaller. */ + gnu_lb_minus_one = size_binop (MINUS_EXPR, gnu_lb, sbitsize_one_node); + if (TREE_OVERFLOW (gnu_lb_minus_one)) + return true; + + return !tree_int_cst_lt (gnu_hb, gnu_lb_minus_one); +} + /* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e. if the - inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */ + inequality HB >= LB - 1 is true. LB and HB are the low and high bounds. */ static bool -cannot_be_superflat (Node_Id gnat_range) +range_cannot_be_superflat (Node_Id gnat_range) { Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range); - Node_Id scalar_range; + Node_Id gnat_scalar_range; tree gnu_lb, gnu_hb, gnu_lb_minus_one; /* If the low bound is not constant, try to find an upper bound. */ while (Nkind (gnat_lb) != N_Integer_Literal && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype) - && (scalar_range = Scalar_Range (Etype (gnat_lb))) - && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition - || Nkind (scalar_range) == N_Range)) - gnat_lb = High_Bound (scalar_range); + && (gnat_scalar_range = Scalar_Range (Etype (gnat_lb))) + && (Nkind (gnat_scalar_range) == N_Signed_Integer_Type_Definition + || Nkind (gnat_scalar_range) == N_Range)) + gnat_lb = High_Bound (gnat_scalar_range); /* If the high bound is not constant, try to find a lower bound. */ while (Nkind (gnat_hb) != N_Integer_Literal && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype) - && (scalar_range = Scalar_Range (Etype (gnat_hb))) - && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition - || Nkind (scalar_range) == N_Range)) - gnat_hb = Low_Bound (scalar_range); + && (gnat_scalar_range = Scalar_Range (Etype (gnat_hb))) + && (Nkind (gnat_scalar_range) == N_Signed_Integer_Type_Definition + || Nkind (gnat_scalar_range) == N_Range)) + gnat_hb = Low_Bound (gnat_scalar_range); /* If we have failed to find constant bounds, punt. */ if (Nkind (gnat_lb) != N_Integer_Literal @@ -6749,12 +6797,12 @@ prepend_attributes (struct attrib **attr_list, Entity_Id gnat_entity) if a variable needs to be created and DEFINITION is true if this is done for a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result; otherwise, we are just elaborating the expression for side-effects. If - NEED_DEBUG is true, we need a variable for debugging purposes even if it - isn't needed for code generation. */ + NEED_FOR_DEBUG is true, we need a variable for debugging purposes even + if it isn't needed for code generation. */ static tree elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s, - bool definition, bool need_value, bool need_debug) + bool definition, bool need_value, bool need_for_debug) { tree gnu_expr; @@ -6772,12 +6820,12 @@ elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s, return NULL_TREE; /* If it's a static expression, we don't need a variable for debugging. */ - if (need_debug && Compile_Time_Known_Value (gnat_expr)) - need_debug = false; + if (need_for_debug && Compile_Time_Known_Value (gnat_expr)) + need_for_debug = false; /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */ gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity, s, - definition, need_debug); + definition, need_for_debug); /* Save the expression in case we try to elaborate this entity again. Since it's not a DECL, don't check it. Don't save if it's a discriminant. */ @@ -6791,7 +6839,7 @@ elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s, static tree elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s, - bool definition, bool need_debug) + bool definition, bool need_for_debug) { const bool expr_public_p = Is_Public (gnat_entity); const bool expr_global_p = expr_public_p || global_bindings_p (); @@ -6839,38 +6887,42 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s, /* If the GNAT encodings are not used, we don't need a variable for debug info purposes if the expression is a constant or another variable, but - we need to be careful because we do not generate debug info for external + we must be careful because we do not generate debug info for external variables so DECL_IGNORED_P is not stable across units. */ - if (need_debug - && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL + if (need_for_debug + && gnat_encodings != DWARF_GNAT_ENCODINGS_ALL && (TREE_CONSTANT (gnu_expr) || (!expr_public_p && DECL_P (gnu_expr) && !DECL_IGNORED_P (gnu_expr)))) - need_debug = false; + need_for_debug = false; /* Now create it, possibly only for debugging purposes. */ - if (use_variable || need_debug) + if (use_variable || need_for_debug) { /* The following variable creation can happen when processing the body - of subprograms that are defined out of the extended main unit and + of subprograms that are defined outside of the extended main unit and inlined. In this case, we are not at the global scope, and thus the new variable must not be tagged "external", as we used to do here as - soon as DEFINITION was false. */ + soon as DEFINITION was false. And note that we test Needs_Debug_Info + here instead of NEED_FOR_DEBUG because, once the variable is created, + whether or not debug information is generated for it is orthogonal to + the reason why it was created in the first place. */ tree gnu_decl = create_var_decl (create_concat_name (gnat_entity, s), NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true, expr_public_p, !definition && expr_global_p, - expr_global_p, false, true, need_debug, - NULL, gnat_entity); + expr_global_p, false, true, + Needs_Debug_Info (gnat_entity), + NULL, gnat_entity, false); - /* Using this variable at debug time (if need_debug is true) requires a - proper location. The back-end will compute a location for this + /* Using this variable for debug (if need_for_debug is true) requires + a proper location. The back-end will compute a location for this variable only if the variable is used by the generated code. Returning the variable ensures the caller will use it in generated code. Note that there is no need for a location if the debug info contains an integer constant. */ - if (use_variable || (need_debug && !TREE_CONSTANT (gnu_expr))) + if (use_variable || (need_for_debug && !TREE_CONSTANT (gnu_expr))) return gnu_decl; } @@ -6881,7 +6933,7 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s, static tree elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, const char *s, - bool definition, bool need_debug, unsigned int align) + bool definition, bool need_for_debug, unsigned int align) { tree unit_align = size_int (align / BITS_PER_UNIT); return @@ -6890,7 +6942,7 @@ elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, const char *s, gnu_expr, unit_align), gnat_entity, s, definition, - need_debug), + need_for_debug), unit_align); } @@ -7125,6 +7177,14 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, tree gnu_field, gnu_size, gnu_pos; bool is_bitfield; + /* Force the type of the Not_Handled_By_Others field to be that of the + field in struct Exception_Data declared in raise.h instead of using + the declared boolean type. We need to do that because there is no + easy way to make use of a C compatible boolean type for the latter. */ + if (gnu_field_id == not_handled_by_others_name_id + && gnu_field_type == boolean_type_node) + gnu_field_type = char_type_node; + /* The qualifier to be used in messages. */ if (is_aliased) field_s = "aliased&"; @@ -7614,20 +7674,20 @@ warn_on_field_placement (tree gnu_field, Node_Id gnat_component_list, const char *msg1 = in_variant - ? "?variant layout may cause performance issues" - : "?record layout may cause performance issues"; + ? "??variant layout may cause performance issues" + : "??record layout may cause performance issues"; const char *msg2 = Ekind (gnat_field) == E_Discriminant - ? "?discriminant & whose length is not multiple of a byte" + ? "??discriminant & whose length is not multiple of a byte" : field_has_self_size (gnu_field) - ? "?component & whose length depends on a discriminant" + ? "??component & whose length depends on a discriminant" : field_has_variable_size (gnu_field) - ? "?component & whose length is not fixed" - : "?component & whose length is not multiple of a byte"; + ? "??component & whose length is not fixed" + : "??component & whose length is not multiple of a byte"; const char *msg3 = do_reorder - ? "?comes too early and was moved down" - : "?comes too early and ought to be moved down"; + ? "??comes too early and was moved down" + : "??comes too early and ought to be moved down"; post_error (msg1, gnat_field); post_error_ne (msg2, gnat_field, gnat_field); @@ -7674,7 +7734,7 @@ typedef struct vinfo will be the single field of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on GNU_FIELD_LIST. The other call to this function is a recursive call for the component list of a variant and, in this case, - GNU_FIELD_LIST is empty. + GNU_FIELD_LIST is empty. Note that GNAT_COMPONENT_LIST may be Empty. PACKED is 1 if this is for a packed record or -1 if this is for a record with Component_Alignment of Storage_Unit. @@ -7715,7 +7775,7 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type, tree *p_gnu_rep_list) { const bool needs_xv_encodings - = debug_info && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL; + = debug_info && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL; bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type); bool variants_have_rep = all_rep; bool layout_with_rep = false; @@ -7730,7 +7790,8 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type, /* For each component referenced in a component declaration create a GCC field and add it to the list, skipping pragmas in the GNAT list. */ gnu_last = tree_last (gnu_field_list); - if (Present (Component_Items (gnat_component_list))) + if (Present (gnat_component_list) + && (Present (Component_Items (gnat_component_list)))) for (gnat_component_decl = First_Non_Pragma (Component_Items (gnat_component_list)); Present (gnat_component_decl); @@ -7787,7 +7848,10 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type, } /* At the end of the component list there may be a variant part. */ - gnat_variant_part = Variant_Part (gnat_component_list); + if (Present (gnat_component_list)) + gnat_variant_part = Variant_Part (gnat_component_list); + else + gnat_variant_part = Empty; /* We create a QUAL_UNION_TYPE for the variant part since the variants are mutually exclusive and should go in the same memory. To do this we need @@ -8688,7 +8752,7 @@ annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref) gnu_type = TREE_TYPE (gnu_type); } - if (Unknown_Esize (gnat_entity)) + if (!Known_Esize (gnat_entity)) { if (TREE_CODE (gnu_type) == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) @@ -8700,7 +8764,7 @@ annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref) Set_Esize (gnat_entity, annotate_value (size)); } - if (Unknown_Alignment (gnat_entity)) + if (!Known_Alignment (gnat_entity)) Set_Alignment (gnat_entity, UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); } @@ -9494,14 +9558,14 @@ intrin_arglists_compatible_p (intrin_binding_t * inb) if (ada_type == void_type_node && btin_type != void_type_node) { - post_error ("?Ada arguments list too short!", inb->gnat_entity); + post_error ("??Ada arguments list too short!", inb->gnat_entity); return false; } if (btin_type == void_type_node && ada_type != void_type_node) { - post_error_ne_num ("?Ada arguments list too long ('> ^)!", + post_error_ne_num ("??Ada arguments list too long ('> ^)!", inb->gnat_entity, inb->gnat_entity, argpos); return false; } @@ -9510,7 +9574,7 @@ intrin_arglists_compatible_p (intrin_binding_t * inb) argpos ++; if (intrin_types_incompatible_p (ada_type, btin_type)) { - post_error_ne_num ("?intrinsic binding type mismatch on argument ^!", + post_error_ne_num ("??intrinsic binding type mismatch on argument ^!", inb->gnat_entity, inb->gnat_entity, argpos); return false; } @@ -9541,7 +9605,7 @@ intrin_return_compatible_p (intrin_binding_t * inb) handles void/void as well. */ if (intrin_types_incompatible_p (btin_return_type, ada_return_type)) { - post_error ("?intrinsic binding type mismatch on return value!", + post_error ("??intrinsic binding type mismatch on return value!", inb->gnat_entity); return false; } @@ -10175,7 +10239,12 @@ associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity) gcc_assert (TYPE_IMPL_PACKED_ARRAY_P (gnu_type)); - if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL) + { + add_parallel_type (gnu_type, gnu_original_array_type); + return NULL_TREE; + } + else { SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type); @@ -10184,11 +10253,6 @@ associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity) original_name = DECL_NAME (original_name); return original_name; } - else - { - add_parallel_type (gnu_type, gnu_original_array_type); - return NULL_TREE; - } } /* Given a type T, a FIELD_DECL F, and a replacement value R, return an diff --git a/gcc/ada/gcc-interface/gadaint.h b/gcc/ada/gcc-interface/gadaint.h index bf49794..89b9a11 100644 --- a/gcc/ada/gcc-interface/gadaint.h +++ b/gcc/ada/gcc-interface/gadaint.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 2010-2020, Free Software Foundation, Inc. * + * Copyright (C) 2010-2021, 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- * diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 328e5f3..49b85a4 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * @@ -233,24 +233,24 @@ extern "C" { structures and then generates code. */ extern void gigi (Node_Id gnat_root, int max_gnat_node, - int number_name, - struct Node *nodes_ptr, - struct Flags *Flags_Ptr, + int number_name, + Field_Offset *node_offsets_ptr, + any_slot *slots_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr, struct Elist_Header *elists_ptr, - struct Elmt_Item *elmts_ptr, - struct String_Entry *strings_ptr, - Char_Code *strings_chars_ptr, - struct List_Header *list_headers_ptr, - Nat number_file, - struct File_Info_Type *file_info_ptr, - Entity_Id standard_boolean, - Entity_Id standard_integer, - Entity_Id standard_character, - Entity_Id standard_long_long_float, - Entity_Id standard_exception_type, - Int gigi_operating_mode); + struct Elmt_Item *elmts_ptr, + struct String_Entry *strings_ptr, + Char_Code *strings_chars_ptr, + struct List_Header *list_headers_ptr, + Nat number_file, + struct File_Info_Type *file_info_ptr, + Entity_Id standard_boolean, + Entity_Id standard_integer, + Entity_Id standard_character, + Entity_Id standard_long_long_float, + Entity_Id standard_exception_type, + Int gigi_operating_mode); #ifdef __cplusplus } @@ -396,8 +396,8 @@ enum standard_datatypes /* Identifier for the name of the _Parent field in tagged record types. */ ADT_parent_name_id, - /* Identifier for the name of the Exception_Data type. */ - ADT_exception_data_name_id, + /* Identifier for the name of the Not_Handled_By_Others field. */ + ADT_not_handled_by_others_name_id, /* Types and decls used by the SJLJ exception mechanism. */ ADT_jmpbuf_type, @@ -467,7 +467,8 @@ extern GTY(()) tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1]; #define mulv64_decl gnat_std_decls[(int) ADT_mulv64_decl] #define mulv128_decl gnat_std_decls[(int) ADT_mulv128_decl] #define parent_name_id gnat_std_decls[(int) ADT_parent_name_id] -#define exception_data_name_id gnat_std_decls[(int) ADT_exception_data_name_id] +#define not_handled_by_others_name_id \ + gnat_std_decls[(int) ADT_not_handled_by_others_name_id] #define jmpbuf_type gnat_std_decls[(int) ADT_jmpbuf_type] #define jmpbuf_ptr_type gnat_std_decls[(int) ADT_jmpbuf_ptr_type] #define get_jmpbuf_decl gnat_std_decls[(int) ADT_get_jmpbuf_decl] diff --git a/gcc/ada/gcc-interface/lang-specs.h b/gcc/ada/gcc-interface/lang-specs.h index f0ef3b92..f5a7496 100644 --- a/gcc/ada/gcc-interface/lang-specs.h +++ b/gcc/ada/gcc-interface/lang-specs.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index d0867e0..96199bd 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * @@ -63,7 +63,7 @@ const char **save_argv; /* GNAT argc and argv generated by the binder for all Ada programs. */ extern int gnat_argc; -extern const char **gnat_argv; +extern char **gnat_argv; /* Ada code requires variables for these settings rather than elements of the global_options structure because they are imported. */ @@ -241,7 +241,7 @@ gnat_init_options (unsigned int decoded_options_count, save_argv[save_argc] = NULL; /* Pass just the name of the command through the regular channel. */ - gnat_argv = (const char **) xmalloc (sizeof (char *)); + gnat_argv = (char **) xmalloc (sizeof (char *)); gnat_argv[0] = xstrdup (save_argv[0]); gnat_argc = 1; } @@ -256,6 +256,9 @@ gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED) /* Excess precision other than "fast" requires front-end support. */ if (flag_excess_precision == EXCESS_PRECISION_STANDARD) sorry ("%<-fexcess-precision=standard%> for Ada"); + else if (flag_excess_precision == EXCESS_PRECISION_FLOAT16) + sorry ("%<-fexcess-precision=16%> for Ada"); + flag_excess_precision = EXCESS_PRECISION_FAST; /* No psABI change warnings for Ada. */ @@ -370,6 +373,9 @@ gnat_init (void) sbitsize_one_node = sbitsize_int (1); sbitsize_unit_node = sbitsize_int (BITS_PER_UNIT); + /* In Ada, we do not use location ranges. */ + line_table->default_range_bits = 0; + /* Register our internal error function. */ global_dc->internal_error = &internal_error_function; @@ -749,7 +755,7 @@ gnat_type_max_size (const_tree gnu_type) type's alignment and return the result in units. */ if (tree_fits_uhwi_p (max_ada_size)) max_size_unit - = size_binop (CEIL_DIV_EXPR, + = size_binop (EXACT_DIV_EXPR, round_up (max_ada_size, TYPE_ALIGN (gnu_type)), bitsize_unit_node); } @@ -803,7 +809,7 @@ gnat_get_array_descr_info (const_tree const_type, /* As well as array types embedded in a record type with their bounds. */ else if (TREE_CODE (type) == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type) - && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + && gnat_encodings != DWARF_GNAT_ENCODINGS_ALL) { /* This will be our base object address. Note that we assume that pointers to this will actually point to the array field (thin @@ -898,7 +904,7 @@ gnat_get_array_descr_info (const_tree const_type, if (TYPE_CONTEXT (first_dimen) && TREE_CODE (TYPE_CONTEXT (first_dimen)) != RECORD_TYPE && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (index_type)) - && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL) { info->dimen[i].lower_bound = NULL_TREE; info->dimen[i].upper_bound = NULL_TREE; @@ -940,7 +946,7 @@ gnat_get_array_descr_info (const_tree const_type, info->associated = NULL_TREE; info->data_location = NULL_TREE; - if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + if (gnat_encodings != DWARF_GNAT_ENCODINGS_ALL) { /* When arrays contain dynamically-sized elements, we usually wrap them in padding types, or we create constrained types for them. Then, if diff --git a/gcc/ada/gcc-interface/system.ads b/gcc/ada/gcc-interface/system.ads index f54c43f..cfd9bb9 100644 --- a/gcc/ada/gcc-interface/system.ads +++ b/gcc/ada/gcc-interface/system.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Compiler Version) -- -- -- --- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -50,6 +50,10 @@ pragma Restrictions (No_Finalization); -- access type on incomplete type Perm_Tree_Wrapper (which is required for -- defining a recursive type). +pragma Restrictions (No_Tasking); +-- Make it explicit that tasking is not used in the compiler, which also +-- allows generating simpler and more efficient code. + package System is pragma Pure; -- Note that we take advantage of the implementation permission to make @@ -145,7 +149,6 @@ private -- parameters is not too critical for the compiler version (e.g. we -- do not use floating-point anyway in the compiler). - AAMP : constant Boolean := False; Backend_Divide_Checks : constant Boolean := False; Backend_Overflow_Checks : constant Boolean := False; Command_Line_Args : constant Boolean := True; @@ -153,8 +156,6 @@ private Denorm : constant Boolean := True; Duration_32_Bits : constant Boolean := False; Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; Preallocated_Stacks : constant Boolean := False; @@ -172,13 +173,4 @@ private Frontend_Exceptions : constant Boolean := False; ZCX_By_Default : constant Boolean := True; - -- Obsolete entries, to be removed eventually (bootstrap issues) - - Front_End_ZCX_Support : constant Boolean := False; - High_Integrity_Mode : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - Functions_Return_By_DSP : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - end System; diff --git a/gcc/ada/gcc-interface/targtyps.c b/gcc/ada/gcc-interface/targtyps.c index 60a37e1..704172d 100644 --- a/gcc/ada/gcc-interface/targtyps.c +++ b/gcc/ada/gcc-interface/targtyps.c @@ -6,7 +6,7 @@ * * * Body * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index ae7a52f..3df56aa 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * @@ -75,8 +75,8 @@ #define ALLOCA_THRESHOLD 1000 /* Pointers to front-end tables accessed through macros. */ -struct Node *Nodes_Ptr; -struct Flags *Flags_Ptr; +Field_Offset *Node_Offsets_Ptr; +any_slot *Slots_Ptr; Node_Id *Next_Node_Ptr; Node_Id *Prev_Node_Ptr; struct Elist_Header *Elists_Ptr; @@ -112,7 +112,7 @@ struct GTY (()) parm_attr_d { typedef struct parm_attr_d *parm_attr; - +/* Structure used to record information for a function. */ struct GTY(()) language_function { vec<parm_attr, va_gc> *parm_attr_cache; bitmap named_ret_val; @@ -194,9 +194,9 @@ struct GTY(()) range_check_info_d { typedef struct range_check_info_d *range_check_info; - /* Structure used to record information for a loop. */ struct GTY(()) loop_info_d { + tree fndecl; tree stmt; tree loop_var; tree low_bound; @@ -205,11 +205,11 @@ struct GTY(()) loop_info_d { tree omp_construct_clauses; enum tree_code omp_code; vec<range_check_info, va_gc> *checks; + vec<tree, va_gc> *invariants; }; typedef struct loop_info_d *loop_info; - /* Stack of loop_info structures associated with LOOP_STMT nodes. */ static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack; @@ -251,17 +251,27 @@ static tree build_raise_check (int, enum exception_info_kind); static tree create_init_temporary (const char *, tree, tree *, Node_Id); static bool maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk); -/* Hooks for debug info back-ends, only supported and used in a restricted set - of configurations. */ -static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED; -static const char *decode_name (const char *) ATTRIBUTE_UNUSED; - /* This makes gigi's file_info_ptr visible in this translation unit, so that Sloc_to_locus can look it up when deciding whether to map decls to instances. */ static struct File_Info_Type *file_map; +/* Return the string of the identifier allocated for the file name Id. */ + +static const char* +File_Name_to_gnu (Name_Id Id) +{ + /* __gnat_to_canonical_file_spec translates file names from pragmas + Source_Reference that contain host style syntax not understood by GDB. */ + const char *name = __gnat_to_canonical_file_spec (Get_Name_String (Id)); + + /* Use the identifier table to make a permanent copy of the file name as + the name table gets reallocated after Gigi returns but before all the + debugging information is output. */ + return IDENTIFIER_POINTER (get_identifier (name)); +} + /* This is the main program of the back-end. It sets up all the table structures and then generates code. */ @@ -269,8 +279,8 @@ void gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, - struct Node *nodes_ptr, - struct Flags *flags_ptr, + Field_Offset *node_offsets_ptr, + any_slot *slots_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr, struct Elist_Header *elists_ptr, @@ -295,8 +305,8 @@ gigi (Node_Id gnat_root, max_gnat_nodes = max_gnat_node; - Nodes_Ptr = nodes_ptr; - Flags_Ptr = flags_ptr; + Node_Offsets_Ptr = node_offsets_ptr; + Slots_Ptr = slots_ptr; Next_Node_Ptr = next_node_ptr; Prev_Node_Ptr = prev_node_ptr; Elists_Ptr = elists_ptr; @@ -315,23 +325,18 @@ gigi (Node_Id gnat_root, for (i = 0; i < number_file; i++) { - /* Use the identifier table to make a permanent copy of the filename as - the name table gets reallocated after Gigi returns but before all the - debugging information is output. The __gnat_to_canonical_file_spec - call translates filenames from pragmas Source_Reference that contain - host style syntax not understood by gdb. */ - const char *filename - = IDENTIFIER_POINTER - (get_identifier - (__gnat_to_canonical_file_spec - (Get_Name_String (file_info_ptr[i].File_Name)))); - /* We rely on the order isomorphism between files and line maps. */ - gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table) == i); + if ((int) LINEMAPS_ORDINARY_USED (line_table) != i) + { + gcc_assert (i > 0); + error ("%s contains too many lines", + File_Name_to_gnu (file_info_ptr[i - 1].File_Name)); + } /* We create the line map for a source file at once, with a fixed number of columns chosen to avoid jumping over the next power of 2. */ - linemap_add (line_table, LC_ENTER, 0, filename, 1); + linemap_add (line_table, LC_ENTER, 0, + File_Name_to_gnu (file_info_ptr[i].File_Name), 1); linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252); linemap_position_for_column (line_table, 252 - 1); linemap_add (line_table, LC_LEAVE, 0, NULL, 0); @@ -456,13 +461,20 @@ gigi (Node_Id gnat_root, /* Name of the _Parent field in tagged record types. */ parent_name_id = get_identifier (Get_Name_String (Name_uParent)); - /* Name of the Exception_Data type defined in System.Standard_Library. */ - exception_data_name_id - = get_identifier ("system__standard_library__exception_data"); + /* Name of the Not_Handled_By_Others field in exception record types. */ + not_handled_by_others_name_id = get_identifier ("not_handled_by_others"); /* Make the types and functions used for exception processing. */ except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type)); + for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t)) + if (DECL_NAME (t) == not_handled_by_others_name_id) + { + not_handled_by_others_decl = t; + break; + } + gcc_assert (DECL_P (not_handled_by_others_decl)); + jmpbuf_type = build_array_type (gnat_type_for_mode (Pmode, 0), build_index_type (size_int (5))); @@ -490,15 +502,6 @@ gigi (Node_Id gnat_root, NULL_TREE), NULL_TREE, is_default, true, true, true, false, false, NULL, Empty); - not_handled_by_others_decl = get_identifier ("not_handled_by_others"); - for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t)) - if (DECL_NAME (t) == not_handled_by_others_decl) - { - not_handled_by_others_decl = t; - break; - } - gcc_assert (DECL_P (not_handled_by_others_decl)); - /* setjmp returns an integer and has one operand, which is a pointer to a jmpbuf. */ setjmp_decl @@ -747,7 +750,7 @@ build_raise_check (int check, enum exception_info_kind kind) strcpy (Name_Buffer, pfx); Name_Len = sizeof (pfx) - 1; - Get_RT_Exception_Name (check); + Get_RT_Exception_Name ((enum RT_Exception_Code) check); if (kind == exception_simple) { @@ -1450,17 +1453,17 @@ Pragma_to_gnu (Node_Id gnat_node) { case Name_Off: if (optimize) - post_error ("must specify -O0?", gnat_node); + post_error ("must specify -O0??", gnat_node); break; case Name_Space: if (!optimize_size) - post_error ("must specify -Os?", gnat_node); + post_error ("must specify -Os??", gnat_node); break; case Name_Time: if (!optimize) - post_error ("insufficient -O value?", gnat_node); + post_error ("insufficient -O value??", gnat_node); break; default: @@ -1470,7 +1473,7 @@ Pragma_to_gnu (Node_Id gnat_node) case Pragma_Reviewable: if (write_symbols == NO_DEBUG) - post_error ("must specify -g?", gnat_node); + post_error ("must specify -g??", gnat_node); break; case Pragma_Warning_As_Error: @@ -1571,17 +1574,17 @@ Pragma_to_gnu (Node_Id gnat_node) option_index = find_opt (option_string + 1, lang_mask); if (option_index == OPT_SPECIAL_unknown) { - post_error ("?unknown -W switch", gnat_node); + post_error ("unknown -W switch??", gnat_node); break; } else if (!(cl_options[option_index].flags & CL_WARNING)) { - post_error ("?-W switch does not control warning", gnat_node); + post_error ("-W switch does not control warning??", gnat_node); break; } else if (!(cl_options[option_index].flags & lang_mask)) { - post_error ("?-W switch not valid for Ada", gnat_node); + post_error ("-W switch not valid for Ada??", gnat_node); break; } if (cl_options[option_index].flags & CL_JOINED) @@ -2763,13 +2766,27 @@ find_loop_for (tree expr, tree *disp, bool *neg_p) if (TREE_CODE (var) != VAR_DECL) return NULL; - if (decl_function_context (var) != current_function_decl) - return NULL; + gcc_checking_assert (vec_safe_length (gnu_loop_stack) > 0); + + FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter) + if (iter->loop_var == var && iter->fndecl == current_function_decl) + break; + + return iter; +} + +/* Return the innermost enclosing loop in the current function. */ + +static struct loop_info_d * +find_loop (void) +{ + struct loop_info_d *iter = NULL; + unsigned int i; - gcc_assert (vec_safe_length (gnu_loop_stack) > 0); + gcc_checking_assert (vec_safe_length (gnu_loop_stack) > 0); FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter) - if (var == iter->loop_var) + if (iter->fndecl == current_function_decl) break; return iter; @@ -2919,26 +2936,30 @@ independent_iterations_p (tree stmt_list) return true; } -/* Helper for Loop_Statement_to_gnu, to translate the body of a loop not - subject to any sort of parallelization directive or restriction, designated - by GNAT_NODE. - - We expect the top of gnu_loop_stack to hold a pointer to the loop info - setup for the translation, which holds a pointer to the initial gnu loop - stmt node. We return the new gnu loop statement to use. - - We might also set *GNU_COND_EXPR_P to request a variant of the translation - scheme in Loop_Statement_to_gnu. */ +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, + to a GCC tree, which is returned. */ static tree -Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p) +Loop_Statement_to_gnu (Node_Id gnat_node) { const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); - struct loop_info_d *const gnu_loop_info = gnu_loop_stack->last (); - tree gnu_loop_stmt = gnu_loop_info->stmt; - tree gnu_loop_label = LOOP_STMT_LABEL (gnu_loop_stmt); - tree gnu_cond_expr = *gnu_cond_expr_p; - tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; + struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> (); + tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE); + tree gnu_loop_label = create_artificial_label (input_location); + tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE; + tree gnu_result; + + /* Push the loop_info structure associated with the LOOP_STMT. */ + gnu_loop_info->fndecl = current_function_decl; + gnu_loop_info->stmt = gnu_loop_stmt; + vec_safe_push (gnu_loop_stack, gnu_loop_info); + + /* Set location information for statement and end label. */ + set_expr_location_from_node (gnu_loop_stmt, gnat_node); + Sloc_to_locus (Sloc (End_Label (gnat_node)), + &DECL_SOURCE_LOCATION (gnu_loop_label)); + LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label; /* Set the condition under which the loop must keep going. If we have an explicit condition, use it to set the location information throughout @@ -3272,7 +3293,16 @@ Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p) } } - /* Second, if loop vectorization is enabled and the iterations of the + /* Second, if we have recorded invariants to be hoisted, emit them. */ + if (vec_safe_length (gnu_loop_info->invariants) > 0) + { + tree *iter; + unsigned int i; + FOR_EACH_VEC_ELT (*gnu_loop_info->invariants, i, iter) + add_stmt_with_node_force (*iter, gnat_node); + } + + /* Third, if loop vectorization is enabled and the iterations of the loop can easily be proved as independent, mark the loop. */ if (optimize >= 3 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt))) @@ -3283,40 +3313,6 @@ Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p) gnu_loop_stmt = end_stmt_group (); } - *gnu_cond_expr_p = gnu_cond_expr; - - return gnu_loop_stmt; -} - -/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, - to a GCC tree, which is returned. */ - -static tree -Loop_Statement_to_gnu (Node_Id gnat_node) -{ - struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> (); - - tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE, - NULL_TREE, NULL_TREE, NULL_TREE); - tree gnu_cond_expr = NULL_TREE; - tree gnu_loop_label = create_artificial_label (input_location); - tree gnu_result; - - /* Push the loop_info structure associated with the LOOP_STMT. */ - vec_safe_push (gnu_loop_stack, gnu_loop_info); - - /* Set location information for statement and end label. */ - set_expr_location_from_node (gnu_loop_stmt, gnat_node); - Sloc_to_locus (Sloc (End_Label (gnat_node)), - &DECL_SOURCE_LOCATION (gnu_loop_label)); - LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label; - - /* Save the statement for later reuse. */ - gnu_loop_info->stmt = gnu_loop_stmt; - - /* Perform the core loop body translation. */ - gnu_loop_stmt = Regular_Loop_to_gnu (gnat_node, &gnu_cond_expr); - /* If we have an outer COND_EXPR, that's our result and this loop is its "true" statement. Otherwise, the result is the LOOP_STMT. */ if (gnu_cond_expr) @@ -3889,7 +3885,9 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) } /* Set the line number in the decl to correspond to that of the body. */ - if (!Sloc_to_locus (Sloc (gnat_node), &locus, false, gnu_subprog_decl)) + if (DECL_IGNORED_P (gnu_subprog_decl)) + locus = UNKNOWN_LOCATION; + else if (!Sloc_to_locus (Sloc (gnat_node), &locus, false, gnu_subprog_decl)) locus = input_location; DECL_SOURCE_LOCATION (gnu_subprog_decl) = locus; @@ -4241,7 +4239,7 @@ node_is_component (Node_Id gnat_node) We implement 3 different semantics of atomicity in this function: 1. the Ada 95/2005/2012 semantics of the Atomic aspect/pragma, - 2. the Ada 2020 semantics of the Atomic aspect/pragma, + 2. the Ada 2022 semantics of the Atomic aspect/pragma, 3. the semantics of the Volatile_Full_Access GNAT aspect/pragma. They are mutually exclusive and the FE should have rejected conflicts. */ @@ -4288,7 +4286,7 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync) gnat_node = Expression (gnat_node); /* Up to Ada 2012, for Atomic itself, only reads and updates of the object as - a whole require atomic access (RM C.6(15)). But, starting with Ada 2020, + a whole require atomic access (RM C.6(15)). But, starting with Ada 2022, reads of or writes to a nonatomic subcomponent of the object also require atomic access (RM C.6(19)). */ if (node_is_atomic (gnat_node)) @@ -4299,7 +4297,7 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync) for (gnat_temp = gnat_node, gnat_parent = Parent (gnat_temp); node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_temp; gnat_temp = gnat_parent, gnat_parent = Parent (gnat_temp)) - if (Ada_Version < Ada_2020 || node_is_atomic (gnat_parent)) + if (Ada_Version < Ada_2022 || node_is_atomic (gnat_parent)) goto not_atomic; else as_a_whole = false; @@ -4318,7 +4316,7 @@ get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync) for (gnat_temp = gnat_node; node_is_component (gnat_temp); gnat_temp = Prefix (gnat_temp)) - if ((Ada_Version >= Ada_2020 && node_is_atomic (Prefix (gnat_temp))) + if ((Ada_Version >= Ada_2022 && node_is_atomic (Prefix (gnat_temp))) || node_is_volatile_full_access (Prefix (gnat_temp))) { *type = OUTER_ATOMIC; @@ -4379,6 +4377,69 @@ create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt, return gnu_temp; } +/* Return true if TYPE is an array of scalar type. */ + +static bool +is_array_of_scalar_type (tree type) +{ + if (TREE_CODE (type) != ARRAY_TYPE) + return false; + + type = TREE_TYPE (type); + + return !AGGREGATE_TYPE_P (type) && !POINTER_TYPE_P (type); +} + +/* Helper function for walk_tree, used by return_slot_opt_for_pure_call_p. */ + +static tree +find_decls_r (tree *tp, int *walk_subtrees, void *data) +{ + bitmap decls = (bitmap) data; + + if (TYPE_P (*tp)) + *walk_subtrees = 0; + + else if (DECL_P (*tp)) + bitmap_set_bit (decls, DECL_UID (*tp)); + + return NULL_TREE; +} + +/* Return whether the assignment TARGET = CALL can be subject to the return + slot optimization, under the assumption that the called function be pure + in the Ada sense and return an array of scalar type. */ + +static bool +return_slot_opt_for_pure_call_p (tree target, tree call) +{ + /* Check that the target is a DECL. */ + if (!DECL_P (target)) + return false; + + const bitmap decls = BITMAP_GGC_ALLOC (); + call_expr_arg_iterator iter; + tree arg; + + /* Check that all the arguments have either a scalar type (we assume that + this means by-copy passing mechanism) or array of scalar type. */ + FOR_EACH_CALL_EXPR_ARG (arg, iter, call) + { + tree arg_type = TREE_TYPE (arg); + if (TREE_CODE (arg_type) == REFERENCE_TYPE) + arg_type = TREE_TYPE (arg_type); + + if (is_array_of_scalar_type (arg_type)) + walk_tree_without_duplicates (&arg, find_decls_r, decls); + + else if (AGGREGATE_TYPE_P (arg_type) || POINTER_TYPE_P (arg_type)) + return false; + } + + /* Check that the target is not referenced by the non-scalar arguments. */ + return !bitmap_bit_p (decls, DECL_UID (target)); +} + /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call or an N_Procedure_Call_Statement, to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where we should place the result type. @@ -4412,8 +4473,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, tree gnu_after_list = NULL_TREE; tree gnu_retval = NULL_TREE; tree gnu_call, gnu_result; - bool went_into_elab_proc = false; - bool pushed_binding_level = false; + bool went_into_elab_proc; + bool pushed_binding_level; bool variadic; bool by_descriptor; Entity_Id gnat_formal; @@ -4496,6 +4557,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, current_function_decl = get_elaboration_procedure (); went_into_elab_proc = true; } + else + went_into_elab_proc = false; /* First, create the temporary for the return value when: @@ -4503,15 +4566,16 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, because we need to preserve the return value before copying back the parameters. - 2. There is no target and the call is made for neither an object, nor a - renaming declaration, nor a return statement, nor an allocator, and - the return type has variable size because in this case the gimplifier - cannot create the temporary, or more generally is an aggregate type, - because the gimplifier would create the temporary in the outermost - scope instead of locally. But there is an exception for an allocator - of an unconstrained record type with default discriminant because we - allocate the actual size in this case, unlike the other 3 cases, so - we need a temporary to fetch the discriminant and we create it here. + 2. There is no target and the call is made for neither the declaration + of an object (regular or renaming), nor a return statement, nor an + allocator, nor an aggregate, and the return type has variable size + because in this case the gimplifier cannot create the temporary, or + more generally is an aggregate type, because the gimplifier would + create the temporary in the outermost scope instead of locally here. + But there is an exception for an allocator of unconstrained record + type with default discriminant because we allocate the actual size + in this case, unlike in the other cases, so we need a temporary to + fetch the discriminant and we create it here. 3. There is a target and it is a slice or an array with fixed size, and the return type has variable size, because the gimplifier @@ -4537,6 +4601,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, && (!(Nkind (Parent (gnat_node)) == N_Qualified_Expression && Nkind (Parent (Parent (gnat_node))) == N_Allocator) || type_is_padding_self_referential (gnu_result_type)) + && Nkind (Parent (gnat_node)) != N_Aggregate && AGGREGATE_TYPE_P (gnu_result_type) && !TYPE_IS_FAT_POINTER_P (gnu_result_type)) || (gnu_target @@ -4548,6 +4613,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, || (gnu_target && TREE_CODE (gnu_target) == COMPONENT_REF && DECL_BIT_FIELD (TREE_OPERAND (gnu_target, 1)) + && DECL_SIZE (TREE_OPERAND (gnu_target, 1)) + != TYPE_SIZE (TREE_TYPE (gnu_target)) && type_is_padding_self_referential (gnu_result_type)))) { gnu_retval = create_temporary ("R", gnu_result_type); @@ -4563,6 +4630,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, gnat_pushlevel (); pushed_binding_level = true; } + else + pushed_binding_level = false; /* Create the list of the actual parameters as GCC expects it, namely a chain of TREE_LIST nodes in which the TREE_VALUE field of each node @@ -4753,7 +4822,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, may have suppressed a conversion to the Etype of the actual earlier, since the parent is a procedure call, so put it back here. Note that we might have a dummy type here if the actual is the dereference of a - pointer to it, but that's OK if the formal is passed by reference. */ + pointer to it, but that's OK when the formal is passed by reference. + We also do not put back a conversion between an actual and a formal + that are unconstrained array types to avoid creating local bounds. */ tree gnu_actual_type = get_unpadded_type (Etype (gnat_actual)); if (TYPE_IS_DUMMY_P (gnu_actual_type)) gcc_assert (is_true_formal_parm && DECL_BY_REF_P (gnu_formal)); @@ -4761,6 +4832,11 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, && Nkind (gnat_actual) == N_Unchecked_Type_Conversion) gnu_actual = unchecked_convert (gnu_actual_type, gnu_actual, No_Truncation (gnat_actual)); + else if ((TREE_CODE (TREE_TYPE (gnu_actual)) == UNCONSTRAINED_ARRAY_TYPE + || (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual)))) + && TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE) + ; else gnu_actual = convert (gnu_actual_type, gnu_actual); @@ -5155,6 +5231,17 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, That's what has been done historically. */ if (return_type_with_variable_size_p (gnu_result_type)) op_code = INIT_EXPR; + + /* If this is a call to a pure function returning an array of scalar + type, try to apply the return slot optimization. */ + else if ((TYPE_READONLY (gnu_subprog_type) + || TYPE_RESTRICT (gnu_subprog_type)) + && is_array_of_scalar_type (gnu_result_type) + && TYPE_MODE (gnu_result_type) == BLKmode + && aggregate_value_p (gnu_result_type, gnu_subprog_type) + && return_slot_opt_for_pure_call_p (gnu_target, gnu_call)) + op_code = INIT_EXPR; + else op_code = MODIFY_EXPR; @@ -5278,7 +5365,7 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) because of the unstructured form of EH used by fe_sjlj_eh, there might be forward edges going to __builtin_setjmp receivers on which it is uninitialized, although they will never be actually taken. */ - TREE_NO_WARNING (gnu_jmpsave_decl) = 1; + suppress_warning (gnu_jmpsave_decl, OPT_Wuninitialized); gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE, jmpbuf_type, @@ -5515,7 +5602,7 @@ Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node) gnu_except_ptr_stack->last (), convert (TREE_TYPE (gnu_except_ptr_stack->last ()), build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); -} + } else gcc_unreachable (); @@ -6067,12 +6154,19 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) { if (!gnu_cond) gnu_cond = gnat_to_gnu (gnat_cond); + if (integer_zerop (gnu_cond)) + return alloc_stmt_list (); gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result, alloc_stmt_list ()); } } else - gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result); + { + /* The condition field must not be present when the node is used as an + expression form. */ + gigi_checking_assert (No (gnat_cond)); + gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result); + } return gnu_result; } @@ -6192,12 +6286,12 @@ tree gnat_to_gnu (Node_Id gnat_node) { const Node_Kind kind = Nkind (gnat_node); - bool went_into_elab_proc = false; tree gnu_result = error_mark_node; /* Default to no value. */ tree gnu_result_type = void_type_node; tree gnu_expr, gnu_lhs, gnu_rhs; Node_Id gnat_temp; atomic_acces_t aa_type; + bool went_into_elab_proc; bool aa_sync; /* Save node number for error message and set location information. */ @@ -6229,32 +6323,18 @@ gnat_to_gnu (Node_Id gnat_node) build_call_raise (CE_Range_Check_Failed, gnat_node, N_Raise_Constraint_Error)); - if ((statement_node_p (gnat_node) && kind != N_Null_Statement) - || kind == N_Handled_Sequence_Of_Statements - || kind == N_Implicit_Label_Declaration) + /* If this is a statement and we are at top level, it must be part of the + elaboration procedure, so mark us as being in that procedure. */ + if ((statement_node_p (gnat_node) + || kind == N_Handled_Sequence_Of_Statements + || kind == N_Implicit_Label_Declaration) + && !current_function_decl) { - tree current_elab_proc = get_elaboration_procedure (); - - /* If this is a statement and we are at top level, it must be part of - the elaboration procedure, so mark us as being in that procedure. */ - if (!current_function_decl) - { - current_function_decl = current_elab_proc; - went_into_elab_proc = true; - } - - /* If we are in the elaboration procedure, check if we are violating a - No_Elaboration_Code restriction by having a statement there. Don't - check for a possible No_Elaboration_Code restriction violation on - N_Handled_Sequence_Of_Statements, as we want to signal an error on - every nested real statement instead. This also avoids triggering - spurious errors on dummy (empty) sequences created by the front-end - for package bodies in some cases. */ - if (current_function_decl == current_elab_proc - && kind != N_Handled_Sequence_Of_Statements - && kind != N_Implicit_Label_Declaration) - Check_Elaboration_Code_Allowed (gnat_node); + current_function_decl = get_elaboration_procedure (); + went_into_elab_proc = true; } + else + went_into_elab_proc = false; switch (kind) { @@ -6726,6 +6806,8 @@ gnat_to_gnu (Node_Id gnat_node) else { tree gnu_field = gnat_to_gnu_field_decl (gnat_field); + tree gnu_offset; + struct loop_info_d *loop; gnu_result = build_component_ref (gnu_prefix, gnu_field, @@ -6733,6 +6815,29 @@ gnat_to_gnu (Node_Id gnat_node) == N_Attribute_Reference) && lvalue_required_for_attribute_p (Parent (gnat_node))); + + /* If optimization is enabled and we are inside a loop, we try to + hoist nonconstant but invariant offset computations outside of + the loop, since they very likely contain loads that could turn + out to be hard to move if they end up in active EH regions. */ + if (optimize + && inside_loop_p () + && TREE_CODE (gnu_result) == COMPONENT_REF + && (gnu_offset = component_ref_field_offset (gnu_result)) + && !TREE_CONSTANT (gnu_offset) + && (gnu_offset = gnat_invariant_expr (gnu_offset)) + && (loop = find_loop ())) + { + tree invariant + = build1 (SAVE_EXPR, TREE_TYPE (gnu_offset), gnu_offset); + vec_safe_push (loop->invariants, invariant); + tree field = TREE_OPERAND (gnu_result, 1); + tree factor + = size_int (DECL_OFFSET_ALIGN (field) / BITS_PER_UNIT); + /* Divide the offset by its alignment. */ + TREE_OPERAND (gnu_result, 2) + = size_binop (EXACT_DIV_EXPR, invariant, factor); + } } gnu_result_type = get_unpadded_type (Etype (gnat_node)); @@ -6872,7 +6977,7 @@ gnat_to_gnu (Node_Id gnat_node) if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type)) post_error_ne_tree_2 - ("?source alignment (^) '< alignment of & (^)", + ("??source alignment (^) '< alignment of & (^)", gnat_node, Designated_Type (Etype (gnat_node)), size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT); } @@ -7520,8 +7625,10 @@ gnat_to_gnu (Node_Id gnat_node) if (gnu_return_label_stack->last ()) { if (gnu_ret_val) - add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj, - gnu_ret_val)); + add_stmt_with_node (build_binary_op (MODIFY_EXPR, + NULL_TREE, gnu_ret_obj, + gnu_ret_val), + gnat_node); gnu_result = build1 (GOTO_EXPR, void_type_node, gnu_return_label_stack->last ()); @@ -7887,7 +7994,7 @@ gnat_to_gnu (Node_Id gnat_node) } Clobber_Setup (gnat_node); - while ((clobber = Clobber_Get_Next ())) + while ((clobber = (char *) Clobber_Get_Next ())) gnu_clobbers = tree_cons (NULL_TREE, build_string (strlen (clobber) + 1, clobber), @@ -8129,6 +8236,14 @@ gnat_to_gnu (Node_Id gnat_node) gcc_unreachable (); } + /* If we are in the elaboration procedure, check if we are violating the + No_Elaboration_Code restriction by having a non-empty statement. */ + if (statement_node_p (gnat_node) + && !(TREE_CODE (gnu_result) == STATEMENT_LIST + && empty_stmt_list_p (gnu_result)) + && current_function_decl == get_elaboration_procedure ()) + Check_Elaboration_Code_Allowed (gnat_node); + /* If we pushed the processing of the elaboration routine, pop it back. */ if (went_into_elab_proc) current_function_decl = NULL_TREE; @@ -8177,7 +8292,7 @@ gnat_to_gnu (Node_Id gnat_node) /* If the result is a constant that overflowed, raise Constraint_Error. */ if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result)) { - post_error ("?`Constraint_Error` will be raised at run time", gnat_node); + post_error ("??`Constraint_Error` will be raised at run time", gnat_node); gnu_result = build1 (NULL_EXPR, gnu_result_type, build_call_raise (CE_Overflow_Check_Failed, gnat_node, @@ -8264,7 +8379,9 @@ gnat_to_gnu (Node_Id gnat_node) much data. But do not remove it if it is already too small. */ if (type_is_padding_self_referential (TREE_TYPE (gnu_result)) && !(TREE_CODE (gnu_result) == COMPONENT_REF - && DECL_BIT_FIELD (TREE_OPERAND (gnu_result, 1)))) + && DECL_BIT_FIELD (TREE_OPERAND (gnu_result, 1)) + && DECL_SIZE (TREE_OPERAND (gnu_result, 1)) + != TYPE_SIZE (TREE_TYPE (gnu_result)))) gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), gnu_result); } @@ -8317,7 +8434,7 @@ tree gnat_to_gnu_external (Node_Id gnat_node) { const int save_force_global = force_global; - bool went_into_elab_proc = false; + bool went_into_elab_proc; /* Force the local context and create a fake scope that we zap at the end so declarations will not be stuck either in the @@ -8327,6 +8444,8 @@ gnat_to_gnu_external (Node_Id gnat_node) current_function_decl = get_elaboration_procedure (); went_into_elab_proc = true; } + else + went_into_elab_proc = false; force_global = 0; gnat_pushlevel (); @@ -8688,7 +8807,7 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, else { *expr_p = create_tmp_var (type, NULL); - TREE_NO_WARNING (*expr_p) = 1; + suppress_warning (*expr_p); } gimplify_and_add (TREE_OPERAND (expr, 0), pre_p); @@ -8736,6 +8855,31 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, return GS_UNHANDLED; + case CALL_EXPR: + /* If we are passing a constant fat pointer CONSTRUCTOR, make sure it is + put into static memory; this performs a restricted version of constant + propagation on fat pointers in calls. But do not do it for strings to + avoid blocking concatenation in the caller when it is inlined. */ + for (int i = 0; i < call_expr_nargs (expr); i++) + { + tree arg = *(CALL_EXPR_ARGP (expr) + i); + + if (TREE_CODE (arg) == CONSTRUCTOR + && TREE_CONSTANT (arg) + && TYPE_IS_FAT_POINTER_P (TREE_TYPE (arg))) + { + tree t = CONSTRUCTOR_ELT (arg, 0)->value; + if (TREE_CODE (t) == NOP_EXPR) + t = TREE_OPERAND (t, 0); + if (TREE_CODE (t) == ADDR_EXPR) + t = TREE_OPERAND (t, 0); + if (TREE_CODE (t) != STRING_CST) + *(CALL_EXPR_ARGP (expr) + i) = tree_output_constant_def (arg); + } + } + + return GS_UNHANDLED; + case VIEW_CONVERT_EXPR: op = TREE_OPERAND (expr, 0); @@ -9131,13 +9275,13 @@ process_freeze_entity (Node_Id gnat_node) gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, true); /* Propagate back-annotations from full view to partial view. */ - if (Unknown_Alignment (gnat_entity)) - Set_Alignment (gnat_entity, Alignment (full_view)); + if (!Known_Alignment (gnat_entity)) + Copy_Alignment (gnat_entity, full_view); - if (Unknown_Esize (gnat_entity)) + if (!Known_Esize (gnat_entity)) Set_Esize (gnat_entity, Esize (full_view)); - if (Unknown_RM_Size (gnat_entity)) + if (!Known_RM_Size (gnat_entity)) Set_RM_Size (gnat_entity, RM_Size (full_view)); /* The above call may have defined this entity (the simplest example @@ -10185,7 +10329,7 @@ validate_unchecked_conversion (Node_Id gnat_node) || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type), target_alias_set))) { - post_error_ne ("?possible aliasing problem for type&", + post_error_ne ("??possible aliasing problem for type&", gnat_node, Target_Type (gnat_node)); post_error ("\\?use -fno-strict-aliasing switch for references", gnat_node); @@ -10211,7 +10355,7 @@ validate_unchecked_conversion (Node_Id gnat_node) || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type), target_alias_set))) { - post_error_ne ("?possible aliasing problem for type&", + post_error_ne ("??possible aliasing problem for type&", gnat_node, Target_Type (gnat_node)); post_error ("\\?use -fno-strict-aliasing switch for references", gnat_node); @@ -10401,27 +10545,6 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node) } } -/* Return a colon-separated list of encodings contained in encoded Ada - name. */ - -static const char * -extract_encoding (const char *name) -{ - char *encoding = (char *) ggc_alloc_atomic (strlen (name)); - get_encoding (name, encoding); - return encoding; -} - -/* Extract the Ada name from an encoded name. */ - -static const char * -decode_name (const char *name) -{ - char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60); - __gnat_decode (name, decoded, 0); - return decoded; -} - /* Post an error message. MSG is the error message, properly annotated. NODE is the node at which to post the error and the node to use for the '&' substitution. */ diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 952f032..846d20a 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * @@ -784,7 +784,7 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) tree context = NULL_TREE; struct deferred_decl_context_node *deferred_decl_context = NULL; - /* If explicitely asked to make DECL global or if it's an imported nested + /* If explicitly asked to make DECL global or if it's an imported nested object, short-circuit the regular Scope-based context computation. */ if (!((TREE_PUBLIC (decl) && DECL_EXTERNAL (decl)) || force_global == 1)) { @@ -836,7 +836,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) if (!deferred_decl_context) DECL_CONTEXT (decl) = context; - TREE_NO_WARNING (decl) = (No (gnat_node) || Warnings_Off (gnat_node)); + suppress_warning (decl, all_warnings, + No (gnat_node) || Warnings_Off (gnat_node)); /* Set the location of DECL and emit a declaration for it. */ if (Present (gnat_node) && !renaming_from_instantiation_p (gnat_node)) @@ -1276,7 +1277,7 @@ make_packable_type (tree type, bool in_record, unsigned int max_align) finish_record_type (new_type, nreverse (new_field_list), 2, false); relate_alias_sets (new_type, type, ALIAS_SET_COPY); - if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + if (gnat_encodings != DWARF_GNAT_ENCODINGS_ALL) SET_TYPE_DEBUG_TYPE (new_type, TYPE_DEBUG_TYPE (type)); else if (TYPE_STUB_DECL (type)) SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type), @@ -1547,7 +1548,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, TYPE_SIZE (record) = size ? size : orig_size; TYPE_SIZE_UNIT (record) = convert (sizetype, - size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record), + size_binop (EXACT_DIV_EXPR, TYPE_SIZE (record), bitsize_unit_node)); /* If we are changing the alignment and the input type is a record with @@ -1609,7 +1610,7 @@ maybe_pad_type (tree type, tree size, unsigned int align, } /* Make the inner type the debug type of the padded type. */ - if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + if (gnat_encodings != DWARF_GNAT_ENCODINGS_ALL) SET_TYPE_DEBUG_TYPE (record, maybe_debug_type (type)); /* Unless debugging information isn't being written for the input type, @@ -1637,14 +1638,14 @@ maybe_pad_type (tree type, tree size, unsigned int align, = create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype, size_unit, true, global_bindings_p (), !definition && global_bindings_p (), false, - false, true, true, NULL, gnat_entity); + false, true, true, NULL, gnat_entity, false); TYPE_SIZE_UNIT (record) = size_unit; } /* There is no need to show what we are a subtype of when outputting as few encodings as possible: regular debugging infomation makes this redundant. */ - if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + if (gnat_encodings == DWARF_GNAT_ENCODINGS_ALL) { tree marker = make_node (RECORD_TYPE); tree orig_name = TYPE_IDENTIFIER (type); @@ -1721,11 +1722,11 @@ built: if (Comes_From_Source (gnat_entity)) { if (is_component_type) - post_error_ne_tree ("component of& padded{ by ^ bits}?", + post_error_ne_tree ("component of& padded{ by ^ bits}??", gnat_entity, gnat_entity, size_diffop (size, orig_size)); else if (Present (gnat_error_node)) - post_error_ne_tree ("{^ }bits of & unused?", + post_error_ne_tree ("{^ }bits of & unused??", gnat_error_node, gnat_entity, size_diffop (size, orig_size)); } @@ -1970,7 +1971,6 @@ finish_record_type (tree record_type, tree field_list, int rep_level, { const enum tree_code orig_code = TREE_CODE (record_type); const bool had_size = TYPE_SIZE (record_type) != NULL_TREE; - const bool had_size_unit = TYPE_SIZE_UNIT (record_type) != NULL_TREE; const bool had_align = TYPE_ALIGN (record_type) > 0; /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE out just like a UNION_TYPE, since the size will be fixed. */ @@ -1997,9 +1997,6 @@ finish_record_type (tree record_type, tree field_list, int rep_level, if (!had_size) TYPE_SIZE (record_type) = bitsize_zero_node; - - if (!had_size_unit) - TYPE_SIZE_UNIT (record_type) = size_zero_node; } else { @@ -2155,19 +2152,22 @@ finish_record_type (tree record_type, tree field_list, int rep_level, /* We need to set the regular sizes if REP_LEVEL is one. */ if (rep_level == 1) { + /* We round TYPE_SIZE and TYPE_SIZE_UNIT up to TYPE_ALIGN separately + to avoid having very large masking constants in TYPE_SIZE_UNIT. */ + const unsigned int align = TYPE_ALIGN (record_type); + /* If this is a padding record, we never want to make the size smaller than what was specified in it, if any. */ - if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type)) + if (TYPE_IS_PADDING_P (record_type) && had_size) size = TYPE_SIZE (record_type); - - tree size_unit = had_size_unit - ? TYPE_SIZE_UNIT (record_type) - : convert (sizetype, - size_binop (CEIL_DIV_EXPR, size, - bitsize_unit_node)); - const unsigned int align = TYPE_ALIGN (record_type); + else + size = round_up (size, BITS_PER_UNIT); TYPE_SIZE (record_type) = variable_size (round_up (size, align)); + + tree size_unit + = convert (sizetype, + size_binop (EXACT_DIV_EXPR, size, bitsize_unit_node)); TYPE_SIZE_UNIT (record_type) = variable_size (round_up (size_unit, align / BITS_PER_UNIT)); } @@ -2274,7 +2274,7 @@ rest_of_record_type_compilation (tree record_type) /* If this record type is of variable size, make a parallel record type that will tell the debugger how the former is laid out (see exp_dbug.ads). */ - if (var_size && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + if (var_size && gnat_encodings == DWARF_GNAT_ENCODINGS_ALL) { tree new_record_type = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE @@ -3543,9 +3543,6 @@ finish_subprog_decl (tree decl, tree asm_name, tree type) DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (type); DECL_RESULT (decl) = result_decl; - /* Propagate the "const" property. */ - TREE_READONLY (decl) = TYPE_READONLY (type); - /* Propagate the "pure" property. */ DECL_PURE_P (decl) = TYPE_RESTRICT (type); @@ -7016,8 +7013,7 @@ def_builtin_1 (enum built_in_function fncode, return; gcc_assert ((!both_p && !fallback_p) - || !strncmp (name, "__builtin_", - strlen ("__builtin_"))); + || startswith (name, "__builtin_")); libname = name + strlen ("__builtin_"); decl = add_builtin_function (name, fntype, fncode, fnclass, diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 316033b..e8ed4b2 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2020, Free Software Foundation, Inc. * + * Copyright (C) 1992-2021, 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- * @@ -1301,11 +1301,11 @@ build_binary_op (enum tree_code op_code, tree result_type, if (TYPE_VOLATILE (operation_type)) TREE_THIS_VOLATILE (result) = 1; } - else - TREE_CONSTANT (result) - |= (TREE_CONSTANT (left_operand) && TREE_CONSTANT (right_operand)); + else if (TREE_CONSTANT (left_operand) && TREE_CONSTANT (right_operand)) + TREE_CONSTANT (result) = 1; - TREE_SIDE_EFFECTS (result) |= has_side_effects; + if (has_side_effects) + TREE_SIDE_EFFECTS (result) = 1; /* If we are working with modular types, perform the MOD operation if something above hasn't eliminated the need for it. */ @@ -1528,7 +1528,9 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) result = build_fold_addr_expr (operand); } - TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand); + if (TREE_CONSTANT (operand) || staticp (operand)) + TREE_CONSTANT (result) = 1; + break; case INDIRECT_REF: @@ -1957,14 +1959,19 @@ gnat_build_constructor (tree type, vec<constructor_elt, va_gc> *v) the elements along the way for possible sorting purposes below. */ FOR_EACH_CONSTRUCTOR_ELT (v, n_elmts, obj, val) { - /* The predicate must be in keeping with output_constructor. */ + /* The predicate must be in keeping with output_constructor and, unlike + initializer_constant_valid_p, we accept "&{...}" because we'll put + the CONSTRUCTOR into the constant pool during gimplification. */ if ((!TREE_CONSTANT (val) && !TREE_STATIC (val)) || (TREE_CODE (type) == RECORD_TYPE && CONSTRUCTOR_BITFIELD_P (obj) && !initializer_constant_valid_for_bitfield_p (val)) - || !initializer_constant_valid_p (val, - TREE_TYPE (val), - TYPE_REVERSE_STORAGE_ORDER (type))) + || (!initializer_constant_valid_p (val, + TREE_TYPE (val), + TYPE_REVERSE_STORAGE_ORDER (type)) + && !(TREE_CODE (val) == ADDR_EXPR + && TREE_CODE (TREE_OPERAND (val, 0)) == CONSTRUCTOR + && TREE_CONSTANT (TREE_OPERAND (val, 0))))) allconstant = false; if (!TREE_READONLY (val)) @@ -2064,7 +2071,9 @@ build_simple_component_ref (tree record, tree field, bool no_fold) need to warn since this will be done on trying to declare the object. */ if (TREE_CODE (DECL_FIELD_OFFSET (field)) == INTEGER_CST && TREE_OVERFLOW (DECL_FIELD_OFFSET (field))) - return NULL_TREE; + return build1 (NULL_EXPR, TREE_TYPE (field), + build_call_raise (SE_Object_Too_Large, Empty, + N_Raise_Storage_Error)); ref = build3 (COMPONENT_REF, TREE_TYPE (field), record, field, NULL_TREE); @@ -2098,7 +2107,7 @@ build_simple_component_ref (tree record, tree field, bool no_fold) return fold (ref); } -/* Likewise, but return NULL_EXPR and generate a Constraint_Error if the +/* Likewise, but return NULL_EXPR and generate a Program_Error if the field is not found in the record. */ tree @@ -2108,10 +2117,13 @@ build_component_ref (tree record, tree field, bool no_fold) if (ref) return ref; - /* Assume this is an invalid user field so raise Constraint_Error. */ + /* The missing field should have been detected in the front-end. */ + gigi_checking_assert (false); + + /* Assume this is an invalid user field so raise Program_Error. */ return build1 (NULL_EXPR, TREE_TYPE (field), - build_call_raise (CE_Discriminant_Check_Failed, Empty, - N_Raise_Constraint_Error)); + build_call_raise (PE_Explicit_Raise, Empty, + N_Raise_Program_Error)); } /* Helper for build_call_alloc_dealloc, with arguments to be interpreted @@ -2676,10 +2688,13 @@ gnat_stabilize_reference_1 (tree e, void *data) gcc_unreachable (); } + /* See gnat_rewrite_reference below for the rationale. */ TREE_READONLY (result) = TREE_READONLY (e); - TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e); TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e); + if (TREE_SIDE_EFFECTS (e)) + TREE_SIDE_EFFECTS (result) = 1; + return result; } @@ -2796,18 +2811,18 @@ gnat_rewrite_reference (tree ref, rewrite_fn func, void *data, tree *init) gcc_unreachable (); } - /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression - may not be sustained across some paths, such as the way via build1 for - INDIRECT_REF. We reset those flags here in the general case, which is - consistent with the GCC version of this routine. + /* TREE_READONLY and TREE_THIS_VOLATILE set on the initial expression may + not be sustained across some paths, such as the one for INDIRECT_REF. Special care should be taken regarding TREE_SIDE_EFFECTS, because some paths introduce side-effects where there was none initially (e.g. if a SAVE_EXPR is built) and we also want to keep track of that. */ TREE_READONLY (result) = TREE_READONLY (ref); - TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref); TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref); + if (TREE_SIDE_EFFECTS (ref)) + TREE_SIDE_EFFECTS (result) = 1; + if (code == INDIRECT_REF || code == UNCONSTRAINED_ARRAY_REF || code == ARRAY_REF @@ -2946,6 +2961,17 @@ gnat_invariant_expr (tree expr) if (TREE_CONSTANT (expr)) return fold_convert (type, expr); + /* Deal with aligning patterns. */ + if (TREE_CODE (expr) == BIT_AND_EXPR + && TREE_CONSTANT (TREE_OPERAND (expr, 1))) + { + tree op0 = gnat_invariant_expr (TREE_OPERAND (expr, 0)); + if (op0) + return fold_build2 (BIT_AND_EXPR, type, op0, TREE_OPERAND (expr, 1)); + else + return NULL_TREE; + } + /* Deal with addition or subtraction of constants. */ if (is_simple_additive_expression (expr, &add, &cst, &minus_p)) { |