diff --git a/ChangeLog b/ChangeLog index 6279013362d1..6131707b9f15 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2025-11-30 Jose E. Marchesi + + * MAINTAINERS: Add Algol 68 subsystems. + * SECURITY.txt: add libga68 to list of libraries. + 2025-11-20 Claudio Bantaloukas * MAINTAINERS: Add myself in forge integration maintainers diff --git a/MAINTAINERS b/MAINTAINERS index ae451ae18182..22d4172c4695 100644 --- a/MAINTAINERS +++ b/MAINTAINERS @@ -173,6 +173,7 @@ objective-c/c++ Mike Stump objective-c/c++ Iain Sandoe Rust Arthur Cohen Rust Philip Herron +Algol 68 Jose E. Marchesi Various Maintainers @@ -181,6 +182,7 @@ libcpp Per Bothner libcpp All C and C++ front end maintainers libcpp David Malcolm fp-bit Ian Lance Taylor +libga68 Jose E. Marchesi libgcc Ian Lance Taylor libgo Ian Lance Taylor libgomp Jakub Jelinek diff --git a/Makefile.def b/Makefile.def index e7f33345aa82..627121e87bc8 100644 --- a/Makefile.def +++ b/Makefile.def @@ -205,6 +205,7 @@ target_modules = { module= zlib; bootstrap=true; }; target_modules = { module= rda; }; target_modules = { module= libada; }; target_modules = { module= libgm2; lib_path=.libs; }; +target_modules = { module= libga68; lib_path=.libs; }; target_modules = { module= libgomp; bootstrap= true; lib_path=.libs; }; target_modules = { module= libitm; lib_path=.libs; }; target_modules = { module= libatomic; bootstrap=true; lib_path=.libs; }; @@ -313,6 +314,8 @@ flags_to_pass = { flag= GNATBIND ; }; flags_to_pass = { flag= GNATMAKE ; }; flags_to_pass = { flag= GDC ; }; flags_to_pass = { flag= GDCFLAGS ; }; +flags_to_pass = { flag= GA68 ; }; +flags_to_pass = { flag= GA68FLAGS ; }; // Target tools flags_to_pass = { flag= AR_FOR_TARGET ; }; @@ -329,6 +332,8 @@ flags_to_pass = { flag= GOC_FOR_TARGET ; }; flags_to_pass = { flag= GOCFLAGS_FOR_TARGET ; }; flags_to_pass = { flag= GDC_FOR_TARGET ; }; flags_to_pass = { flag= GDCFLAGS_FOR_TARGET ; }; +flags_to_pass = { flag= GA68_FOR_TARGET ; }; +flags_to_pass = { flag= GA68FLAGS_FOR_TARGET ; }; flags_to_pass = { flag= GM2_FOR_TARGET ; }; flags_to_pass = { flag= GM2FLAGS_FOR_TARGET ; }; flags_to_pass = { flag= LD_FOR_TARGET ; }; @@ -678,6 +683,7 @@ dependencies = { module=configure-target-libstdc++-v3; on=configure-target-libgo dependencies = { module=configure-target-libsanitizer; on=all-target-libstdc++-v3; }; dependencies = { module=configure-target-libvtv; on=all-target-libstdc++-v3; }; dependencies = { module=configure-target-libgrust; on=all-target-libstdc++-v3; }; +dependencies = { module=configure-target-libga68; on=all-target-libstdc++-v3; }; // parallel_list.o and parallel_settings.o depend on omp.h, which is // generated by the libgomp configure. Unfortunately, due to the use of // recursive make, we can't be that specific. @@ -736,6 +742,8 @@ languages = { language=jit; gcc-check-target=check-jit; }; languages = { language=rust; gcc-check-target=check-rust; }; languages = { language=cobol; gcc-check-target=check-cobol; lib-check-target=check-target-libgcobol; }; +languages = { language=algol68; gcc-check-target=check-algol68; + lib-check-target=check-target-libga68; }; // Toplevel bootstrap bootstrap_stage = { id=1 ; }; diff --git a/Makefile.in b/Makefile.in index 15f7413e9973..ef49d3a4c032 100644 --- a/Makefile.in +++ b/Makefile.in @@ -160,6 +160,8 @@ BUILD_EXPORTS = \ CXX="$(CXX_FOR_BUILD)"; export CXX; \ CXXFLAGS="$(CXXFLAGS_FOR_BUILD)"; export CXXFLAGS; \ GFORTRAN="$(GFORTRAN_FOR_BUILD)"; export GFORTRAN; \ + GA68="$(GA68_FOR_BUILD)"; export GA68; \ + GA68FLAGS="$(GA68FLAGS_FOR_BUILD)"; export GA68FLAGS; \ GOC="$(GOC_FOR_BUILD)"; export GOC; \ GOCFLAGS="$(GOCFLAGS_FOR_BUILD)"; export GOCFLAGS; \ GDC="$(GDC_FOR_BUILD)"; export GDC; \ @@ -203,6 +205,7 @@ HOST_EXPORTS = \ CXX="$(CXX)"; export CXX; \ CXXFLAGS="$(CXXFLAGS)"; export CXXFLAGS; \ GFORTRAN="$(GFORTRAN)"; export GFORTRAN; \ + GA68="$(GA68)"; export GA68; \ GOC="$(GOC)"; export GOC; \ GDC="$(GDC)"; export GDC; \ GM2="$(GM2)"; export GM2; \ @@ -278,6 +281,11 @@ POSTSTAGE1_HOST_EXPORTS = \ CC_FOR_BUILD="$$CC"; export CC_FOR_BUILD; \ $(POSTSTAGE1_CXX_EXPORT) \ $(LTO_EXPORTS) \ + GA68="$$r/$(HOST_SUBDIR)/prev-gcc/ga68$(exeext) -B$$r/$(HOST_SUBDIR)/prev-gcc/ \ + -B$(build_tooldir)/bin/ $(GA68FLAGS_FOR_TARGET) \ + -B$$r/prev-$(TARGET_SUBDIR)/libga68/.libs"; \ + export GA68; \ + GA68_FOR_BUILD="$$GA68"; export GA68_FOR_BUILD; \ GDC="$$r/$(HOST_SUBDIR)/prev-gcc/gdc$(exeext) -B$$r/$(HOST_SUBDIR)/prev-gcc/ \ -B$(build_tooldir)/bin/ $(GDCFLAGS_FOR_TARGET) \ -B$$r/prev-$(TARGET_SUBDIR)/libphobos/libdruntime/gcc \ @@ -310,6 +318,7 @@ BASE_TARGET_EXPORTS = \ CPPFLAGS="$(CPPFLAGS_FOR_TARGET)"; export CPPFLAGS; \ CXXFLAGS="$(CXXFLAGS_FOR_TARGET)"; export CXXFLAGS; \ GFORTRAN="$(GFORTRAN_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GFORTRAN; \ + GA68="$(GA68_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GA68; \ GOC="$(GOC_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GOC; \ GDC="$(GDC_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GDC; \ GM2="$(GM2_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GM2; \ @@ -380,6 +389,7 @@ CXX_FOR_BUILD = @CXX_FOR_BUILD@ DLLTOOL_FOR_BUILD = @DLLTOOL_FOR_BUILD@ DSYMUTIL_FOR_BUILD = @DSYMUTIL_FOR_BUILD@ GFORTRAN_FOR_BUILD = @GFORTRAN_FOR_BUILD@ +GA68_FOR_BUILD = @GA68_FOR_BUILD@ GOC_FOR_BUILD = @GOC_FOR_BUILD@ GDC_FOR_BUILD = @GDC_FOR_BUILD@ GM2_FOR_BUILD = @GM2_FOR_BUILD@ @@ -443,6 +453,7 @@ STRIP = @STRIP@ WINDRES = @WINDRES@ WINDMC = @WINDMC@ +GA68 = @GA68@ GDC = @GDC@ GNATBIND = @GNATBIND@ GNATMAKE = @GNATMAKE@ @@ -453,6 +464,7 @@ LIBCFLAGS = $(CFLAGS) CXXFLAGS = @CXXFLAGS@ LIBCXXFLAGS = $(CXXFLAGS) -fno-implicit-templates GOCFLAGS = $(CFLAGS) +GA68FLAGS = @GA68FLAGS@ GDCFLAGS = @GDCFLAGS@ GM2FLAGS = $(CFLAGS) @@ -678,6 +690,7 @@ CXX_FOR_TARGET=$(STAGE_CC_WRAPPER) @CXX_FOR_TARGET@ RAW_CXX_FOR_TARGET=$(STAGE_CC_WRAPPER) @RAW_CXX_FOR_TARGET@ GFORTRAN_FOR_TARGET=$(STAGE_CC_WRAPPER) @GFORTRAN_FOR_TARGET@ GOC_FOR_TARGET=$(STAGE_CC_WRAPPER) @GOC_FOR_TARGET@ +GA68_FOR_TARGET=$(STAGE_CC_WRAPPER) @GA68_FOR_TARGET@ GDC_FOR_TARGET=$(STAGE_CC_WRAPPER) @GDC_FOR_TARGET@ GM2_FOR_TARGET=$(STAGE_CC_WRAPPER) @GM2_FOR_TARGET@ DLLTOOL_FOR_TARGET=@DLLTOOL_FOR_TARGET@ @@ -707,6 +720,7 @@ LIBCXXFLAGS_FOR_TARGET = $(CXXFLAGS_FOR_TARGET) -fno-implicit-templates LDFLAGS_FOR_TARGET = @LDFLAGS_FOR_TARGET@ GM2FLAGS_FOR_TARGET = -O2 -g GOCFLAGS_FOR_TARGET = -O2 -g +GA68FLAGS_FOR_TARGET = -O2 -g GDCFLAGS_FOR_TARGET = -O2 -g FLAGS_FOR_TARGET = @FLAGS_FOR_TARGET@ @@ -732,7 +746,7 @@ all: # This is the list of directories that may be needed in RPATH_ENVVAR # so that programs built for the target machine work. -TARGET_LIB_PATH = $(TARGET_LIB_PATH_libstdc++-v3)$(TARGET_LIB_PATH_libsanitizer)$(TARGET_LIB_PATH_libvtv)$(TARGET_LIB_PATH_libssp)$(TARGET_LIB_PATH_libphobos)$(TARGET_LIB_PATH_libgm2)$(TARGET_LIB_PATH_libgomp)$(TARGET_LIB_PATH_libitm)$(TARGET_LIB_PATH_libatomic)$(HOST_LIB_PATH_gcc) +TARGET_LIB_PATH = $(TARGET_LIB_PATH_libstdc++-v3)$(TARGET_LIB_PATH_libsanitizer)$(TARGET_LIB_PATH_libvtv)$(TARGET_LIB_PATH_libssp)$(TARGET_LIB_PATH_libphobos)$(TARGET_LIB_PATH_libgm2)$(TARGET_LIB_PATH_libga68)$(TARGET_LIB_PATH_libgomp)$(TARGET_LIB_PATH_libitm)$(TARGET_LIB_PATH_libatomic)$(HOST_LIB_PATH_gcc) @if target-libstdc++-v3 TARGET_LIB_PATH_libstdc++-v3 = $$r/$(TARGET_SUBDIR)/libstdc++-v3/src/.libs: @@ -758,6 +772,10 @@ TARGET_LIB_PATH_libphobos = $$r/$(TARGET_SUBDIR)/libphobos/src/.libs: TARGET_LIB_PATH_libgm2 = $$r/$(TARGET_SUBDIR)/libgm2/.libs: @endif target-libgm2 +@if target-libga68 +TARGET_LIB_PATH_libga68 = $$r/$(TARGET_SUBDIR)/libga68/.libs: +@endif target-libga68 + @if target-libgomp TARGET_LIB_PATH_libgomp = $$r/$(TARGET_SUBDIR)/libgomp/.libs: @endif target-libgomp @@ -889,6 +907,8 @@ BASE_FLAGS_TO_PASS = \ "GNATMAKE=$(GNATMAKE)" \ "GDC=$(GDC)" \ "GDCFLAGS=$(GDCFLAGS)" \ + "GA68=$(GA68)" \ + "GA68FLAGS=$(GA68FLAGS)" \ "AR_FOR_TARGET=$(AR_FOR_TARGET)" \ "AS_FOR_TARGET=$(AS_FOR_TARGET)" \ "CC_FOR_TARGET=$(CC_FOR_TARGET)" \ @@ -903,6 +923,8 @@ BASE_FLAGS_TO_PASS = \ "GOCFLAGS_FOR_TARGET=$(GOCFLAGS_FOR_TARGET)" \ "GDC_FOR_TARGET=$(GDC_FOR_TARGET)" \ "GDCFLAGS_FOR_TARGET=$(GDCFLAGS_FOR_TARGET)" \ + "GA68_FOR_TARGET=$(GA68_FOR_TARGET)" \ + "GA68FLAGS_FOR_TARGET=$(GA68FLAGS_FOR_TARGET)" \ "GM2_FOR_TARGET=$(GM2_FOR_TARGET)" \ "GM2FLAGS_FOR_TARGET=$(GM2FLAGS_FOR_TARGET)" \ "LD_FOR_TARGET=$(LD_FOR_TARGET)" \ @@ -977,6 +999,7 @@ EXTRA_HOST_FLAGS = \ 'DSYMUTIL=$(DSYMUTIL)' \ 'GFORTRAN=$(GFORTRAN)' \ 'GOC=$(GOC)' \ + 'GA68=$(GA68)' \ 'GDC=$(GDC)' \ 'GM2=$(GM2)' \ 'LD=$(LD)' \ @@ -1005,6 +1028,7 @@ STAGE1_FLAGS_TO_PASS = \ POSTSTAGE1_FLAGS_TO_PASS = \ CC="$${CC}" CC_FOR_BUILD="$${CC_FOR_BUILD}" \ CXX="$${CXX}" CXX_FOR_BUILD="$${CXX_FOR_BUILD}" \ + GA68="$${GA68}" GA68_FOR_BUILD="$${GA68_FOR_BUILD}" \ GDC="$${GDC}" GDC_FOR_BUILD="$${GDC_FOR_BUILD}" \ GM2="$${GM2}" GM2_FOR_BUILD="$${GM2_FOR_BUILD}" \ GNATBIND="$${GNATBIND}" \ @@ -1040,6 +1064,8 @@ EXTRA_TARGET_FLAGS = \ 'GFORTRAN=$$(GFORTRAN_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \ 'GOC=$$(GOC_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \ 'GOCFLAGS=$$(GOCFLAGS_FOR_TARGET)' \ + 'GA68=$$(GA68_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \ + 'GA68FLAGS=$$(GA68FLAGS_FOR_TARGET)' \ 'GDC=$$(GDC_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \ 'GDCFLAGS=$$(GDCFLAGS_FOR_TARGET)' \ 'GM2=$$(GM2_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \ @@ -1161,6 +1187,7 @@ configure-target: \ maybe-configure-target-rda \ maybe-configure-target-libada \ maybe-configure-target-libgm2 \ + maybe-configure-target-libga68 \ maybe-configure-target-libgomp \ maybe-configure-target-libitm \ maybe-configure-target-libatomic \ @@ -1361,6 +1388,7 @@ all-target: maybe-all-target-zlib all-target: maybe-all-target-rda all-target: maybe-all-target-libada all-target: maybe-all-target-libgm2 +all-target: maybe-all-target-libga68 @if target-libgomp-no-bootstrap all-target: maybe-all-target-libgomp @endif target-libgomp-no-bootstrap @@ -1464,6 +1492,7 @@ info-target: maybe-info-target-zlib info-target: maybe-info-target-rda info-target: maybe-info-target-libada info-target: maybe-info-target-libgm2 +info-target: maybe-info-target-libga68 info-target: maybe-info-target-libgomp info-target: maybe-info-target-libitm info-target: maybe-info-target-libatomic @@ -1558,6 +1587,7 @@ dvi-target: maybe-dvi-target-zlib dvi-target: maybe-dvi-target-rda dvi-target: maybe-dvi-target-libada dvi-target: maybe-dvi-target-libgm2 +dvi-target: maybe-dvi-target-libga68 dvi-target: maybe-dvi-target-libgomp dvi-target: maybe-dvi-target-libitm dvi-target: maybe-dvi-target-libatomic @@ -1652,6 +1682,7 @@ pdf-target: maybe-pdf-target-zlib pdf-target: maybe-pdf-target-rda pdf-target: maybe-pdf-target-libada pdf-target: maybe-pdf-target-libgm2 +pdf-target: maybe-pdf-target-libga68 pdf-target: maybe-pdf-target-libgomp pdf-target: maybe-pdf-target-libitm pdf-target: maybe-pdf-target-libatomic @@ -1746,6 +1777,7 @@ html-target: maybe-html-target-zlib html-target: maybe-html-target-rda html-target: maybe-html-target-libada html-target: maybe-html-target-libgm2 +html-target: maybe-html-target-libga68 html-target: maybe-html-target-libgomp html-target: maybe-html-target-libitm html-target: maybe-html-target-libatomic @@ -1840,6 +1872,7 @@ TAGS-target: maybe-TAGS-target-zlib TAGS-target: maybe-TAGS-target-rda TAGS-target: maybe-TAGS-target-libada TAGS-target: maybe-TAGS-target-libgm2 +TAGS-target: maybe-TAGS-target-libga68 TAGS-target: maybe-TAGS-target-libgomp TAGS-target: maybe-TAGS-target-libitm TAGS-target: maybe-TAGS-target-libatomic @@ -1934,6 +1967,7 @@ install-info-target: maybe-install-info-target-zlib install-info-target: maybe-install-info-target-rda install-info-target: maybe-install-info-target-libada install-info-target: maybe-install-info-target-libgm2 +install-info-target: maybe-install-info-target-libga68 install-info-target: maybe-install-info-target-libgomp install-info-target: maybe-install-info-target-libitm install-info-target: maybe-install-info-target-libatomic @@ -2028,6 +2062,7 @@ install-dvi-target: maybe-install-dvi-target-zlib install-dvi-target: maybe-install-dvi-target-rda install-dvi-target: maybe-install-dvi-target-libada install-dvi-target: maybe-install-dvi-target-libgm2 +install-dvi-target: maybe-install-dvi-target-libga68 install-dvi-target: maybe-install-dvi-target-libgomp install-dvi-target: maybe-install-dvi-target-libitm install-dvi-target: maybe-install-dvi-target-libatomic @@ -2122,6 +2157,7 @@ install-pdf-target: maybe-install-pdf-target-zlib install-pdf-target: maybe-install-pdf-target-rda install-pdf-target: maybe-install-pdf-target-libada install-pdf-target: maybe-install-pdf-target-libgm2 +install-pdf-target: maybe-install-pdf-target-libga68 install-pdf-target: maybe-install-pdf-target-libgomp install-pdf-target: maybe-install-pdf-target-libitm install-pdf-target: maybe-install-pdf-target-libatomic @@ -2216,6 +2252,7 @@ install-html-target: maybe-install-html-target-zlib install-html-target: maybe-install-html-target-rda install-html-target: maybe-install-html-target-libada install-html-target: maybe-install-html-target-libgm2 +install-html-target: maybe-install-html-target-libga68 install-html-target: maybe-install-html-target-libgomp install-html-target: maybe-install-html-target-libitm install-html-target: maybe-install-html-target-libatomic @@ -2310,6 +2347,7 @@ installcheck-target: maybe-installcheck-target-zlib installcheck-target: maybe-installcheck-target-rda installcheck-target: maybe-installcheck-target-libada installcheck-target: maybe-installcheck-target-libgm2 +installcheck-target: maybe-installcheck-target-libga68 installcheck-target: maybe-installcheck-target-libgomp installcheck-target: maybe-installcheck-target-libitm installcheck-target: maybe-installcheck-target-libatomic @@ -2404,6 +2442,7 @@ mostlyclean-target: maybe-mostlyclean-target-zlib mostlyclean-target: maybe-mostlyclean-target-rda mostlyclean-target: maybe-mostlyclean-target-libada mostlyclean-target: maybe-mostlyclean-target-libgm2 +mostlyclean-target: maybe-mostlyclean-target-libga68 mostlyclean-target: maybe-mostlyclean-target-libgomp mostlyclean-target: maybe-mostlyclean-target-libitm mostlyclean-target: maybe-mostlyclean-target-libatomic @@ -2498,6 +2537,7 @@ clean-target: maybe-clean-target-zlib clean-target: maybe-clean-target-rda clean-target: maybe-clean-target-libada clean-target: maybe-clean-target-libgm2 +clean-target: maybe-clean-target-libga68 clean-target: maybe-clean-target-libgomp clean-target: maybe-clean-target-libitm clean-target: maybe-clean-target-libatomic @@ -2592,6 +2632,7 @@ distclean-target: maybe-distclean-target-zlib distclean-target: maybe-distclean-target-rda distclean-target: maybe-distclean-target-libada distclean-target: maybe-distclean-target-libgm2 +distclean-target: maybe-distclean-target-libga68 distclean-target: maybe-distclean-target-libgomp distclean-target: maybe-distclean-target-libitm distclean-target: maybe-distclean-target-libatomic @@ -2686,6 +2727,7 @@ maintainer-clean-target: maybe-maintainer-clean-target-zlib maintainer-clean-target: maybe-maintainer-clean-target-rda maintainer-clean-target: maybe-maintainer-clean-target-libada maintainer-clean-target: maybe-maintainer-clean-target-libgm2 +maintainer-clean-target: maybe-maintainer-clean-target-libga68 maintainer-clean-target: maybe-maintainer-clean-target-libgomp maintainer-clean-target: maybe-maintainer-clean-target-libitm maintainer-clean-target: maybe-maintainer-clean-target-libatomic @@ -2838,6 +2880,7 @@ check-target: \ maybe-check-target-rda \ maybe-check-target-libada \ maybe-check-target-libgm2 \ + maybe-check-target-libga68 \ maybe-check-target-libgomp \ maybe-check-target-libitm \ maybe-check-target-libatomic \ @@ -3036,6 +3079,7 @@ install-target: \ maybe-install-target-rda \ maybe-install-target-libada \ maybe-install-target-libgm2 \ + maybe-install-target-libga68 \ maybe-install-target-libgomp \ maybe-install-target-libitm \ maybe-install-target-libatomic \ @@ -3150,6 +3194,7 @@ install-strip-target: \ maybe-install-strip-target-rda \ maybe-install-strip-target-libada \ maybe-install-strip-target-libgm2 \ + maybe-install-strip-target-libga68 \ maybe-install-strip-target-libgomp \ maybe-install-strip-target-libitm \ maybe-install-strip-target-libatomic \ @@ -60201,6 +60246,491 @@ maintainer-clean-target-libgm2: +.PHONY: configure-target-libga68 maybe-configure-target-libga68 +maybe-configure-target-libga68: +@if gcc-bootstrap +configure-target-libga68: stage_current +@endif gcc-bootstrap +@if target-libga68 +maybe-configure-target-libga68: configure-target-libga68 +configure-target-libga68: + @: $(MAKE); $(unstage) + @r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + echo "Checking multilib configuration for libga68..."; \ + $(SHELL) $(srcdir)/mkinstalldirs $(TARGET_SUBDIR)/libga68; \ + $(CC_FOR_TARGET) --print-multi-lib > $(TARGET_SUBDIR)/libga68/multilib.tmp 2> /dev/null; \ + if test -r $(TARGET_SUBDIR)/libga68/multilib.out; then \ + if cmp -s $(TARGET_SUBDIR)/libga68/multilib.tmp $(TARGET_SUBDIR)/libga68/multilib.out; then \ + rm -f $(TARGET_SUBDIR)/libga68/multilib.tmp; \ + else \ + rm -f $(TARGET_SUBDIR)/libga68/Makefile; \ + mv $(TARGET_SUBDIR)/libga68/multilib.tmp $(TARGET_SUBDIR)/libga68/multilib.out; \ + fi; \ + else \ + mv $(TARGET_SUBDIR)/libga68/multilib.tmp $(TARGET_SUBDIR)/libga68/multilib.out; \ + fi; \ + test ! -f $(TARGET_SUBDIR)/libga68/Makefile || exit 0; \ + $(SHELL) $(srcdir)/mkinstalldirs $(TARGET_SUBDIR)/libga68; \ + $(NORMAL_TARGET_EXPORTS) \ + echo Configuring in $(TARGET_SUBDIR)/libga68; \ + cd "$(TARGET_SUBDIR)/libga68" || exit 1; \ + case $(srcdir) in \ + /* | [A-Za-z]:[\\/]*) topdir=$(srcdir) ;; \ + *) topdir=`echo $(TARGET_SUBDIR)/libga68/ | \ + sed -e 's,\./,,g' -e 's,[^/]*/,../,g' `$(srcdir) ;; \ + esac; \ + module_srcdir=libga68; \ + rm -f no-such-file || : ; \ + CONFIG_SITE=no-such-file $(SHELL) \ + $$s/$$module_srcdir/configure \ + --srcdir=$${topdir}/$$module_srcdir \ + $(TARGET_CONFIGARGS) --build=${build_alias} --host=${target_alias} \ + --target=${target_alias} \ + || exit 1 +@endif target-libga68 + + + + + +.PHONY: all-target-libga68 maybe-all-target-libga68 +maybe-all-target-libga68: +@if gcc-bootstrap +all-target-libga68: stage_current +@endif gcc-bootstrap +@if target-libga68 +TARGET-target-libga68=all +maybe-all-target-libga68: all-target-libga68 +all-target-libga68: configure-target-libga68 + @: $(MAKE); $(unstage) + @r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) $(EXTRA_TARGET_FLAGS) \ + $(TARGET-target-libga68)) +@endif target-libga68 + + + + + +.PHONY: check-target-libga68 maybe-check-target-libga68 +maybe-check-target-libga68: +@if target-libga68 +maybe-check-target-libga68: check-target-libga68 + +check-target-libga68: + @: $(MAKE); $(unstage) + @r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(TARGET_FLAGS_TO_PASS) check) + +@endif target-libga68 + +.PHONY: install-target-libga68 maybe-install-target-libga68 +maybe-install-target-libga68: +@if target-libga68 +maybe-install-target-libga68: install-target-libga68 + +install-target-libga68: installdirs + @: $(MAKE); $(unstage) + @r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(TARGET_FLAGS_TO_PASS) install) + +@endif target-libga68 + +.PHONY: install-strip-target-libga68 maybe-install-strip-target-libga68 +maybe-install-strip-target-libga68: +@if target-libga68 +maybe-install-strip-target-libga68: install-strip-target-libga68 + +install-strip-target-libga68: installdirs + @: $(MAKE); $(unstage) + @r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(TARGET_FLAGS_TO_PASS) install-strip) + +@endif target-libga68 + +# Other targets (info, dvi, pdf, etc.) + +.PHONY: maybe-info-target-libga68 info-target-libga68 +maybe-info-target-libga68: +@if target-libga68 +maybe-info-target-libga68: info-target-libga68 + +info-target-libga68: \ + configure-target-libga68 + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing info in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + info) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-dvi-target-libga68 dvi-target-libga68 +maybe-dvi-target-libga68: +@if target-libga68 +maybe-dvi-target-libga68: dvi-target-libga68 + +dvi-target-libga68: \ + configure-target-libga68 + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing dvi in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + dvi) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-pdf-target-libga68 pdf-target-libga68 +maybe-pdf-target-libga68: +@if target-libga68 +maybe-pdf-target-libga68: pdf-target-libga68 + +pdf-target-libga68: \ + configure-target-libga68 + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing pdf in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + pdf) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-html-target-libga68 html-target-libga68 +maybe-html-target-libga68: +@if target-libga68 +maybe-html-target-libga68: html-target-libga68 + +html-target-libga68: \ + configure-target-libga68 + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing html in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + html) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-TAGS-target-libga68 TAGS-target-libga68 +maybe-TAGS-target-libga68: +@if target-libga68 +maybe-TAGS-target-libga68: TAGS-target-libga68 + +TAGS-target-libga68: \ + configure-target-libga68 + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing TAGS in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + TAGS) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-install-info-target-libga68 install-info-target-libga68 +maybe-install-info-target-libga68: +@if target-libga68 +maybe-install-info-target-libga68: install-info-target-libga68 + +install-info-target-libga68: \ + configure-target-libga68 \ + info-target-libga68 + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing install-info in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + install-info) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-install-dvi-target-libga68 install-dvi-target-libga68 +maybe-install-dvi-target-libga68: +@if target-libga68 +maybe-install-dvi-target-libga68: install-dvi-target-libga68 + +install-dvi-target-libga68: \ + configure-target-libga68 \ + dvi-target-libga68 + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing install-dvi in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + install-dvi) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-install-pdf-target-libga68 install-pdf-target-libga68 +maybe-install-pdf-target-libga68: +@if target-libga68 +maybe-install-pdf-target-libga68: install-pdf-target-libga68 + +install-pdf-target-libga68: \ + configure-target-libga68 \ + pdf-target-libga68 + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing install-pdf in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + install-pdf) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-install-html-target-libga68 install-html-target-libga68 +maybe-install-html-target-libga68: +@if target-libga68 +maybe-install-html-target-libga68: install-html-target-libga68 + +install-html-target-libga68: \ + configure-target-libga68 \ + html-target-libga68 + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing install-html in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + install-html) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-installcheck-target-libga68 installcheck-target-libga68 +maybe-installcheck-target-libga68: +@if target-libga68 +maybe-installcheck-target-libga68: installcheck-target-libga68 + +installcheck-target-libga68: \ + configure-target-libga68 + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing installcheck in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + installcheck) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-mostlyclean-target-libga68 mostlyclean-target-libga68 +maybe-mostlyclean-target-libga68: +@if target-libga68 +maybe-mostlyclean-target-libga68: mostlyclean-target-libga68 + +mostlyclean-target-libga68: + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing mostlyclean in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + mostlyclean) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-clean-target-libga68 clean-target-libga68 +maybe-clean-target-libga68: +@if target-libga68 +maybe-clean-target-libga68: clean-target-libga68 + +clean-target-libga68: + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing clean in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + clean) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-distclean-target-libga68 distclean-target-libga68 +maybe-distclean-target-libga68: +@if target-libga68 +maybe-distclean-target-libga68: distclean-target-libga68 + +distclean-target-libga68: + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing distclean in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + distclean) \ + || exit 1 + +@endif target-libga68 + +.PHONY: maybe-maintainer-clean-target-libga68 maintainer-clean-target-libga68 +maybe-maintainer-clean-target-libga68: +@if target-libga68 +maybe-maintainer-clean-target-libga68: maintainer-clean-target-libga68 + +maintainer-clean-target-libga68: + @: $(MAKE); $(unstage) + @[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \ + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(NORMAL_TARGET_EXPORTS) \ + echo "Doing maintainer-clean in $(TARGET_SUBDIR)/libga68"; \ + for flag in $(EXTRA_TARGET_FLAGS); do \ + eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \ + done; \ + (cd $(TARGET_SUBDIR)/libga68 && \ + $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \ + "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \ + "RANLIB=$${RANLIB}" \ + "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \ + maintainer-clean) \ + || exit 1 + +@endif target-libga68 + + + + + .PHONY: configure-target-libgomp maybe-configure-target-libgomp maybe-configure-target-libgomp: @if gcc-bootstrap @@ -64336,6 +64866,14 @@ check-gcc-cobol: gcc-site.exp (cd gcc && $(MAKE) $(GCC_FLAGS_TO_PASS) check-cobol); check-cobol: check-gcc-cobol check-target-libgcobol +.PHONY: check-gcc-algol68 check-algol68 +check-gcc-algol68: gcc-site.exp + r=`${PWD_COMMAND}`; export r; \ + s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \ + $(HOST_EXPORTS) \ + (cd gcc && $(MAKE) $(GCC_FLAGS_TO_PASS) check-algol68); +check-algol68: check-gcc-algol68 check-target-libga68 + # The gcc part of install-no-fixedincludes, which relies on an intimate # knowledge of how a number of gcc internal targets (inter)operate. Delegate. @@ -67877,6 +68415,7 @@ configure-stageautofeedback-target-zlib: maybe-all-stageautofeedback-gcc configure-target-rda: stage_last configure-target-libada: stage_last configure-target-libgm2: stage_last +configure-target-libga68: stage_last configure-stage1-target-libgomp: maybe-all-stage1-gcc configure-stage2-target-libgomp: maybe-all-stage2-gcc configure-stage3-target-libgomp: maybe-all-stage3-gcc @@ -67921,6 +68460,7 @@ configure-target-zlib: maybe-all-gcc configure-target-rda: maybe-all-gcc configure-target-libada: maybe-all-gcc configure-target-libgm2: maybe-all-gcc +configure-target-libga68: maybe-all-gcc configure-target-libgomp: maybe-all-gcc configure-target-libitm: maybe-all-gcc configure-target-libatomic: maybe-all-gcc @@ -69221,6 +69761,9 @@ all-target-libgm2: maybe-all-target-libatomic @unless target-libstdc++-v3-bootstrap configure-target-libgrust: maybe-all-target-libstdc++-v3 @endunless target-libstdc++-v3-bootstrap +@unless target-libstdc++-v3-bootstrap +configure-target-libga68: maybe-all-target-libstdc++-v3 +@endunless target-libstdc++-v3-bootstrap @unless target-libbacktrace-bootstrap configure-target-libgfortran: maybe-all-target-libbacktrace @endunless target-libbacktrace-bootstrap @@ -69284,6 +69827,7 @@ all-target-libgo: maybe-all-target-libatomic configure-target-libgm2: maybe-all-target-libstdc++-v3 all-target-libgm2: maybe-all-target-libatomic configure-target-libgrust: maybe-all-target-libstdc++-v3 +configure-target-libga68: maybe-all-target-libstdc++-v3 configure-target-newlib: maybe-all-binutils configure-target-newlib: maybe-all-ld configure-target-libgfortran: maybe-all-target-libbacktrace @@ -69390,6 +69934,7 @@ configure-target-zlib: maybe-all-target-libgcc configure-target-rda: maybe-all-target-libgcc configure-target-libada: maybe-all-target-libgcc configure-target-libgm2: maybe-all-target-libgcc +configure-target-libga68: maybe-all-target-libgcc configure-target-libgomp: maybe-all-target-libgcc configure-target-libitm: maybe-all-target-libgcc configure-target-libatomic: maybe-all-target-libgcc @@ -69436,6 +69981,8 @@ configure-target-libada: maybe-all-target-newlib maybe-all-target-libgloss configure-target-libgm2: maybe-all-target-newlib maybe-all-target-libgloss +configure-target-libga68: maybe-all-target-newlib maybe-all-target-libgloss + configure-target-libgomp: maybe-all-target-newlib maybe-all-target-libgloss configure-target-libitm: maybe-all-target-newlib maybe-all-target-libgloss @@ -69533,6 +70080,7 @@ configure-target-zlib: maybe-all-target-libatomic configure-target-rda: maybe-all-target-libatomic configure-target-libada: maybe-all-target-libatomic configure-target-libgm2: maybe-all-target-libatomic +configure-target-libga68: maybe-all-target-libatomic configure-target-libgomp: maybe-all-target-libatomic configure-target-libitm: maybe-all-target-libatomic configure-target-libgrust: maybe-all-target-libatomic diff --git a/Makefile.tpl b/Makefile.tpl index f4f0fc58df4f..362a21b2aff1 100644 --- a/Makefile.tpl +++ b/Makefile.tpl @@ -163,6 +163,8 @@ BUILD_EXPORTS = \ CXX="$(CXX_FOR_BUILD)"; export CXX; \ CXXFLAGS="$(CXXFLAGS_FOR_BUILD)"; export CXXFLAGS; \ GFORTRAN="$(GFORTRAN_FOR_BUILD)"; export GFORTRAN; \ + GA68="$(GA68_FOR_BUILD)"; export GA68; \ + GA68FLAGS="$(GA68FLAGS_FOR_BUILD)"; export GA68FLAGS; \ GOC="$(GOC_FOR_BUILD)"; export GOC; \ GOCFLAGS="$(GOCFLAGS_FOR_BUILD)"; export GOCFLAGS; \ GDC="$(GDC_FOR_BUILD)"; export GDC; \ @@ -206,6 +208,7 @@ HOST_EXPORTS = \ CXX="$(CXX)"; export CXX; \ CXXFLAGS="$(CXXFLAGS)"; export CXXFLAGS; \ GFORTRAN="$(GFORTRAN)"; export GFORTRAN; \ + GA68="$(GA68)"; export GA68; \ GOC="$(GOC)"; export GOC; \ GDC="$(GDC)"; export GDC; \ GM2="$(GM2)"; export GM2; \ @@ -281,6 +284,11 @@ POSTSTAGE1_HOST_EXPORTS = \ CC_FOR_BUILD="$$CC"; export CC_FOR_BUILD; \ $(POSTSTAGE1_CXX_EXPORT) \ $(LTO_EXPORTS) \ + GA68="$$r/$(HOST_SUBDIR)/prev-gcc/ga68$(exeext) -B$$r/$(HOST_SUBDIR)/prev-gcc/ \ + -B$(build_tooldir)/bin/ $(GA68FLAGS_FOR_TARGET) \ + -B$$r/prev-$(TARGET_SUBDIR)/libga68/.libs"; \ + export GA68; \ + GA68_FOR_BUILD="$$GA68"; export GA68_FOR_BUILD; \ GDC="$$r/$(HOST_SUBDIR)/prev-gcc/gdc$(exeext) -B$$r/$(HOST_SUBDIR)/prev-gcc/ \ -B$(build_tooldir)/bin/ $(GDCFLAGS_FOR_TARGET) \ -B$$r/prev-$(TARGET_SUBDIR)/libphobos/libdruntime/gcc \ @@ -313,6 +321,7 @@ BASE_TARGET_EXPORTS = \ CPPFLAGS="$(CPPFLAGS_FOR_TARGET)"; export CPPFLAGS; \ CXXFLAGS="$(CXXFLAGS_FOR_TARGET)"; export CXXFLAGS; \ GFORTRAN="$(GFORTRAN_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GFORTRAN; \ + GA68="$(GA68_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GA68; \ GOC="$(GOC_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GOC; \ GDC="$(GDC_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GDC; \ GM2="$(GM2_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GM2; \ @@ -383,6 +392,7 @@ CXX_FOR_BUILD = @CXX_FOR_BUILD@ DLLTOOL_FOR_BUILD = @DLLTOOL_FOR_BUILD@ DSYMUTIL_FOR_BUILD = @DSYMUTIL_FOR_BUILD@ GFORTRAN_FOR_BUILD = @GFORTRAN_FOR_BUILD@ +GA68_FOR_BUILD = @GA68_FOR_BUILD@ GOC_FOR_BUILD = @GOC_FOR_BUILD@ GDC_FOR_BUILD = @GDC_FOR_BUILD@ GM2_FOR_BUILD = @GM2_FOR_BUILD@ @@ -446,6 +456,7 @@ STRIP = @STRIP@ WINDRES = @WINDRES@ WINDMC = @WINDMC@ +GA68 = @GA68@ GDC = @GDC@ GNATBIND = @GNATBIND@ GNATMAKE = @GNATMAKE@ @@ -456,6 +467,7 @@ LIBCFLAGS = $(CFLAGS) CXXFLAGS = @CXXFLAGS@ LIBCXXFLAGS = $(CXXFLAGS) -fno-implicit-templates GOCFLAGS = $(CFLAGS) +GA68FLAGS = @GA68FLAGS@ GDCFLAGS = @GDCFLAGS@ GM2FLAGS = $(CFLAGS) @@ -601,6 +613,7 @@ CXX_FOR_TARGET=$(STAGE_CC_WRAPPER) @CXX_FOR_TARGET@ RAW_CXX_FOR_TARGET=$(STAGE_CC_WRAPPER) @RAW_CXX_FOR_TARGET@ GFORTRAN_FOR_TARGET=$(STAGE_CC_WRAPPER) @GFORTRAN_FOR_TARGET@ GOC_FOR_TARGET=$(STAGE_CC_WRAPPER) @GOC_FOR_TARGET@ +GA68_FOR_TARGET=$(STAGE_CC_WRAPPER) @GA68_FOR_TARGET@ GDC_FOR_TARGET=$(STAGE_CC_WRAPPER) @GDC_FOR_TARGET@ GM2_FOR_TARGET=$(STAGE_CC_WRAPPER) @GM2_FOR_TARGET@ DLLTOOL_FOR_TARGET=@DLLTOOL_FOR_TARGET@ @@ -630,6 +643,7 @@ LIBCXXFLAGS_FOR_TARGET = $(CXXFLAGS_FOR_TARGET) -fno-implicit-templates LDFLAGS_FOR_TARGET = @LDFLAGS_FOR_TARGET@ GM2FLAGS_FOR_TARGET = -O2 -g GOCFLAGS_FOR_TARGET = -O2 -g +GA68FLAGS_FOR_TARGET = -O2 -g GDCFLAGS_FOR_TARGET = -O2 -g FLAGS_FOR_TARGET = @FLAGS_FOR_TARGET@ @@ -734,6 +748,7 @@ EXTRA_HOST_FLAGS = \ 'DSYMUTIL=$(DSYMUTIL)' \ 'GFORTRAN=$(GFORTRAN)' \ 'GOC=$(GOC)' \ + 'GA68=$(GA68)' \ 'GDC=$(GDC)' \ 'GM2=$(GM2)' \ 'LD=$(LD)' \ @@ -762,6 +777,7 @@ STAGE1_FLAGS_TO_PASS = \ POSTSTAGE1_FLAGS_TO_PASS = \ CC="$${CC}" CC_FOR_BUILD="$${CC_FOR_BUILD}" \ CXX="$${CXX}" CXX_FOR_BUILD="$${CXX_FOR_BUILD}" \ + GA68="$${GA68}" GA68_FOR_BUILD="$${GA68_FOR_BUILD}" \ GDC="$${GDC}" GDC_FOR_BUILD="$${GDC_FOR_BUILD}" \ GM2="$${GM2}" GM2_FOR_BUILD="$${GM2_FOR_BUILD}" \ GNATBIND="$${GNATBIND}" \ @@ -797,6 +813,8 @@ EXTRA_TARGET_FLAGS = \ 'GFORTRAN=$$(GFORTRAN_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \ 'GOC=$$(GOC_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \ 'GOCFLAGS=$$(GOCFLAGS_FOR_TARGET)' \ + 'GA68=$$(GA68_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \ + 'GA68FLAGS=$$(GA68FLAGS_FOR_TARGET)' \ 'GDC=$$(GDC_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \ 'GDCFLAGS=$$(GDCFLAGS_FOR_TARGET)' \ 'GM2=$$(GM2_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \ diff --git a/SECURITY.txt b/SECURITY.txt index b38425ea2238..910e969a77b1 100644 --- a/SECURITY.txt +++ b/SECURITY.txt @@ -85,6 +85,7 @@ Language runtime libraries * libcpp * libdecnumber * libffi + * libga68 * libgcc * libgfortran * libgm2 diff --git a/config/ChangeLog b/config/ChangeLog index 0a70422182b7..59cc1f4dea44 100644 --- a/config/ChangeLog +++ b/config/ChangeLog @@ -1,3 +1,7 @@ +2025-11-30 Jose E. Marchesi + + * acx.m4 (ACX_PROG_GA68): New defun. + 2025-11-03 Sam James * clang-plugin.m4: Sync with binutils. diff --git a/config/acx.m4 b/config/acx.m4 index db54ccf1c7c1..4e0c64172e6c 100644 --- a/config/acx.m4 +++ b/config/acx.m4 @@ -434,6 +434,12 @@ else have_cargo=no fi]) +# Test for Algol 68 +AC_DEFUN([ACX_PROG_GA68], +[AC_REQUIRE([AC_CHECK_TOOL_PREFIX]) +AC_REQUIRE([AC_PROG_CC]) +AC_CHECK_TOOL(GA68, ga68, no)]) + # Test for D. AC_DEFUN([ACX_PROG_GDC], [AC_REQUIRE([AC_CHECK_TOOL_PREFIX]) diff --git a/configure b/configure index d4da79e76690..e59746f3d000 100755 --- a/configure +++ b/configure @@ -620,6 +620,7 @@ AR_FOR_TARGET GM2_FOR_TARGET GDC_FOR_TARGET GOC_FOR_TARGET +GA68_FOR_TARGET GFORTRAN_FOR_TARGET GCC_FOR_TARGET CXX_FOR_TARGET @@ -633,6 +634,7 @@ GREP CPP PKG_CONFIG_PATH GDCFLAGS +GA68FLAGS READELF OTOOL OBJDUMP @@ -665,6 +667,7 @@ LDFLAGS_FOR_BUILD GNATMAKE_FOR_BUILD GDC_FOR_BUILD GOC_FOR_BUILD +GA68_FOR_BUILD GFORTRAN_FOR_BUILD DSYMUTIL_FOR_BUILD DLLTOOL_FOR_BUILD @@ -728,6 +731,7 @@ HAVE_CXX14 do_compare CARGO GDC +GA68 GNATMAKE GNATBIND ac_ct_CXX @@ -829,6 +833,7 @@ enable_libquadmath enable_libquadmath_support enable_libada enable_libgm2 +enable_libga68 enable_libssp enable_libstdcxx enable_bootstrap @@ -859,6 +864,7 @@ enable_host_shared enable_libgdiagnostics enable_stage1_languages enable_objc_gc +enable_algol68_gc with_target_bdw_gc with_target_bdw_gc_include with_target_bdw_gc_lib @@ -907,6 +913,7 @@ CC_FOR_TARGET CXX_FOR_TARGET GCC_FOR_TARGET GFORTRAN_FOR_TARGET +GA68_FOR_TARGET GOC_FOR_TARGET GDC_FOR_TARGET GM2_FOR_TARGET @@ -1576,6 +1583,7 @@ Optional Features: disable libquadmath support for Fortran --enable-libada build libada directory --enable-libgm2 build libgm2 directory + --enable-libga68 build libga68 directory --enable-libssp build libssp directory --disable-libstdcxx do not build libstdc++-v3 directory --enable-bootstrap enable bootstrapping [yes if native build] @@ -1599,6 +1607,8 @@ Optional Features: Mostly useful for compiler development --enable-objc-gc enable use of Boehm's garbage collector with the GNU Objective-C runtime + --enable-algol68-gc enable use of Boehm's garbage collector with the GNU + Algol runtime --enable-vtable-verify Enable vtable verification feature --enable-serial-[{host,target,build}-]configure force sequential configuration of sub-packages for @@ -1712,6 +1722,8 @@ Some influential environment variables: GCC for the target GFORTRAN_FOR_TARGET GFORTRAN for the target + GA68_FOR_TARGET + GA68 for the target GOC_FOR_TARGET GOC for the target GDC_FOR_TARGET @@ -2916,6 +2928,7 @@ target_libraries="target-libgcc \ target-libgcobol \ target-libada \ target-libgm2 \ + target-libga68 \ target-libgo \ target-libgrust \ target-libphobos \ @@ -3319,6 +3332,14 @@ if test "${ENABLE_LIBGM2}" != "yes" ; then noconfigdirs="$noconfigdirs gm2tools" fi +# Check whether --enable-libga68 was given. +if test "${enable_libga68+set}" = set; then : + enableval=$enable_libga68; ENABLE_LIBGA68=$enableval +else + ENABLE_LIBGA68=yes +fi + + # Check whether --enable-libssp was given. if test "${enable_libssp+set}" = set; then : enableval=$enable_libssp; ENABLE_LIBSSP=$enableval @@ -4301,6 +4322,7 @@ if test "${build}" != "${host}" ; then DLLTOOL_FOR_BUILD=${DLLTOOL_FOR_BUILD-dlltool} DSYMUTIL_FOR_BUILD=${DSYMUTIL_FOR_BUILD-dsymutil} GFORTRAN_FOR_BUILD=${GFORTRAN_FOR_BUILD-gfortran} + GA68_FOR_BUILD=${GA68_FOR_BUILD-ga68} GOC_FOR_BUILD=${GOC_FOR_BUILD-gccgo} GDC_FOR_BUILD=${GDC_FOR_BUILD-gdc} GNATMAKE_FOR_BUILD=${GNATMAKE_FOR_BUILD-gnatmake} @@ -4317,6 +4339,7 @@ else DLLTOOL_FOR_BUILD="\$(DLLTOOL)" DSYMUTIL_FOR_BUILD="\$(DSYMUTIL)" GFORTRAN_FOR_BUILD="\$(GFORTRAN)" + GA68_FOR_BUILD="\$(GA68)" GOC_FOR_BUILD="\$(GOC)" GDC_FOR_BUILD="\$(GDC)" GNATMAKE_FOR_BUILD="\$(GNATMAKE)" @@ -5837,6 +5860,100 @@ fi +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}ga68", so it can be a program name with args. +set dummy ${ac_tool_prefix}ga68; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_GA68+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$GA68"; then + ac_cv_prog_GA68="$GA68" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_GA68="${ac_tool_prefix}ga68" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +GA68=$ac_cv_prog_GA68 +if test -n "$GA68"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GA68" >&5 +$as_echo "$GA68" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_GA68"; then + ac_ct_GA68=$GA68 + # Extract the first word of "ga68", so it can be a program name with args. +set dummy ga68; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_GA68+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_GA68"; then + ac_cv_prog_ac_ct_GA68="$ac_ct_GA68" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_GA68="ga68" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_GA68=$ac_cv_prog_ac_ct_GA68 +if test -n "$ac_ct_GA68"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_GA68" >&5 +$as_echo "$ac_ct_GA68" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_GA68" = x; then + GA68="no" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + GA68=$ac_ct_GA68 + fi +else + GA68="$ac_cv_prog_GA68" +fi + + + if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gdc", so it can be a program name with args. set dummy ${ac_tool_prefix}gdc; ac_word=$2 @@ -10383,6 +10500,11 @@ if test "${enable_objc_gc+set}" = set; then : enableval=$enable_objc_gc; fi +# Check whether --enable-algol68-gc was given. +if test "${enable_algol68_gc+set}" = set; then : + enableval=$enable_algol68_gc; +fi + # Check whether --with-target-bdw-gc was given. if test "${with_target_bdw_gc+set}" = set; then : @@ -10402,22 +10524,23 @@ if test "${with_target_bdw_gc_lib+set}" = set; then : fi -case ,${enable_languages},:${enable_objc_gc} in *,objc,*:yes|*,objc,*:auto) - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bdw garbage collector" >&5 +case ,${enable_languages},:${enable_objc_gc}:${enable_algol68_gc} in + *,objc,*:yes:*|*,objc,*:auto:*|*,algol68,*:*:yes|*,algol68,*:*:auto) + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bdw garbage collector" >&5 $as_echo_n "checking for bdw garbage collector... " >&6; } - if test "x$with_target_bdw_gc$with_target_bdw_gc_include$with_target_bdw_gc_lib" = x; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: using bdw-gc in default locations" >&5 + if test "x$with_target_bdw_gc$with_target_bdw_gc_include$with_target_bdw_gc_lib" = x; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: using bdw-gc in default locations" >&5 $as_echo "using bdw-gc in default locations" >&6; } - else - if test "x$with_target_bdw_gc_include" = x && test "x$with_target_bdw_gc_lib" != x; then - as_fn_error $? "found --with-target-bdw-gc-lib but --with-target-bdw-gc-include missing" "$LINENO" 5 - elif test "x$with_target_bdw_gc_include" != x && test "x$with_target_bdw_gc_lib" = x; then - as_fn_error $? "found --with-target-bdw-gc-include but --with-target-bdw-gc-lib missing" "$LINENO" 5 else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: using paths configured with --with-target-bdw-gc options" >&5 + if test "x$with_target_bdw_gc_include" = x && test "x$with_target_bdw_gc_lib" != x; then + as_fn_error $? "found --with-target-bdw-gc-lib but --with-target-bdw-gc-include missing" "$LINENO" 5 + elif test "x$with_target_bdw_gc_include" != x && test "x$with_target_bdw_gc_lib" = x; then + as_fn_error $? "found --with-target-bdw-gc-include but --with-target-bdw-gc-lib missing" "$LINENO" 5 + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: using paths configured with --with-target-bdw-gc options" >&5 $as_echo "using paths configured with --with-target-bdw-gc options" >&6; } + fi fi - fi esac # Disable libitm, libsanitizer, libvtv if we're not building C++ @@ -11746,6 +11869,7 @@ done + # Generate default definitions for YACC, M4, LEX and other programs that run @@ -14266,6 +14390,9 @@ fi +GA68FLAGS=${GA68FLAGS-${CFLAGS}} + + GDCFLAGS=${GDCFLAGS-${CFLAGS}} @@ -15594,6 +15721,167 @@ fi +if test -n "$GA68_FOR_TARGET"; then + ac_cv_prog_GA68_FOR_TARGET=$GA68_FOR_TARGET +elif test -n "$ac_cv_prog_GA68_FOR_TARGET"; then + GA68_FOR_TARGET=$ac_cv_prog_GA68_FOR_TARGET +fi + +if test -n "$ac_cv_prog_GA68_FOR_TARGET"; then + for ncn_progname in ga68; do + # Extract the first word of "${ncn_progname}", so it can be a program name with args. +set dummy ${ncn_progname}; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_GA68_FOR_TARGET+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$GA68_FOR_TARGET"; then + ac_cv_prog_GA68_FOR_TARGET="$GA68_FOR_TARGET" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_GA68_FOR_TARGET="${ncn_progname}" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +GA68_FOR_TARGET=$ac_cv_prog_GA68_FOR_TARGET +if test -n "$GA68_FOR_TARGET"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GA68_FOR_TARGET" >&5 +$as_echo "$GA68_FOR_TARGET" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + done +fi + +if test -z "$ac_cv_prog_GA68_FOR_TARGET" && test -n "$with_build_time_tools"; then + for ncn_progname in ga68; do + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ${ncn_progname} in $with_build_time_tools" >&5 +$as_echo_n "checking for ${ncn_progname} in $with_build_time_tools... " >&6; } + if test -x $with_build_time_tools/${ncn_progname}; then + ac_cv_prog_GA68_FOR_TARGET=$with_build_time_tools/${ncn_progname} + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + break + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + fi + done +fi + +if test -z "$ac_cv_prog_GA68_FOR_TARGET"; then + for ncn_progname in ga68; do + if test -n "$ncn_target_tool_prefix"; then + # Extract the first word of "${ncn_target_tool_prefix}${ncn_progname}", so it can be a program name with args. +set dummy ${ncn_target_tool_prefix}${ncn_progname}; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_GA68_FOR_TARGET+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$GA68_FOR_TARGET"; then + ac_cv_prog_GA68_FOR_TARGET="$GA68_FOR_TARGET" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_GA68_FOR_TARGET="${ncn_target_tool_prefix}${ncn_progname}" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +GA68_FOR_TARGET=$ac_cv_prog_GA68_FOR_TARGET +if test -n "$GA68_FOR_TARGET"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GA68_FOR_TARGET" >&5 +$as_echo "$GA68_FOR_TARGET" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + if test -z "$ac_cv_prog_GA68_FOR_TARGET" && test $build = $target ; then + # Extract the first word of "${ncn_progname}", so it can be a program name with args. +set dummy ${ncn_progname}; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_GA68_FOR_TARGET+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$GA68_FOR_TARGET"; then + ac_cv_prog_GA68_FOR_TARGET="$GA68_FOR_TARGET" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_GA68_FOR_TARGET="${ncn_progname}" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +GA68_FOR_TARGET=$ac_cv_prog_GA68_FOR_TARGET +if test -n "$GA68_FOR_TARGET"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GA68_FOR_TARGET" >&5 +$as_echo "$GA68_FOR_TARGET" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi + test -n "$ac_cv_prog_GA68_FOR_TARGET" && break + done +fi + +if test -z "$ac_cv_prog_GA68_FOR_TARGET" ; then + set dummy ga68 + if test $build = $target ; then + GA68_FOR_TARGET="$2" + else + GA68_FOR_TARGET="${ncn_target_tool_prefix}$2" + fi +else + GA68_FOR_TARGET="$ac_cv_prog_GA68_FOR_TARGET" +fi + + + if test -n "$GOC_FOR_TARGET"; then ac_cv_prog_GOC_FOR_TARGET=$GOC_FOR_TARGET elif test -n "$ac_cv_prog_GOC_FOR_TARGET"; then @@ -20060,6 +20348,51 @@ $as_echo "pre-installed" >&6; } fi fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking where to find the target ga68" >&5 +$as_echo_n "checking where to find the target ga68... " >&6; } +if test "x${build}" != "x${host}" ; then + if expr "x$GA68_FOR_TARGET" : "x/" > /dev/null; then + # We already found the complete path + ac_dir=`dirname $GA68_FOR_TARGET` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: pre-installed in $ac_dir" >&5 +$as_echo "pre-installed in $ac_dir" >&6; } + else + # Canadian cross, just use what we found + { $as_echo "$as_me:${as_lineno-$LINENO}: result: pre-installed" >&5 +$as_echo "pre-installed" >&6; } + fi +else + ok=yes + case " ${configdirs} " in + *" gcc "*) ;; + *) ok=no ;; + esac + case ,${enable_languages}, in + *,algol68,*) ;; + *) ok=no ;; + esac + if test $ok = yes; then + # An in-tree tool is available and we can use it + GA68_FOR_TARGET='$$r/$(HOST_SUBDIR)/gcc/ga68 -B$$r/$(HOST_SUBDIR)/gcc/' + { $as_echo "$as_me:${as_lineno-$LINENO}: result: just compiled" >&5 +$as_echo "just compiled" >&6; } + elif expr "x$GA68_FOR_TARGET" : "x/" > /dev/null; then + # We already found the complete path + ac_dir=`dirname $GA68_FOR_TARGET` + { $as_echo "$as_me:${as_lineno-$LINENO}: result: pre-installed in $ac_dir" >&5 +$as_echo "pre-installed in $ac_dir" >&6; } + elif test "x$target" = "x$host"; then + # We can use an host tool + GA68_FOR_TARGET='$(GA68)' + { $as_echo "$as_me:${as_lineno-$LINENO}: result: host tool" >&5 +$as_echo "host tool" >&6; } + else + # We need a cross tool + { $as_echo "$as_me:${as_lineno-$LINENO}: result: pre-installed" >&5 +$as_echo "pre-installed" >&6; } + fi +fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking where to find the target gdc" >&5 $as_echo_n "checking where to find the target gdc... " >&6; } if test "x${build}" != "x${host}" ; then diff --git a/configure.ac b/configure.ac index 456a673b9bbe..2fb385961df6 100644 --- a/configure.ac +++ b/configure.ac @@ -166,6 +166,7 @@ target_libraries="target-libgcc \ target-libgcobol \ target-libada \ target-libgm2 \ + target-libga68 \ target-libgo \ target-libgrust \ target-libphobos \ @@ -514,6 +515,11 @@ if test "${ENABLE_LIBGM2}" != "yes" ; then noconfigdirs="$noconfigdirs gm2tools" fi +AC_ARG_ENABLE(libga68, +[AS_HELP_STRING([--enable-libga68], [build libga68 directory])], +ENABLE_LIBGA68=$enableval, +ENABLE_LIBGA68=yes) + AC_ARG_ENABLE(libssp, [AS_HELP_STRING([--enable-libssp], [build libssp directory])], ENABLE_LIBSSP=$enableval, @@ -1451,6 +1457,7 @@ if test "${build}" != "${host}" ; then DLLTOOL_FOR_BUILD=${DLLTOOL_FOR_BUILD-dlltool} DSYMUTIL_FOR_BUILD=${DSYMUTIL_FOR_BUILD-dsymutil} GFORTRAN_FOR_BUILD=${GFORTRAN_FOR_BUILD-gfortran} + GA68_FOR_BUILD=${GA68_FOR_BUILD-ga68} GOC_FOR_BUILD=${GOC_FOR_BUILD-gccgo} GDC_FOR_BUILD=${GDC_FOR_BUILD-gdc} GNATMAKE_FOR_BUILD=${GNATMAKE_FOR_BUILD-gnatmake} @@ -1467,6 +1474,7 @@ else DLLTOOL_FOR_BUILD="\$(DLLTOOL)" DSYMUTIL_FOR_BUILD="\$(DSYMUTIL)" GFORTRAN_FOR_BUILD="\$(GFORTRAN)" + GA68_FOR_BUILD="\$(GA68)" GOC_FOR_BUILD="\$(GOC)" GDC_FOR_BUILD="\$(GDC)" GNATMAKE_FOR_BUILD="\$(GNATMAKE)" @@ -1520,6 +1528,7 @@ int main() {}])], fi ACX_PROG_GNAT +ACX_PROG_GA68 ACX_PROG_GDC ACX_PROG_CARGO ACX_PROG_CMP_IGNORE_INITIAL @@ -2644,6 +2653,10 @@ AC_ARG_ENABLE(objc-gc, [AS_HELP_STRING([--enable-objc-gc], [enable use of Boehm's garbage collector with the GNU Objective-C runtime])]) +AC_ARG_ENABLE(algol68-gc, +[AS_HELP_STRING([--enable-algol68-gc], + [enable use of Boehm's garbage collector with the + GNU Algol runtime])]) AC_ARG_WITH([target-bdw-gc], [AS_HELP_STRING([--with-target-bdw-gc=PATHLIST], [specify prefix directory for installed bdw-gc package. @@ -2656,21 +2669,22 @@ AC_ARG_WITH([target-bdw-gc-lib], [AS_HELP_STRING([--with-target-bdw-gc-lib=PATHLIST], [specify directories for installed bdw-gc library])]) -case ,${enable_languages},:${enable_objc_gc} in *,objc,*:yes|*,objc,*:auto) - AC_MSG_CHECKING([for bdw garbage collector]) - if test "x$with_target_bdw_gc$with_target_bdw_gc_include$with_target_bdw_gc_lib" = x; then - dnl no bdw-gw options, assume default locations - AC_MSG_RESULT([using bdw-gc in default locations]) - else - dnl bdw-gw options, first error checking, complete checking in libobjc - if test "x$with_target_bdw_gc_include" = x && test "x$with_target_bdw_gc_lib" != x; then - AC_MSG_ERROR([found --with-target-bdw-gc-lib but --with-target-bdw-gc-include missing]) - elif test "x$with_target_bdw_gc_include" != x && test "x$with_target_bdw_gc_lib" = x; then - AC_MSG_ERROR([found --with-target-bdw-gc-include but --with-target-bdw-gc-lib missing]) +case ,${enable_languages},:${enable_objc_gc}:${enable_algol68_gc} in + *,objc,*:yes:*|*,objc,*:auto:*|*,algol68,*:*:yes|*,algol68,*:*:auto) + AC_MSG_CHECKING([for bdw garbage collector]) + if test "x$with_target_bdw_gc$with_target_bdw_gc_include$with_target_bdw_gc_lib" = x; then + dnl no bdw-gw options, assume default locations + AC_MSG_RESULT([using bdw-gc in default locations]) else - AC_MSG_RESULT([using paths configured with --with-target-bdw-gc options]) + dnl bdw-gw options, first error checking, complete checking in libobjc and libga68 + if test "x$with_target_bdw_gc_include" = x && test "x$with_target_bdw_gc_lib" != x; then + AC_MSG_ERROR([found --with-target-bdw-gc-lib but --with-target-bdw-gc-include missing]) + elif test "x$with_target_bdw_gc_include" != x && test "x$with_target_bdw_gc_lib" = x; then + AC_MSG_ERROR([found --with-target-bdw-gc-include but --with-target-bdw-gc-lib missing]) + else + AC_MSG_RESULT([using paths configured with --with-target-bdw-gc options]) + fi fi - fi esac # Disable libitm, libsanitizer, libvtv if we're not building C++ @@ -3917,6 +3931,7 @@ AC_SUBST(CXX_FOR_BUILD) AC_SUBST(DLLTOOL_FOR_BUILD) AC_SUBST(DSYMUTIL_FOR_BUILD) AC_SUBST(GFORTRAN_FOR_BUILD) +AC_SUBST(GA68_FOR_BUILD) AC_SUBST(GOC_FOR_BUILD) AC_SUBST(GDC_FOR_BUILD) AC_SUBST(GNATMAKE_FOR_BUILD) @@ -4012,6 +4027,9 @@ AC_SUBST(CC) AC_SUBST(CXX) AC_SUBST(CFLAGS) AC_SUBST(CXXFLAGS) +AC_SUBST(GA68) +AC_SUBST(GA68FLAGS) +GA68FLAGS=${GA68FLAGS-${CFLAGS}} AC_SUBST(GDC) AC_SUBST(GDCFLAGS) GDCFLAGS=${GDCFLAGS-${CFLAGS}} @@ -4060,6 +4078,7 @@ NCN_STRICT_CHECK_TARGET_TOOLS(CC_FOR_TARGET, cc gcc) NCN_STRICT_CHECK_TARGET_TOOLS(CXX_FOR_TARGET, c++ g++ cxx gxx) NCN_STRICT_CHECK_TARGET_TOOLS(GCC_FOR_TARGET, gcc, ${CC_FOR_TARGET}) NCN_STRICT_CHECK_TARGET_TOOLS(GFORTRAN_FOR_TARGET, gfortran) +NCN_STRICT_CHECK_TARGET_TOOLS(GA68_FOR_TARGET, ga68) NCN_STRICT_CHECK_TARGET_TOOLS(GOC_FOR_TARGET, gccgo) NCN_STRICT_CHECK_TARGET_TOOLS(GDC_FOR_TARGET, gdc) NCN_STRICT_CHECK_TARGET_TOOLS(GM2_FOR_TARGET, gm2) @@ -4111,6 +4130,8 @@ GCC_TARGET_TOOL(gfortran, GFORTRAN_FOR_TARGET, GFORTRAN, [gcc/gfortran -B$$r/$(HOST_SUBDIR)/gcc/], fortran) GCC_TARGET_TOOL(gccgo, GOC_FOR_TARGET, GOC, [gcc/gccgo -B$$r/$(HOST_SUBDIR)/gcc/], go) +GCC_TARGET_TOOL(ga68, GA68_FOR_TARGET, GA68, + [gcc/ga68 -B$$r/$(HOST_SUBDIR)/gcc/], algol68) GCC_TARGET_TOOL(gdc, GDC_FOR_TARGET, GDC, [gcc/gdc -B$$r/$(HOST_SUBDIR)/gcc/], d) GCC_TARGET_TOOL(gm2, GM2_FOR_TARGET, GM2, diff --git a/contrib/gcc-changelog/git_commit.py b/contrib/gcc-changelog/git_commit.py index 7c93df6ebbee..7aa3ea38cf51 100755 --- a/contrib/gcc-changelog/git_commit.py +++ b/contrib/gcc-changelog/git_commit.py @@ -33,6 +33,7 @@ 'contrib/regression', 'fixincludes', 'gcc/ada', + 'gcc/algol68', 'gcc/analyzer', 'gcc/brig', 'gcc/c', @@ -64,6 +65,7 @@ 'libcpp/po', 'libdecnumber', 'libffi', + 'libga68', 'libgcc', 'libgcc/config/avr/libf7', 'libgcc/config/libbid', diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 3aa2a2eeb612..cab26dad2493 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,845 @@ +2025-11-30 Tamar Christina + + PR tree-optimization/115120 + PR tree-optimization/119577 + PR tree-optimization/119860 + * tree-vect-loop-manip.cc (vect_can_advance_ivs_p): Check for nonlinear + mult induction and early break. + (vect_update_ivs_after_vectorizer): Support early break exits. + (vect_do_peeling): Support scalar IVs. + * tree-vect-loop.cc (vect_peel_nonlinear_iv_init): Support early break. + (vect_update_nonlinear_iv): use `unsigned_type_for` such that function + works for both vector and scalar types. + (vectorizable_induction, vectorizable_live_operation): Remove vector + early break IV code. + (vect_update_ivs_after_vectorizer_for_early_breaks): New. + (vect_transform_loop): Support new scalar IV for early break. + * tree-vect-slp.cc (vect_analyze_slp): Remove SLP build for early break + IVs. + * tree-vect-stmts.cc (vect_stmt_relevant_p): No longer mark early break + IVs as completely unused rather than used_only_live. They no longer + contribute to the vector loop and so should not be analyzed. + (can_vectorize_live_stmts): Remove vector early vreak IV code. + * tree-vectorizer.h (LOOP_VINFO_EARLY_BRK_NITERS_VAR): New. + (class loop_vec_info): Add early_break_niters_var. + +2025-11-30 Jose E. Marchesi + + * Makefile.in (OPT_URLS_HTML_DEPS): Add ga68/Option-Index.html. + +2025-11-30 Jose E. Marchesi + + * doc/install.texi (Configuration): Mention algol68 option for + --enable-languages. + (Algol 68-Specific Options): New section. + * doc/sourcebuild.texi (Top Level): Add entry for libga68. + +2025-11-30 Jose E. Marchesi + + * config/rs6000/rs6000-logue.cc (rs6000_output_function_epilogue): + Handle "GNU Algol 68" in language_string. + +2025-11-30 Jose E. Marchesi + + * config/darwin.h: Adapt specs for libga68.a. + +2025-11-30 Jose E. Marchesi + + * dwarf2out.cc: Set DW_LANG_Algol68 an DW_LNAME_Algol68. + +2025-11-30 Jose E. Marchesi + + * common.opt: New option -static-libga68. + * common.opt.urls: Generate. + * gcc.cc: Handle OPT_static_libga68. + * regenerate-opt-urls.py (PER_LANGUAGE_OPTION_INDEXES): Add Algol68. + +2025-11-30 Jose E. Marchesi + + * Makefile.def (libga68): New module. + (configure-target-libga68): Likewise. + * Makefile.tpl (GA68): Define. + (GA68_FOR_BUILD): Likewise. + (GA68FLAGS): Likewise. + * configure.ac (--enable-libga68): New option. + (--enable-algol68-gc): Likewise. + (GA68): Subst. + (GA68FLAGS): Likewise. + Invoke ACX_PROG_GA68. + * configure: Regenerate. + * Makefile.in: Likewise. + +2025-11-29 Sandra Loosemore + + * common.opt.urls: Regenerated. + * config/aarch64/aarch64.opt.urls: Regenerated. + * config/alpha/alpha.opt.urls: Regenerated. + * config/arm/arm.opt.urls: Regenerated. + * config/avr/avr.opt.urls: Regenerated. + * config/bpf/bpf.opt.urls: Regenerated. + * config/c6x/c6x.opt.urls: Regenerated. + * config/cris/cris.opt.urls: Regenerated. + * config/cris/elf.opt.urls: Regenerated. + * config/csky/csky.opt.urls: Regenerated. + * config/darwin.opt.urls: Regenerated. + * config/epiphany/epiphany.opt.urls: Regenerated. + * config/frv/frv.opt.urls: Regenerated. + * config/ft32/ft32.opt.urls: Regenerated. + * config/gcn/gcn.opt.urls: Regenerated. + * config/i386/i386.opt.urls: Regenerated. + * config/ia64/ia64.opt.urls: Regenerated. + * config/loongarch/loongarch.opt.urls: Regenerated. + * config/m68k/m68k.opt.urls: Regenerated. + * config/microblaze/microblaze.opt.urls: Regenerated. + * config/mips/mips.opt.urls: Regenerated. + * config/mmix/mmix.opt.urls: Regenerated. + * config/or1k/or1k.opt.urls: Regenerated. + * config/pa/pa.opt.urls: Regenerated. + * config/pdp11/pdp11.opt.urls: Regenerated. + * config/rs6000/rs6000.opt.urls: Regenerated. + * config/s390/s390.opt.urls: Regenerated. + * config/sparc/sparc.opt.urls: Regenerated. + * config/v850/v850.opt.urls: Regenerated. + * config/vax/vax.opt.urls: Regenerated. + * config/visium/visium.opt.urls: Regenerated. + +2025-11-29 Sandra Loosemore + + * doc/invoke.texi (Options Summary): Switch ordering of FRV + and FT32. + (Submodel Options): Likewise in the menu and section ordering. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * doc/invoke.texi: Document -mno-android. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * config/frv/frv.opt (mbranch-cost=): Mark as Undocumented. + (mcond-exec-insns=): Likewise. + (mcond-exec-tempss=): Likewise. + * doc/invoke.texi (Option Summary) : Remove duplicate + positive/negative forms from the list. + (FRV Options): Combine documentation of positive/negative forms + where they were listed separately. Add @opindex entries for + negative forms. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * config/ft32/ft32.opt (mlra): Mark obsolete option as Undocumented. + * doc/invoke.texi (Option Summary) : Remove -mlra. + (FT32 Options): Likewise. Add @opindex entries for negative + option forms. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * doc/invoke.texi (FR30 Options): Add @opindex for -mno-small-model. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * doc/invoke.texi (Option Summary) : Fix formatting + issues. Remove redundant entry for -mno-co-re. + (eBPF Options): Add missing @opindex entries. Combine documentation + for -mco-re and -mno-co-re. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * config/alpha/alpha.opt (mgas): Mark as Undocumented. + * doc/invoke.texi (Option Summary) : Add + -mtls-kernel, -mtls-size=, -mlong-double-128, and -mlong-double-64. + (DEC Alpha Options): Likewise. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * config/darwin.opt (findirect-virtual-calls): Mark as Undocumented. + (fterminated-vtables): Likewise. + (multi_module): Likewise. + (multiply_defined): Likewise. + (multiply_defined_unused): Likewise. + (no_dead_strip_inits_and_terms): Likewise. + (noprefixbinding): Likewise. + (nomultidefs): Likewise. + (noprebind): Likewise. + (noseglinkedit): Likewise. + (ObjC, ObjC++): Add documentation strings. + (object): Mark as Undocumented. + (prebind): Likewise. + (prebind_all_twolevel_modules): Likewise. + (private_bundle): Likewise. + (sectobjectsymbols): Likewise. + (sectorder): Likewise. + (seg_addr_table_filename): Likewise. + (segcreate): Likewise. + (seglinkedit): Likewise. + (single_module): Likewise. + (X): Likewise. + (y): Likewise. + (Mach): Likewise. + * doc/invoke.texi (Option Summary) : Improve + alphabetization of the list. Remove obsolete/undocumented + options and add missing entries. + (Darwin Options): Add documentation for -arch, -dependency-file, + -fapple-kext, -matt-stubs, -fconstant-cfstrings, -mdynamic-no-pic, + -asm_macosx_version_min, -msymbol-stubs, -mtarget-linker, + -ObjC, -ObjC++, -Wnonportable-cfstrings. Update the list + of options passed to the linker to remove obsolete options + and add missing ones; also move the block of @opindex entries + before the list items instead of putting it in the middle. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * doc/invoke.texi (Option Summary) : + Correct spelling of -mthreads and add missing options. + (Cygwin and MinGW Options): Add @opindex for negative forms. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * doc/invoke.texi (Option Summary) : Remove + entries for "Undocumented" options -EB, -EL, -mhard-float, + -msoft-float, and nonexistent option -mcse-cc. + (C-SKY Options): Likewise. Also remove references to "Undocumented" + option -mstm and uniformly index/document the -mno- forms for + consistency with other options in this section that already do so. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * config/cris/cris.opt (m32-bit, m16-bit, m8-bit): Remove + Undocumented property. + (m32bit, m8bit): Add Undocumented property. + * doc/invoke.texi (Option Summary) : Remove + obsolete -melf and -maout options from table, plus redundant + -mno-mul-bug-workaround. + (CRIS Options): Add @opindex for -mno- forms that didn't already + have one. Remove obsolete -melf documentation. Document + -mbest-lib-options, -moverride-best-lib-options, + -mtrap-using-break8, -mtrap-unaligned-atomic, and + -munaligned-atomic-may-use-library. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * doc/invoke.texi (Option Summary) : Add -mdbst + and -mlong-calls. + (C6X Options): Likewise. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * doc/invoke.texi (Option Summary) : + Remove redundant -mno- entries. + (Blackfin Options): Combine explicit -mno-* documentation + with that for the corresponding positive form of the option. + Add @opindex entries for the negative forms of options that + didn't already have one. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * config/arm/arm.opt (mapcs-reentrant): Mark as "Undocumented", + updatehelp string for internal documentation. + (mapcs-stack-check): Likewise update help string. + (mprint-tune-info, mneon-for-64bits): Mark as "Undocumented". + * doc/invoke.texi (Option Summary) : Remove duplicate + entries for negative forms and entries for options that are + explicitly "Undocumented". Add missing entry for + -mpic-data-is-text-relative. Fix some formatting issues. + (ARM Options): Remove documentation for -mapcs-stack-check, + -mapcs-reentrant, -mflip-thumb, -mneon-for-64-bits, + -mprint-tune-info, and -mverbose-cost-dump. Add index entries + for -mno- option forms. Minor editing for clarity. + +2025-11-29 Sandra Loosemore + + PR other/122243 + PR target/122288 + * config/gcn/gcn.opt (m32, m64, mgomp): Mark "Undocumented" + since these options don't actually do anything useful. + (flag_bypass_init_error, stack_size_opt, gang_size_opt): Correct + opt file syntax. + (mstack-size=): Mark "Undocumented" since it's obsolete. + * doc/invoke.texi (Option Summary) : + Remove obsolete options, add missing entries for + -mgang-private-size=, -msram-ecc=, and -mxnack=. + (AMD GCN Options): Likewise. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * config/epiphany/epiphany.opt (mlong-calls): Make it do something + useful. + (may-round-for-trunc): Make this undocumented option with a weird + name an alias for -mmay-round-for-trunc. + (mfp-iarith): Fix doc string. + * doc/invoke.texi (Option Summary) : + Add missing options. + (Adapteva Epiphany Options): Document negative forms also when + that is not the default, or where it's unclear. Document + -may-round-for-trunc and -mfp-iarith. Fix spelling of + -mpost-inc and -mpost-modify. + +2025-11-29 Sandra Loosemore + + PR other/122243 + * config/aarch64/aarch64.opt (Wexperimental-fmv-target): Mark + as "Undocumented". + * doc/invoke.texi (Option Summary) : Don't + list "Undocumented" aarch64 options -mverbose-cost-dump or + -Wexperimental-fmv-target, or both positive and negative forms + of other options. Add missing options. Fix whitespace problems. + (AArch64 Options): Light copy-editing. Add missing @opindex + entries to match the documented options. Undocument + -mverbose-cost-dump and -Wexperimental-fmv-target. + +2025-11-28 Jakub Jelinek + + * config/rs6000/rs6000.cc (complex_multiply_builtin_code): + Avoid arithmetics between enumerators from different enum types. + (complex_divide_builtin_code): Likewise. + +2025-11-28 Jakub Jelinek + + * config/loongarch/loongarch.cc (loongarch_unspec_address_offset): + Avoid arithmetics between enumerators from different enum types. + (loongarch_call_tls_get_addr): Likewise. + +2025-11-28 Jakub Jelinek + + * config/mips/mips.cc (mips_unspec_address_offset): Avoid + arithmetics between enumerators from different enum types. + +2025-11-28 Jakub Jelinek + + * config/riscv/riscv-v.cc (expand_const_vector_onestep): Avoid + bitwise ops between enumerators from different enum types. + (emit_vec_cvt_x_f): Likewise. + (emit_vec_cvt_x_f_rtz): Likewise. + * config/riscv/riscv.cc (riscv_unspec_address_offset): Avoid + arithmetics between enumerators from different enum types. + +2025-11-28 Sam James + + * crc-verification.cc (crc_symbolic_execution::is_used_outside_the_loop): + Fix 'assignment' typo. + +2025-11-28 Andrew MacLeod + + PR tree-optimization/122686 + * range-op.cc (operator_bitwise_and::op1_range): Check for + undefined bitmask. + * value-range.cc (prange::intersect): Handle undefined bitmask + intersection. + (irange::get_bitmask): Ditto. + (irange::intersect_bitmask): Ditto. + * value-range.h (irange_bitmask::intersect): Return false if the + result is UNDEFINED. + +2025-11-28 Tobias Burnus + + * config.gcc (amdgcn-*-*): Use gfx90a for 'with_arch'. + For TM_MULTILIB_CONFIG, replace specific archs by + gfx{9,9-4,10-3,11}-generic, keep gfx90{8,a}. + * config/gcn/gcn.opt (march=, mtune=): Use gfx90a. + * doc/install.texi (amdgcn): Update accordingly. + +2025-11-28 Stefan Schulze Frielinghaus + + * config/s390/s390-builtins.h + (S390_OVERLOADED_BUILTIN_VAR_OFFSET,S390_ALL_BUILTIN_MAX): Fix + enum arithmetic. + * config/s390/s390.cc (OB_DEF): Ditto. + +2025-11-28 Richard Biener + + PR tree-optimization/122844 + * tree-vect-slp.cc (vect_analyze_slp_reduc_chain): Only + try stripping sign conversions around ops where this is valid. + +2025-11-28 Jim Lin + + * config/riscv/riscv.cc (riscv_output_move): Use \n\t instead + of semicolon to separate instructions in fmv.x.h emulation. + +2025-11-28 Charlie Jenkins + + * config.gcc: Add cpu to supported configure options + * config/riscv/riscv.h (riscv_arch_help): Use --with-cpu during + compilation + * doc/install.texi: Mention in docs that --with-cpu is supported + +2025-11-28 Mark Zhuang + + * config/riscv/riscv-cores.def (RISCV_CORE): Add xsmtvdot to + spacemit-x60 + * config/riscv/riscv-ext.def: Add xsmtvdot + * config/riscv/riscv-ext.opt: Ditto + * config/riscv/t-riscv: Ditto + * doc/riscv-ext.texi: Ditto + * config/riscv/riscv-ext-spacemit.def: Define xsmtvdot + +2025-11-28 Mark Zhuang + + * config/riscv/riscv-ext.opt: Generated file. + +2025-11-28 Kuan-Lin Chen + + * config/riscv/riscv-cores.def (RISCV_TUNE): Add andes-45-sereis. + (RISCV_CORE): Add Andes 45 series cpu list. + * config/riscv/riscv-opts.h + (enum riscv_microarchitecture_type): Add andes_45_series. + * config/riscv/riscv.cc: Add andes_45_tune_info. + * config/riscv/riscv.md: Add andes_45. + * doc/riscv-mcpu.texi: Regenerated for Andes cpu list. + * doc/riscv-mtune.texi: Regenerated for andes-45-series. + * config/riscv/andes-45-series.md: New file. + +2025-11-28 Kuan-Lin Chen + + * config/riscv/riscv-cores.def (RISCV_TUNE): Add andes-23-series. + (RISCV_CORE): Add Andes 23-series cpu list. + * config/riscv/riscv-opts.h + (enum riscv_microarchitecture_type): Add andes_23_series. + * config/riscv/riscv.cc: Add andes_23_tune_info. + * config/riscv/riscv.md: Add andes_23. + * doc/riscv-mcpu.texi: Regenerated for Andes cpu list. + * doc/riscv-mtune.texi: Regenerated for andes-23-series. + * config/riscv/andes-23-series.md: New file. + +2025-11-28 Jakub Jelinek + + PR tree-optimization/122733 + * gimple-match-head.cc (gimple_match_range_of_expr): Return false + even when range_of_expr returns true, but the range is undefined_p. + * match.pd ((mult (plus:s@5 (mult:s@4 @0 @1) @2) @3)): Remove + vr0.undefined_p () check. + ((plus (mult:s@5 (plus:s@4 @0 @1) @2) @3)): Likewise. + ((X + M*N) / N -> X / N + M): Remove vr4.undefined_p () check. + ((X - M*N) / N -> X / N - M): Likewise. + ((y << x) == x, (y << x) != x): Use convert2? instead of + nop_convert2? and test INTEGRAL_TYPE_P on TREE_TYPE (@0) rather than + TREE_TYPE (@1). + ((y << x) {<,<=,>,>=} x): New simplification. + (((T)(A)) + CST -> (T)(A + CST)): Remove vr.undefined_p () check. + (x_5 == cstN ? cst4 : cst3): Remove r.undefined_p () check. + +2025-11-28 Tamar Christina + + PR middle-end/122890 + * optabs.cc (emit_cmp_and_jump_insns): Check for SSA Name. + +2025-11-27 Matthieu Longo + + * config/aarch64/aarch64-c.cc (aarch64_define_unconditional_macros): Define + __ARM_BUILDATTR64_FV when BA support is detected in GAS. + +2025-11-27 Wilco Dijkstra + + * config/aarch64/aarch64.md (ctz2): Use compact syntax. + +2025-11-27 Wilco Dijkstra + + * config/aarch64/aarch64.md (ffs2): Use gen_ctz. + (ctz2): Model ctz as a single target instruction. + +2025-11-27 Wilco Dijkstra + + * config/aarch64/atomics.md (*dmb): Expand release fence into dmb ishld + and dmb ishst. + +2025-11-27 Andrew Pinski + + * tree-ssa-reassoc.cc (rewrite_expr_tree): Swap + oe1 and oe2 if commutative code and not in + canonical order. + +2025-11-27 Georg-Johann Lay + + * config/avr/avr-mcus.def (AVR_MCUS): Add avr16la14, avr16la20, + avr16la28, avr16la32, avr32la14, avr32la20, avr32la28, avr32la32. + * doc/avr-mmcu.texi: Rebuild. + +2025-11-27 Robin Dapp + + PR tree-optimization/122855 + PR tree-optimization/122850 + * tree-ssa-forwprop.cc (simplify_vector_constructor): Nop + convert input if necessary. + +2025-11-27 Andrew Stubbs + + * config/gcn/gcn.cc (gcn_init_cumulative_args): Emit a warning if the + -mxnack setting looks wrong. + * config/gcn/mkoffload.cc: Include tree.h and omp-general.h. + (process_asm): Add omp_requires parameter. + Emit HSA_XNACK code into mkoffload_setup, as required. + (main): Modify HSACO_ATTR_OFF to preserve user-set -mxnack. + Pass omp_requires to process_asm. + +2025-11-27 Jakub Jelinek + + PR target/122714 + * gimple-lower-bitint.cc (bitint_large_huge::limb_access): Adjust + MEM_REFs offset for bitint_big_endian if ltype doesn't have the + same byte size as m_limb_type. + +2025-11-27 Richard Biener + + * tree-vect-stmts.cc (vectorizable_simd_clone_call): Fix + recording of the mask type again. Adjust placing of + mask arguments for non-masked calls. + +2025-11-27 Dhruv Chawla + + PR tree-optimization/122733 + * match.pd ((y << x) {<,<=,>,>=} x): Remove. + ((y << x) {==,!=} x): Call constant_boolean_node instead of + build_one_cst/build_zero_cst and combine into one pattern. + +2025-11-27 Jakub Jelinek + + * fold-const.h (expr_not_equal_to): Add gimple * argument defaulted + to NULL. + * fold-const.cc (expr_not_equal_to): Likewise, pass it through to + range_of_expr. + * generic-match-head.cc (gimple_match_ctx): New static inline. + * match.pd (X % -Y -> X % Y): Capture NEGATE and pass + gimple_match_ctx (@2) as new 3rd argument to expr_not_equal_to. + ((A * C) +- (B * C) -> (A+-B) * C): Pass gimple_match_ctx (@3) + as new 3rd argument to expr_not_equal_to. + (a rrotate (bitsize-b) -> a lrotate b): Likewise. + +2025-11-27 Jakub Jelinek + + PR tree-optimization/119683 + * gimple-match.h (gimple_match_ctx): Move to ... + * gimple-match-head.cc (gimple_match_ctx): ... here. Make static. + (gimple_match_range_of_expr): New static inline. + * match.pd ((mult (plus:s (mult:s @0 @1) @2) @3)): Use + gimple_match_range_of_expr. + ((plus (mult:s (plus:s @0 @1) @2) @3)): Likewise. + ((t * u) / u -> t): Likewise. + ((t * u) / v -> t * (u / v)): Likewise. + ((X + M*N) / N -> X / N + M): Likewise. + ((X - M*N) / N -> X / N - M): Likewise. + ((X + C) / N -> X / N + C / N): Likewise. + (((T)(A)) + CST -> (T)(A + CST)): Likewise + (x_5 == cstN ? cst4 : cst3): Likewise. Do r.set_varying + even when gimple_match_range_of_expr failed. + +2025-11-27 Christophe Lyon + + * config/arm/arm-builtins.cc (arm_init_mve_builtins): Remove + volatile qualifier. + +2025-11-27 Richard Biener + + PR tree-optimization/122885 + * tree-vect-loop.cc (vect_find_reusable_accumulator): Reject + mask vectors which do not use integer vector modes. + (vect_create_partial_epilog): Assert the same. + +2025-11-27 liuhongt + + * config/i386/i386-options.cc (set_ix86_tune_features): Set + gather/scatter tune if OPTION_SET_P. + * config/i386/i386.opt: Refactor mgather/mscatter. + +2025-11-27 Lulu Cheng + + * doc/extend.texi: Remove the incorrect prompt message. + +2025-11-27 Sandra Loosemore + + * doc/invoke.texi (Option Summary) : + Add --compile-std-module. + +2025-11-26 Jeff Law + + Revert: + 2025-10-14 Zhongyao Chen + + * common/config/riscv/riscv-common.cc (riscv_subset_list::get_profile_name): + New function. + * config/riscv/riscv-c.cc (riscv_cpu_cpp_builtins): Define + profile macro if a profile is detected. + * config/riscv/riscv-subset.h (riscv_subset_list::get_profile_name): Declare. + +2025-11-26 Alejandro Colomar + + * doc/extend.texi (Syntax Extensions): Document _Maxof & _Minof. + +2025-11-26 Tamar Christina + + * optabs.cc (emit_cmp_and_jump_insns): Check for non-single use. + +2025-11-26 Jeff Law + + PR rtl-optimization/122735 + * simplify-rtx.cc (simplify_binary_operation_1): When moving a SUBREG + from an outer expression to an inner operand, make sure to avoid + trying to create invalid SUBREGs. + +2025-11-26 Richard Earnshaw + + PR target/122867 + * config/arm/arm.cc (arm_print_operand): Use %- to + emit LOCAL_LABEL_PREFIX. + (arm_print_operand_punct_valid_p): Allow %- for punct + and make %_ valid for all compilation variants. + * config/arm/thumb2.md (*thumb2_cbz): Handle very + large branch ranges that exceed the limit of b. + (*thumb2_cbnz): Likewise. + +2025-11-26 Richard Biener + + PR tree-optimization/110571 + * tree-vectorizer.h (vect_need_peeling_or_partial_vectors_p): Remove. + * tree-vect-loop.cc (vect_need_peeling_or_partial_vectors_p): + Fix when called on epilog loops. Make static. + * tree-vect-loop-manip.cc (vect_do_peeling): Do not + re-compute LOOP_VINFO_PEELING_FOR_NITER. + +2025-11-26 Tamar Christina + + PR tree-optimization/122861 + * optabs.cc (emit_cmp_and_jump_insns): Check argument instead of result. + +2025-11-26 Jakub Jelinek + + * doc/invoke.texi (gnu++17): Remove comment about the default. + (c++20): Remove note about experimental support, except add a note + that modules are still experimental and need to be enabled separately. + (gnu++20): Likewise. Move here comment about the default. + (fcoroutines): Mention it is enabled by default for C++20 and later. + * doc/standards.texi: Document that the default for C++ is + -std=gnu++20. + +2025-11-26 Richard Biener + + * tree-vect-stmts.cc (vectorizable_simd_clone_call): Handle + AVX512 masking for loop masked SIMD clone call. + +2025-11-26 Jakub Jelinek + + PR middle-end/122835 + * tree-eh.cc (replace_goto_queue_1): Handle GIMPLE_ASM. + (maybe_record_in_goto_queue): Likewise. + (lower_eh_constructs_2): Likewise. + +2025-11-26 Jakub Jelinek + + PR tree-optimization/119683 + * gimple-match.h (gimple_match_ctx): New inline function. + * match.pd ((mult (plus:s (mult:s @0 @1) @2) @3)): Capture + PLUS, use get_range_query (cfun) instead of + get_global_range_query () and pass gimple_match_ctx (@5) + as 3rd argument to range_of_expr. + ((plus (mult:s (plus:s @0 @1) @2) @3)): Similarly for MULT, + with @4 instead of @5. + ((t * u) / u -> t): Similarly with @2 instead of @4. + ((t * u) / v -> t * (u / v)): Capture MULT, pass gimple_match_ctx (@3) + as 3rd argument to range_of_expr. + ((X + M*N) / N -> X / N + M): Pass gimple_match_ctx (@3) or + gimple_match_ctx (@4) as 3rd arg to some range_of_expr calls. + ((X - M*N) / N -> X / N - M): Likewise. + ((X + C) / N -> X / N + C / N): Similarly. + (((T)(A)) + CST -> (T)(A + CST)): Capture CONVERT, use + get_range_query (cfun) instead of get_global_range_query () + and pass gimple_match_ctx (@2) as 3rd argument to range_of_expr. + (x_5 == cstN ? cst4 : cst3): Capture EQNE and pass + gimple_match_ctx (@4) as 3rd argument to range_of_expr. + +2025-11-26 Soumya AR + + * config/aarch64/aarch64-json-tunings-parser.cc: Include + aarch64-json-tunings-parser-generated.inc. + * config/aarch64/aarch64-json-tunings-printer.cc: Include + aarch64-json-tunings-printer-generated.inc. + * config/aarch64/aarch64-opts.h (AARCH64_LDP_STP_POLICY): Use + aarch64-tuning-enums.def. + * config/aarch64/aarch64-protos.h (AARCH64_AUTOPREFETCH_MODE): Use + aarch64-tuning-enums.def. + * config/aarch64/t-aarch64: Invoke + aarch64-generate-json-tuning-routines.py if the schema is modified. + * config/aarch64/aarch64-generate-json-tuning-routines.py: New + maintenance script to generate JSON parser/printer routines. + * config/aarch64/aarch64-json-tunings-parser-generated.inc: New file. + * config/aarch64/aarch64-json-tunings-printer-generated.inc: New file. + * config/aarch64/aarch64-tuning-enums.def: New file. + +2025-11-26 Soumya AR + + * config.gcc: Add aarch64-json-tunings-parser.o. + * config/aarch64/aarch64.cc (aarch64_override_options_internal): Invoke + aarch64_load_tuning_params_from_json if -muser-provided-CPU= is + (aarch64_json_tunings_tests): Extern aarch64_json_tunings_tests(). + (aarch64_run_selftests): Add aarch64_json_tunings_tests(). + * config/aarch64/aarch64.opt: New option. + * config/aarch64/t-aarch64 (aarch64-json-tunings-parser.o): New define. + * config/aarch64/aarch64-json-schema.h: New file. + * config/aarch64/aarch64-json-tunings-parser.cc: New file. + * config/aarch64/aarch64-json-tunings-parser.h: New file. + +2025-11-26 Soumya AR + + * json.h (class object): Add get_map () method. + (is_a_helper, is_a_helper): + New template specializations. + +2025-11-26 Soumya AR + + * config.gcc: Add aarch64-json-tunings-printer.o. + * config/aarch64/aarch64.cc (aarch64_override_options_internal): Invoke + aarch64_print_tune_params if -fdump-tuning-model= is specified. + * config/aarch64/aarch64.opt: New option. + * config/aarch64/t-aarch64 (aarch64-json-tunings-printer.o): New define. + * config/aarch64/aarch64-json-tunings-printer.cc: New file. + * config/aarch64/aarch64-json-tunings-printer.h: New file. + +2025-11-26 Soumya AR + + * config/aarch64/aarch64-protos.h + (struct scale_addr_mode_cost): Remove const from struct members. + (struct cpu_addrcost_table): Likewise. + (struct cpu_regmove_cost): Likewise. + (struct simd_vec_cost): Likewise. + (struct sve_vec_cost): Likewise. + (struct aarch64_base_vec_issue_info): Likewise. + (struct aarch64_simd_vec_issue_info): Likewise. + (struct aarch64_sve_vec_issue_info): Likewise. + (struct aarch64_vec_issue_info): Likewise. + (struct cpu_vector_cost): Likewise. + (struct cpu_branch_cost): Likewise. + (struct cpu_approx_modes): Likewise. + (struct cpu_prefetch_tune): Likewise. + * config/arm/aarch-common-protos.h + (struct alu_cost_table): Remove const from struct members. + (struct mult_cost_table): Likewise. + (struct mem_cost_table): Likewise. + (struct fp_cost_table): Likewise. + (struct vector_cost_table): Likewise. + (struct cpu_cost_table): Likewise. + +2025-11-26 Dhruv Chawla + + PR middle-end/116815 + * config/aarch64/aarch64.md + (*aarch64_plus_within_3_): New pattern. + (*aarch64_minus_within_3): Likewise. + * config/aarch64/iterators.md (ovf_add_cmp): New code attribute. + (udf_sub_cmp): Likewise. + (UMAXMIN): New code iterator. + (ovf_commutate): New iterator. + (ovf_comm_opp): New int attribute. + +2025-11-26 Pan Li + + * match.pd: Add pattern for SAT_MUL form 7 include + mul and widen_mul. + +2025-11-26 Andrew Pinski + + * tree-ssa-phiprop.cc (propagate_with_phi): Only + calculate on demand post dom info when the new store + might trap. + +2025-11-26 Andrew Pinski + + PR tree-optimization/122847 + * tree-ssa-phiprop.cc (propagate_with_phi): Add type + check for reuse of the phi for the delayed statements. + +2025-11-25 Rainer Orth + + * configure.ac (gcc_cv_header_zstd_h): Save, restore CXXFLAGS, + LDFLAGS. + * configure: Regenerate. + +2025-11-25 Tamar Christina + + PR target/118974 + * config/aarch64/aarch64-simd.md (xor3): Rename ... + (@xor3): .. to this. + (cbranch4): Update comments. + (): New. + * config/aarch64/aarch64-sve.md (cbranch4): Update comment. + (): New. + (aarch64_ptest): Rename to ... + (@aarch64_ptest): .. this. + * config/aarch64/iterators.md (UNSPEC_CMP_ALL, UNSPEC_CMP_ANY, + UNSPEC_COND_CMP_ALL, UNSPEC_COND_CMP_ANY): New. + (optabs): Add them. + (CBRANCH_CMP, COND_CBRANCH_CMP, cbranch_op): New. + * config/aarch64/predicates.md (aarch64_cbranch_compare_operation): New. + +2025-11-25 Tamar Christina + + PR target/118974 + * tree-vect-stmts.cc (supports_vector_compare_and_branch): New. + (vectorizable_early_exit): Use it. + +2025-11-25 Tamar Christina + + PR target/118974 + * optabs.def (vec_cbranch_any_optab, vec_cbranch_all_optab, + cond_vec_cbranch_any_optab, cond_vec_cbranch_all_optab, + cond_len_vec_cbranch_any_optab, cond_len_vec_cbranch_all_optab): New. + * doc/md.texi: Document them. + * optabs.cc (prepare_cmp_insn): Refactor to take optab to check for + instead of hardcoded cbranch and support mask and len. + (emit_cmp_and_jump_insn_1, emit_cmp_and_jump_insns): Implement them. + (emit_conditional_move, emit_conditional_add, gen_cond_trap): Update + after changing function signatures to support new optabs. + +2025-11-25 Jason Merrill + + * doc/invoke.texi: Document --compile-std-module. + * gcc.cc (struct infile): Add artificial field. + (add_infile): Set it. + (driver::prepare_infiles): Check it. + +2025-11-25 Jason Merrill + + * doc/invoke.texi (C++ Modules): Remove TU-local caveat. + +2025-11-25 Jakub Jelinek + + PR middle-end/120052 + * gimplify.cc (gimplify_call_expr): For IFN_UBSAN_BOUNDS + call with integer_onep first argument, change that argument + to 0 and add TYPE_MAX_VALUE (TYPE_DOMAIN (arr_type)) to + 3rd argument before gimplification. + +2025-11-25 Jakub Jelinek + + PR middle-end/120564 + * omp-expand.cc (extract_omp_for_update_vars): Use build2 instead of + fold_build2 to build argument for gimple_build_cond_empty. + +2025-11-25 Jakub Jelinek + + * alias.cc (get_alias_set): Fix comment typo, TYPE_CANOINCAL + -> TYPE_CANONICAL. + +2025-11-25 Jakub Jelinek + + PR middle-end/122624 + * tree.cc (build_bitint_type): Use type_hash_canon_hash. + +2025-11-25 Rainer Orth + + * doc/sourcebuild.texi (Add Options): Document + check_function_bodies. + 2025-11-24 Alexandre Oliva PR rtl-optimization/122767 diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index e0428feb0905..112e13c0bf36 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20251125 +20251201 diff --git a/gcc/Makefile.in b/gcc/Makefile.in index 02cc38ce57e0..2c3194e7d1e3 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -3902,7 +3902,8 @@ $(build_htmldir)/gccinstall/index.html: $(TEXI_GCCINSTALL_FILES) .PHONY: regenerate-opt-urls OPT_URLS_HTML_DEPS = $(build_htmldir)/gcc/Option-Index.html \ $(build_htmldir)/gdc/Option-Index.html \ - $(build_htmldir)/gfortran/Option-Index.html + $(build_htmldir)/gfortran/Option-Index.html \ + $(build_htmldir)/ga68/Option-Index.html $(OPT_URLS_HTML_DEPS): %/Option-Index.html: %/index.html regenerate-opt-urls: $(srcdir)/regenerate-opt-urls.py $(OPT_URLS_HTML_DEPS) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8cbdbfe17701..1b0d40b8438f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,157 @@ +2025-11-30 Andrew Pinski + + * gcc-interface/lang.opt.urls: Regenerate. + +2025-11-27 Eric Botcazou + + * exp_ch6.adb (Expand_Actuals): Do not create activation chain and + master for build-in-place calls here but... + (Make_Build_In_Place_Call_In_Allocator): Use Unqual_Conv. + (Make_Build_In_Place_Call_In_Anonymous_Context): ...here instead. + Call Make_Build_In_Place_Call_In_Object_Declaration directly. + (Make_Build_In_Place_Iface_Call_In_Anonymous_Context): ...and here + instead. Add missing rewriting of the call. + +2025-11-27 Ronan Desplanques + + * doc/gnat_ugn/about_this_guide.rst: Minor fixes + * gnat_ugn.texi: Regenerate. + +2025-11-27 Eric Botcazou + + PR ada/122574 + * doc/gnat_ugn/building_executable_programs_with_gnat.rst (-gnatwp): + Replace reference to -gnatN with -gnatn and adjust accordingly. + * inline.adb: Remove clauses for Exp_Tss. + (Has_Initialized_Type): Delete. + (Add_Inlined_Subprogram): Test that the Is_Inlined flag is still set + on the subprogram. + * usage.adb (Usage): Adjust description of -gnatwp. + * gnat_ugn.texi: Regenerate. + +2025-11-27 Denis Mazzucato + + * sem_ch5.adb: Skip check for assignment that doesn't come from source. + +2025-11-27 Ronan Desplanques + + * exp_aggr.adb (Gen_Loop): Only preanalyze expressions we know won't + evaluated. + +2025-11-27 Tom Tromey + + * repinfo.adb (Visit): New procedure. + (List_GCC_Expression): Rewrite. + * repinfo.ads (Visit): New generic procedure. + +2025-11-27 Ghjuvan Lacambre + + * sem_ch13.adb (Analyze_Code_Statement): Do not emit error + message when only checking relaxed semantics. + +2025-11-27 Eric Botcazou + + * exp_ch7.adb (Build_Finalizer_Call): Delete. + (Build_Finalizer): Always insert the finalizer at the end of the + statement list in the non-package case. + (Expand_Cleanup_Actions): Attach the finalizer manually, if any. + * exp_smem.adb (Add_Shared_Var_Lock_Procs): Insert all the actions + directly in the transient scope. + +2025-11-27 Eric Botcazou + + * exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statement): Merge the + eslif condition with the if condition for cleanup actions. + * sem_ch6.adb (Analyze_Procedure_Call.Analyze_Call_And_Resolve): Get + rid of if statement whose condition is always true. + * sinfo.ads (Finally_Statements): Document their purpose. + +2025-11-27 Eric Botcazou + + * gen_il-gen-gen_nodes.adb (N_Extended_Return_Statement): Add + Activation_Chain_Entity semantic field. + * exp_ch3.adb (Build_Master): Use Build_Master_{Entity,Renaming} in + all cases. + (Expand_N_Object_Declaration): Small tweak. + * exp_ch6.adb (Make_Build_In_Place_Iface_Call_In_Allocator): Use + Build_Master_{Entity,Renaming} to build the master. + * exp_ch7.adb (Expand_N_Package_Declaration): Do not guard the call + to Build_Task_Activation_Call for the sake of consistency. + * exp_ch9.ads (Build_Class_Wide_Master): Delete. + (Find_Master_Scope): Likewise. + (Build_Protected_Subprogram_Call_Cleanup): Move to... + (First_Protected_Operation): Move to... + (Mark_Construct_As_Task_Master): New procedure. + * exp_ch9.adb (Build_Protected_Subprogram_Call_Cleanup): ...here. + (First_Protected_Operation): ...here. + (Build_Activation_Chain_Entity): Streamline handling of extended + return statements. + (Build_Class_Wide_Master): Delete. + (Build_Master_Entity): Streamline handling of extended return + statements and call Mark_Construct_As_Task_Master on the context. + (Build_Task_Activation_Call): Assert that the owner is not an + extended return statement. + (Find_Master_Scope): Delete. + (Mark_Construct_As_Task_Master): New procedure. + * sem_ch3.adb (Access_Definition): Use Build_Master_{Entity,Renaming} + in all cases to build a master. + * sem_ch6.adb (Check_Anonymous_Return): Rename to... + (Check_Anonymous_Access_Return_With_Tasks): ...this. At the end, + call Mark_Construct_As_Task_Master on the parent node. + (Analyze_Subprogram_Body_Helper): Adjust to above renaming. + (Create_Extra_Formals): Do not set Has_Master_Entity here. + * sinfo.ads (Activation_Chain_Entity): Adjust description. + +2025-11-27 Bob Duff + + * sem_ch13.adb (Aspect_Annotate): Avoid disturbing the tree of the + aspect. + * vast.adb: Enable Check_Parent_Present. + * exp_ch6.adb (Validate_Subprogram_Calls): Minor reformatting. + +2025-11-27 Eric Botcazou + + * exp_ch4.adb (Expand_N_Case_Expression): When not optimizing for a + specific context, call Make_Build_In_Place_Call_In_Anonymous_Context + on expressions of alternatives when they are calls to BIP functions. + (Expand_N_If_Expression): Likewise for the Then & Else expressions. + +2025-11-27 Bob Duff + + * frontend.adb: Move call to VAST from here... + * gnat1drv.adb: ...to here. + * vast.ads (VAST_If_Enabled): Rename main entry point of VAST from + VAST to VAST_If_Enabled. + * vast.adb: Miscellaneous improvements. Mostly debugging + improvements. Also enable Check_Error_Nodes. Also add checks: + Check_FE_Only, Check_Scope_Present, Check_Scope_Correct. + * debug.ads: Minor comment tweaks. The comment, "In the checks off + version of debug, the call to Set_Debug_Flag is always a null + operation." appears to be false, so is removed. + * debug.adb: Minor: Remove some code duplication. + * sinfo-utils.adb (nnd): Add comment warning about C vs. Ada + confusion. + +2025-11-27 Eric Botcazou + + * exp_ch6.ads (Needs_BIP_Task_Actuals): Adjust description. + * exp_ch6.adb (Expand_N_Extended_Return_Statement): Move activation + chain for every build-in-place function with task formal parameters + when the type of the return object might have tasks. + +2025-11-27 Ronan Desplanques + + * libgnat/s-dwalin.ads (Display_Mode_Type): New enumerated type. + (Symbolic_Traceback): Use new type in profile. + * libgnat/s-dwalin.adb (Symbolic_Traceback): Use new type in profile + and adapt body. + * libgnat/s-trasym__dwarf.adb (Multi_Module_Symbolic_Traceback): Fix + wrong call in body of one overload. Use new type in profile. Adapt + body. + (Symbolic_Traceback, Symbolic_Traceback_No_Lock, + Module_Symbolic_Traceback): Use new type in profile and adapt body. + (Calling_Entity): Adapt body. + 2025-11-24 Eric Botcazou PR ada/81106 diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index ffe4adc790e1..7b36426ed3e9 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -1292,15 +1292,15 @@ package body Debug is -- display the source file name, the time stamp expected and -- the time stamp found. + subtype Dig is Character range '1' .. '9'; + subtype LLet is Character range 'a' .. 'z'; + subtype ULet is Character range 'A' .. 'Z'; + -------------------- -- Set_Debug_Flag -- -------------------- procedure Set_Debug_Flag (C : Character; Val : Boolean := True) is - subtype Dig is Character range '1' .. '9'; - subtype LLet is Character range 'a' .. 'z'; - subtype ULet is Character range 'A' .. 'Z'; - begin if C in Dig then case Dig (C) is @@ -1443,10 +1443,6 @@ package body Debug is --------------------------- procedure Set_Dotted_Debug_Flag (C : Character; Val : Boolean := True) is - subtype Dig is Character range '1' .. '9'; - subtype LLet is Character range 'a' .. 'z'; - subtype ULet is Character range 'A' .. 'Z'; - begin if C in Dig then case Dig (C) is @@ -1592,10 +1588,6 @@ package body Debug is (C : Character; Val : Boolean := True) is - subtype Dig is Character range '1' .. '9'; - subtype LLet is Character range 'a' .. 'z'; - subtype ULet is Character range 'A' .. 'Z'; - begin if C in Dig then case Dig (C) is diff --git a/gcc/ada/debug.ads b/gcc/ada/debug.ads index e8d78b11cf14..5cc408bc75c5 100644 --- a/gcc/ada/debug.ads +++ b/gcc/ada/debug.ads @@ -30,22 +30,22 @@ package Debug is pragma Preelaborate; - ------------------------- - -- Dynamic Debug Flags -- - ------------------------- - - -- Flags that can be used to activate various specialized debugging output - -- information. The flags are preset to False, which corresponds to the - -- given output being suppressed. The individual flags can be turned on - -- using the undocumented switch dxxx where xxx is a string of letters for - -- flags to be turned on. Documentation on the current usage of these flags - -- is contained in the body of Debug rather than the spec, so that we don't - -- have to recompile the world when a new debug flag is added. + ----------------- + -- Debug Flags -- + ----------------- + + -- Flags that can be used to activate various debugging actions. They are + -- False by default, which means any output is suppressed. The individual + -- flags can be turned on using the undocumented switches -dxxx, -d.xxx, or + -- -d_xxx where xxx is a string of letters or digits for flags to be turned + -- on. For the compiler itself, "gnat" is prepended, as in -gnatdxxx, + -- -gnatd.xxx, or -gnatd_xxx. Documentation of each flag is given in the + -- package body. -- WARNING: There is a matching C declaration of a few flags in fe.h - Debug_Flag_A : Boolean := False; - Debug_Flag_B : Boolean := False; + Debug_Flag_A : Boolean := False; -- -da or -gnatda + Debug_Flag_B : Boolean := False; -- ... etc. Debug_Flag_C : Boolean := False; Debug_Flag_D : Boolean := False; Debug_Flag_E : Boolean := False; @@ -71,7 +71,7 @@ package Debug is Debug_Flag_Y : Boolean := False; Debug_Flag_Z : Boolean := False; - Debug_Flag_AA : Boolean := False; + Debug_Flag_AA : Boolean := False; -- -dA or -gnatdA Debug_Flag_BB : Boolean := False; Debug_Flag_CC : Boolean := False; Debug_Flag_DD : Boolean := False; @@ -98,7 +98,7 @@ package Debug is Debug_Flag_YY : Boolean := False; Debug_Flag_ZZ : Boolean := False; - Debug_Flag_1 : Boolean := False; + Debug_Flag_1 : Boolean := False; -- -d1 or -gnatd1 Debug_Flag_2 : Boolean := False; Debug_Flag_3 : Boolean := False; Debug_Flag_4 : Boolean := False; @@ -108,7 +108,7 @@ package Debug is Debug_Flag_8 : Boolean := False; Debug_Flag_9 : Boolean := False; - Debug_Flag_Dot_A : Boolean := False; + Debug_Flag_Dot_A : Boolean := False; -- -d.a or -gnatd.a Debug_Flag_Dot_B : Boolean := False; Debug_Flag_Dot_C : Boolean := False; Debug_Flag_Dot_D : Boolean := False; @@ -135,7 +135,7 @@ package Debug is Debug_Flag_Dot_Y : Boolean := False; Debug_Flag_Dot_Z : Boolean := False; - Debug_Flag_Dot_AA : Boolean := False; + Debug_Flag_Dot_AA : Boolean := False; -- -d.A or -gnatd.A Debug_Flag_Dot_BB : Boolean := False; Debug_Flag_Dot_CC : Boolean := False; Debug_Flag_Dot_DD : Boolean := False; @@ -162,7 +162,7 @@ package Debug is Debug_Flag_Dot_YY : Boolean := False; Debug_Flag_Dot_ZZ : Boolean := False; - Debug_Flag_Dot_1 : Boolean := False; + Debug_Flag_Dot_1 : Boolean := False; -- -d.1 or -gnatd.1 Debug_Flag_Dot_2 : Boolean := False; Debug_Flag_Dot_3 : Boolean := False; Debug_Flag_Dot_4 : Boolean := False; @@ -172,7 +172,7 @@ package Debug is Debug_Flag_Dot_8 : Boolean := False; Debug_Flag_Dot_9 : Boolean := False; - Debug_Flag_Underscore_A : Boolean := False; + Debug_Flag_Underscore_A : Boolean := False; -- -d_a or -gnatd_a Debug_Flag_Underscore_B : Boolean := False; Debug_Flag_Underscore_C : Boolean := False; Debug_Flag_Underscore_D : Boolean := False; @@ -199,7 +199,7 @@ package Debug is Debug_Flag_Underscore_Y : Boolean := False; Debug_Flag_Underscore_Z : Boolean := False; - Debug_Flag_Underscore_AA : Boolean := False; + Debug_Flag_Underscore_AA : Boolean := False; -- -d_A or -gnatd_A Debug_Flag_Underscore_BB : Boolean := False; Debug_Flag_Underscore_CC : Boolean := False; Debug_Flag_Underscore_DD : Boolean := False; @@ -226,7 +226,7 @@ package Debug is Debug_Flag_Underscore_YY : Boolean := False; Debug_Flag_Underscore_ZZ : Boolean := False; - Debug_Flag_Underscore_1 : Boolean := False; + Debug_Flag_Underscore_1 : Boolean := False; -- -d_1 or -gnatd_1 Debug_Flag_Underscore_2 : Boolean := False; Debug_Flag_Underscore_3 : Boolean := False; Debug_Flag_Underscore_4 : Boolean := False; @@ -238,8 +238,7 @@ package Debug is procedure Set_Debug_Flag (C : Character; Val : Boolean := True); -- Where C is 0-9, A-Z, or a-z, sets the corresponding debug flag to - -- the given value. In the checks off version of debug, the call to - -- Set_Debug_Flag is always a null operation. + -- the given value. procedure Set_Dotted_Debug_Flag (C : Character; Val : Boolean := True); -- Where C is 0-9, A-Z, or a-z, sets the corresponding dotted debug diff --git a/gcc/ada/doc/gnat_ugn/about_this_guide.rst b/gcc/ada/doc/gnat_ugn/about_this_guide.rst index d614fe1857bf..fc7bd8c96fe4 100644 --- a/gcc/ada/doc/gnat_ugn/about_this_guide.rst +++ b/gcc/ada/doc/gnat_ugn/about_this_guide.rst @@ -78,7 +78,7 @@ What You Should Know before Reading This Guide This guide assumes a basic familiarity with the Ada 95 language, as described in the International Standard ANSI/ISO/IEC-8652:1995, January 1995. -Reference manuals for Ada 95, Ada 2005, and Ada 2012 are included in +Reference manuals for Ada 95, Ada 2005, Ada 2012 and Ada 2022 are included in the GNAT documentation package. @@ -88,11 +88,12 @@ Related Information For further information about Ada and related tools, please refer to the following documents: -* :title:`Ada 95 Reference Manual`, :title:`Ada 2005 Reference Manual`, and - :title:`Ada 2012 Reference Manual`, which contain reference - material for the several revisions of the Ada language standard. +* :title:`Ada 95 Reference Manual`, :title:`Ada 2005 Reference Manual`, + :title:`Ada 2012 Reference Manual`, and :title:`Ada 2022 Reference Manual`, + which contain reference material for the several revisions of the Ada language + standard. -* :title:`GNAT Reference_Manual`, which contains all reference material for the GNAT +* :title:`GNAT Reference Manual`, which contains all reference material for the GNAT implementation of Ada. * :title:`Using GNAT Studio`, which describes the GNAT Studio @@ -104,11 +105,6 @@ following documents: * :title:`Debugging with GDB`, for all details on the use of the GNU source-level debugger. -* :title:`GNU Emacs Manual`, - for full information on the extensible editor and programming - environment Emacs. - - Conventions =========== .. index:: Conventions, typographical @@ -133,9 +129,9 @@ in this guide: * Examples are described by text - :: + .. code-block:: text - and then shown this way. + and then shown this way. * Commands that you enter are shown as preceded by a prompt string comprising the ``$`` character followed by a space. diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index 703607d28493..13654e185e0a 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -3587,13 +3587,13 @@ of the pragma in the :title:`GNAT_Reference_manual`). :switch:`-gnatwp` *Activate warnings on ineffective pragma Inlines.* - This switch activates warnings for failure of front end inlining - (activated by :switch:`-gnatN`) to inline a particular call. There are - many reasons for not being able to inline a call, including most - commonly that the call is too complex to inline. The default is - that such warnings are not given. - Warnings on ineffective inlining by the gcc back end can be activated - separately, using the gcc switch -Winline. + This switch activates warnings for failure of cross-unit inlining + (activated by :switch:`-gnatn`) to inline calls to a subprogram. + There are many reasons for not being able to inline these calls, + including most commonly that the subprogram body is too complex + to inline. The default is that such warnings are not given. + Warnings on ineffective inlining (within units) by the back end + can be activated separately, using the -Winline switch. .. index:: -gnatwP (gcc) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 51fbdb8e1e92..d195fb044d55 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -32,7 +32,6 @@ with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; -with Expander; use Expander; with Exp_Util; use Exp_Util; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; @@ -1604,7 +1603,6 @@ package body Exp_Aggr is and then Is_Array_Type (Etype (N)) and then No (Next_Index (Index)) then - Expander_Mode_Save_And_Set (False); Tcopy := New_Copy_Tree (Expr); Set_Parent (Tcopy, N); @@ -1614,9 +1612,10 @@ package body Exp_Aggr is Comp_Typ := Corresponding_Mutably_Tagged_Type (Comp_Typ); end if; - -- For iterated_component_association analyze and resolve - -- the expression with name of the index parameter visible. - -- To manipulate scopes, we use entity of the implicit loop. + -- For iterated_component_association (pre)analyze and + -- resolve the expression with name of the index parameter + -- visible. To manipulate scopes, we use entity of the + -- implicit loop. if Is_Iterated_Component then declare @@ -1625,18 +1624,16 @@ package body Exp_Aggr is begin Push_Scope (Scope (Index_Parameter)); Enter_Name (Index_Parameter); - Analyze_And_Resolve (Tcopy, Comp_Typ); + Preanalyze_And_Resolve (Tcopy, Comp_Typ); End_Scope; end; - -- For ordinary component association, just analyze and + -- For ordinary component association, just (pre)analyze and -- resolve the expression. else - Analyze_And_Resolve (Tcopy, Comp_Typ); + Preanalyze_And_Resolve (Tcopy, Comp_Typ); end if; - - Expander_Mode_Restore; end if; end if; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index a6b17184cb16..719217879551 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1279,27 +1279,17 @@ package body Exp_Ch11 is -- Add cleanup actions if required. No cleanup actions are needed in -- thunks associated with interfaces, because they only displace the - -- pointer to the object. For extended return statements, we need - -- cleanup actions if the Handled_Statement_Sequence contains generated - -- objects of controlled types, for example. We do not want to clean up - -- the return object. - - if Nkind (Parent (N)) not in N_Accept_Statement - | N_Extended_Return_Statement - | N_Package_Body - and then not Delay_Cleanups (Current_Scope) - and then not Is_Thunk (Current_Scope) - then - Expand_Cleanup_Actions (Parent (N)); + -- pointer to the object. - elsif Nkind (Parent (N)) = N_Extended_Return_Statement - and then Handled_Statement_Sequence (Parent (N)) = N + if Nkind (Parent (N)) not in N_Accept_Statement | N_Package_Body and then not Delay_Cleanups (Current_Scope) + and then not Is_Thunk (Current_Scope) then - pragma Assert (not Is_Thunk (Current_Scope)); Expand_Cleanup_Actions (Parent (N)); end if; + -- Protect the Finally_Statements with abort defer/undefer + if Present (Finally_Statements (N)) and then Abort_Allowed then if Exceptions_OK then Set_Finally_Statements diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index fbc7060a7442..57d2ec399745 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6684,7 +6684,8 @@ package body Exp_Ch3 is elsif not Is_Param_Block_Component_Type (Ptr_Typ) and then Is_Limited_Class_Wide_Type (Desig_Typ) then - Build_Class_Wide_Master (Ptr_Typ); + Build_Master_Entity (Ptr_Typ); + Build_Master_Renaming (Ptr_Typ); end if; end Build_Master; @@ -7651,7 +7652,9 @@ package body Exp_Ch3 is -- If tasks are being declared, make sure we have an activation chain -- defined for the tasks (has no effect if we already have one), and -- also that a Master variable is established (and that the appropriate - -- enclosing construct is established as a task master). + -- enclosing construct is established as a task master). And also deal + -- with objects initialized with a call to a BIP function that has task + -- formal parameters. if Has_Task (Typ) or else Might_Have_Tasks (Typ) @@ -7660,12 +7663,7 @@ package body Exp_Ch3 is then Build_Activation_Chain_Entity (N); - if Has_Task (Typ) then - Build_Master_Entity (Def_Id); - - -- Handle objects initialized with BIP function calls - - elsif Has_BIP_Init_Expr then + if Has_Task (Typ) or else Has_BIP_Init_Expr then Build_Master_Entity (Def_Id); end if; end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7c90aa0d1b8e..520ab683a6e2 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5368,7 +5368,17 @@ package body Exp_Ch4 is -- When the alternative's expression involves controlled function -- calls, generated temporaries are chained on the corresponding -- list of actions. These temporaries need to be finalized after - -- the case expression is evaluated. + -- the case expression is evaluated. We first need to make them + -- explicit for build-in-place functions in anonymous contexts, + -- because calls to these do not go through Expand_Ctrl_Actions. + + if Is_Build_In_Place_Function_Call (Expression (Alt)) + and then not Optimize_Assignment_Stmt + and then not Optimize_Return_Stmt + and then not Optimize_Object_Decl + then + Make_Build_In_Place_Call_In_Anonymous_Context (Expression (Alt)); + end if; Process_Transients_In_Expression (N, Actions (Alt)); @@ -6345,7 +6355,17 @@ package body Exp_Ch4 is -- When the "then" or "else" expressions involve controlled function -- calls, generated temporaries are chained on the corresponding list -- of actions. These temporaries need to be finalized after the if - -- expression is evaluated. + -- expression is evaluated. We first need to make them explicit for + -- build-in-place functions in anonymous contexts, because calls to + -- these do not go through Expand_Ctrl_Actions. + + if Is_Build_In_Place_Function_Call (Thenx) then + Make_Build_In_Place_Call_In_Anonymous_Context (Thenx); + end if; + + if Is_Build_In_Place_Function_Call (Elsex) then + Make_Build_In_Place_Call_In_Anonymous_Context (Elsex); + end if; Process_Transients_In_Expression (N, Then_Actions (N)); Process_Transients_In_Expression (N, Else_Actions (N)); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index f41dca311d1d..23150c73b917 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2729,9 +2729,7 @@ package body Exp_Ch6 is -- Ada 2005 (AI-318-02): If the actual parameter is a call to a -- build-in-place function, then a temporary return object needs - -- to be created and access to it must be passed to the function - -- (and ensure that we have an activation chain defined for tasks - -- and a Master variable). + -- to be created and access to it must be passed to the function. -- But do not do it here for intrinsic subprograms since this will -- be done properly after the subprogram is expanded. @@ -2740,11 +2738,6 @@ package body Exp_Ch6 is null; elsif Is_Build_In_Place_Function_Call (Actual) then - if Might_Have_Tasks (Etype (Actual)) then - Build_Activation_Chain_Entity (N); - Build_Master_Entity (Etype (Actual)); - end if; - Make_Build_In_Place_Call_In_Anonymous_Context (Actual); -- Ada 2005 (AI-318-02): Specialization of the previous case for @@ -2752,8 +2745,6 @@ package body Exp_Ch6 is -- object covers interface types. elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then - Build_Activation_Chain_Entity (N); - Build_Master_Entity (Etype (Actual)); Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual); end if; @@ -5908,8 +5899,6 @@ package body Exp_Ch6 is Loc : constant Source_Ptr := Sloc (N); Func_Id : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (N)); - Is_BIP_Func : constant Boolean := - Is_Build_In_Place_Function (Func_Id); Ret_Obj_Id : constant Entity_Id := First_Entity (Return_Statement_Entity (N)); Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); @@ -6024,12 +6013,13 @@ package body Exp_Ch6 is -- master. But Move_Activation_Chain updates their master to be that -- of the caller, so they will not be terminated unless the return -- statement completes unsuccessfully due to exception, abort, goto, - -- or exit. As a formality, we test whether the function requires the - -- result to be built in place, though that's necessarily true for - -- the case of result types with task parts. - - if Is_BIP_Func and then Has_Task (Ret_Typ) then + -- or exit. Note that we test that the function is both BIP and has + -- implicit task formal parameters, because not all functions whose + -- result type contains tasks have them (see Needs_BIP_Task_Actuals). + if Is_Build_In_Place_Function (Func_Id) + and then Needs_BIP_Task_Actuals (Func_Id) + then -- The return expression is an aggregate for a complex type which -- contains tasks. This particular case is left unexpanded since -- the regular expansion would insert all temporaries and @@ -6042,7 +6032,7 @@ package body Exp_Ch6 is -- Do not move the activation chain if the return object does not -- contain tasks. - if Has_Task (Etype (Ret_Obj_Id)) then + if Might_Have_Tasks (Etype (Ret_Obj_Id)) then Append_To (Stmts, Move_Activation_Chain (Func_Id)); end if; end if; @@ -9010,9 +9000,9 @@ package body Exp_Ch6 is (Allocator : Node_Id; Function_Call : Node_Id) is - Acc_Type : constant Entity_Id := Etype (Allocator); + Acc_Type : constant Entity_Id := Etype (Allocator); Loc : constant Source_Ptr := Sloc (Function_Call); - Func_Call : Node_Id := Function_Call; + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); Ref_Func_Call : Node_Id; Function_Id : Entity_Id; Result_Subt : Entity_Id; @@ -9025,16 +9015,6 @@ package body Exp_Ch6 is Chain : Entity_Id; -- activation chain, in case of tasks begin - -- Step past qualification or unchecked conversion (the latter can occur - -- in cases of calls to 'Input). - - if Nkind (Func_Call) in N_Qualified_Expression - | N_Type_Conversion - | N_Unchecked_Type_Conversion - then - Func_Call := Expression (Func_Call); - end if; - -- Mark the call as processed as a build-in-place call pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); @@ -9288,6 +9268,7 @@ package body Exp_Ch6 is Loc : constant Source_Ptr := Sloc (Function_Call); Func_Call : constant Node_Id := Unqual_Conv (Function_Call); Function_Id : Entity_Id; + Has_Tasks : Boolean; Known_Size : Boolean; Needs_Fin : Boolean; Result_Subt : Entity_Id; @@ -9316,6 +9297,7 @@ package body Exp_Ch6 is Warn_BIP (Func_Call); Result_Subt := Etype (Function_Id); + Has_Tasks := Might_Have_Tasks (Result_Subt); Known_Size := Caller_Known_Size (Func_Call, Result_Subt); Needs_Fin := Needs_Finalization (Result_Subt); @@ -9327,15 +9309,11 @@ package body Exp_Ch6 is -- object also needs to be created and an access value designating it -- passed as an actual. - -- Create a temporary which is initialized with the function call: - -- - -- Temp_Id : Func_Type := BIP_Func_Call; - -- - -- The initialization expression of the temporary will be rewritten by - -- the expander using the appropriate mechanism in Make_Build_In_Place_ - -- Call_In_Object_Declaration. + -- Insert a temporary before the call initialized with function call to + -- reuse the BIP machinery which takes care of adding the extra build-in + -- place actuals. - if Needs_Fin or else Known_Size then + if Needs_Fin or else Known_Size or else Has_Tasks then if Needs_Fin then Establish_Transient_Scope (Func_Call, Manage_Sec_Stack => not Known_Size); @@ -9352,9 +9330,20 @@ package body Exp_Ch6 is begin Set_Assignment_OK (Temp_Decl); + Expander_Mode_Save_And_Set (False); Insert_Action (Function_Call, Temp_Decl); + Expander_Mode_Restore; + + if Has_Tasks then + Build_Activation_Chain_Entity (Temp_Decl); + Build_Master_Entity (Temp_Id); + end if; + + Make_Build_In_Place_Call_In_Object_Declaration + (Obj_Decl => Temp_Decl, + Function_Call => Expression (Temp_Decl)); + Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc)); - Analyze (Function_Call); end; -- When the result subtype is unconstrained, the function must allocate @@ -9955,7 +9944,6 @@ package body Exp_Ch6 is Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call); Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call)); Set_Etype (Anon_Type, Anon_Type); - Build_Class_Wide_Master (Anon_Type); Tmp_Decl := Make_Object_Declaration (Loc, @@ -9979,6 +9967,9 @@ package body Exp_Ch6 is Insert_Action (Allocator, Tmp_Decl); Expander_Mode_Restore; + Build_Master_Entity (Anon_Type); + Build_Master_Renaming (Anon_Type); + Make_Build_In_Place_Call_In_Allocator (Allocator => Expression (Tmp_Decl), Function_Call => Expression (Expression (Tmp_Decl))); @@ -10033,9 +10024,14 @@ package body Exp_Ch6 is Insert_Action (Function_Call, Tmp_Decl); Expander_Mode_Restore; + Build_Activation_Chain_Entity (Tmp_Decl); + Build_Master_Entity (Tmp_Id); + Make_Build_In_Place_Iface_Call_In_Object_Declaration (Obj_Decl => Tmp_Decl, Function_Call => Expression (Tmp_Decl)); + + Rewrite (Function_Call, New_Occurrence_Of (Tmp_Id, Loc)); end Make_Build_In_Place_Iface_Call_In_Anonymous_Context; ---------------------------------------------------------- @@ -10559,8 +10555,9 @@ package body Exp_Ch6 is begin pragma Assert (Check_BIP_Actuals (Call_Node, Subp)); - -- Build-in-place function calls return their result by - -- reference. + + -- Build-in-place function calls return their result by + -- reference. pragma Assert (not Is_Build_In_Place_Function (Subp) or else Returns_By_Ref (Subp)); diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index b32ac77e5b49..15804eaf0acc 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -305,7 +305,8 @@ package Exp_Ch6 is -- BIP_Collection parameter (see type BIP_Formal_Kind). function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean; - -- Return True if the function returns an object of a type that has tasks. + -- Ada 2005 (AI-318-02): Return True if the function needs implicit + -- BIP_Task_Master and BIP_Activation_Chain parameters. function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id; -- Return the inner BIP function call removing any qualification from Expr diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index c170c23451d8..030134394cb3 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -428,13 +428,6 @@ package body Exp_Ch7 is -- does not contain the above constructs, the routine returns an empty -- list. - procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id); - -- N is a construct that contains a handled sequence of statements, Fin_Id - -- is the entity of a finalizer. Create an At_End handler that covers the - -- statements of N and calls Fin_Id. If the handled statement sequence has - -- an exception handler, the statements will be wrapped in a block to avoid - -- unwanted interaction with the new At_End handler. - procedure Build_Record_Deep_Procs (Typ : Entity_Id); -- Build the deep Initialize/Adjust/Finalize for a record Typ with -- Has_Controlled_Component set and store them using the TSS mechanism. @@ -2306,38 +2299,30 @@ package body Exp_Ch7 is Append_To (Decls, Fin_Spec); - -- When the finalizer acts solely as a cleanup routine, the body - -- is inserted right after the spec. - - if Acts_As_Clean and not Has_Ctrl_Objs then - Insert_After (Fin_Spec, Fin_Body); - - -- In other cases the body is inserted after the last statement + -- Manually freeze the spec. This is somewhat of a hack because a + -- subprogram is frozen when its body is seen and the freeze node + -- appears right before the body. However, in this case, the spec + -- must be frozen earlier since the At_End handler must be able to + -- call it. + -- + -- declare + -- procedure Fin_Id; -- Spec + -- [Fin_Id] -- Freeze node + -- begin + -- ... + -- at end + -- Fin_Id; -- At_End handler + -- end; - else - -- Manually freeze the spec. This is somewhat of a hack because - -- a subprogram is frozen when its body is seen and the freeze - -- node appears right before the body. However, in this case, - -- the spec must be frozen earlier since the At_End handler - -- must be able to call it. - -- - -- declare - -- procedure Fin_Id; -- Spec - -- [Fin_Id] -- Freeze node - -- begin - -- ... - -- at end - -- Fin_Id; -- At_End handler - -- end; + Ensure_Freeze_Node (Fin_Id); + Insert_After (Fin_Spec, Freeze_Node (Fin_Id)); + Mutate_Ekind (Fin_Id, E_Procedure); + Freeze_Extra_Formals (Fin_Id); + Set_Is_Frozen (Fin_Id); - Ensure_Freeze_Node (Fin_Id); - Insert_After (Fin_Spec, Freeze_Node (Fin_Id)); - Mutate_Ekind (Fin_Id, E_Procedure); - Freeze_Extra_Formals (Fin_Id); - Set_Is_Frozen (Fin_Id); + pragma Assert (Present (Stmts)); - Append_To (Stmts, Fin_Body); - end if; + Append_To (Stmts, Fin_Body); end if; Analyze (Fin_Spec, Suppress => All_Checks); @@ -3183,8 +3168,7 @@ package body Exp_Ch7 is Spec_Id := Defining_Identifier (Spec_Id); end if; - -- Accept statement, block, entry body, package body, protected body, - -- subprogram body or task body. + -- Block, entry body, package body, subprogram body or task body else Decls := Declarations (N); @@ -3310,76 +3294,6 @@ package body Exp_Ch7 is end if; end Build_Finalizer; - -------------------------- - -- Build_Finalizer_Call -- - -------------------------- - - procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is - begin - -- Do not perform this expansion in SPARK mode because we do not create - -- finalizers in the first place. - - if GNATprove_Mode then - return; - end if; - - -- If the construct to be cleaned up is a protected subprogram body, the - -- finalizer call needs to be associated with the block that wraps the - -- unprotected version of the subprogram. The following illustrates this - -- scenario: - - -- procedure Prot_SubpP is - -- procedure finalizer is - -- begin - -- Service_Entries (Prot_Obj); - -- Abort_Undefer; - -- end finalizer; - - -- begin - -- . . . - -- begin - -- Prot_SubpN (Prot_Obj); - -- at end - -- finalizer; - -- end; - -- end Prot_SubpP; - - declare - Loc : constant Source_Ptr := Sloc (N); - - Is_Protected_Subp_Body : constant Boolean := - Nkind (N) = N_Subprogram_Body - and then Is_Protected_Subprogram_Body (N); - -- True if N is the protected version of a subprogram that belongs to - -- a protected type. - - HSS : constant Node_Id := - (if Is_Protected_Subp_Body - then Handled_Statement_Sequence - (Last (Statements (Handled_Statement_Sequence (N)))) - else Handled_Statement_Sequence (N)); - - -- We attach the At_End_Proc to the HSS if this is an accept - -- statement or extended return statement. Also in the case of - -- a protected subprogram, because if Service_Entries raises an - -- exception, we do not lock the PO, so we also do not want to - -- unlock it. - - Use_HSS : constant Boolean := - Nkind (N) in N_Accept_Statement | N_Extended_Return_Statement - or else Is_Protected_Subp_Body; - - At_End_Proc_Bearer : constant Node_Id := (if Use_HSS then HSS else N); - begin - pragma Assert (No (At_End_Proc (At_End_Proc_Bearer))); - Set_At_End_Proc (At_End_Proc_Bearer, New_Occurrence_Of (Fin_Id, Loc)); - -- Attach reference to finalizer to tree, for LLVM use - Set_Parent (At_End_Proc (At_End_Proc_Bearer), At_End_Proc_Bearer); - Analyze (At_End_Proc (At_End_Proc_Bearer)); - Expand_At_End_Handler (At_End_Proc_Bearer, Empty); - end; - end Build_Finalizer_Call; - --------------------- -- Build_Late_Proc -- --------------------- @@ -4898,7 +4812,12 @@ package body Exp_Ch7 is Fin_Id => Fin_Id); if Present (Fin_Id) then - Build_Finalizer_Call (N, Fin_Id); + pragma Assert (No (At_End_Proc (N))); + Set_At_End_Proc (N, New_Occurrence_Of (Fin_Id, Sloc (N))); + -- Attach reference to finalizer to tree for LLVM + Set_Parent (At_End_Proc (N), N); + Analyze (At_End_Proc (N)); + Expand_At_End_Handler (N, Empty); end if; end; end Expand_Cleanup_Actions; @@ -5067,9 +4986,7 @@ package body Exp_Ch7 is -- Generate task activation call as last step of elaboration - if Present (Activation_Chain_Entity (N)) then - Build_Task_Activation_Call (N); - end if; + Build_Task_Activation_Call (N); -- Verify the run-time semantics of pragma Initial_Condition at the -- end of the private declarations when the package lacks a body. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 4c63ec978ff0..f23df88a5b81 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -243,6 +243,16 @@ package body Exp_Ch9 is -- cleanup handler that unlocks the object in all cases. For details, -- see Exp_Ch7.Expand_Cleanup_Actions. + procedure Build_Protected_Subprogram_Call_Cleanup + (Op_Spec : Node_Id; + Conc_Typ : Node_Id; + Loc : Source_Ptr; + Stmts : List_Id); + -- Append to Stmts the cleanups after a call to a protected subprogram + -- whose specification is Op_Spec. Conc_Typ is the concurrent type and Loc + -- the sloc for appended statements. The cleanup will either unlock the + -- protected object or serve pending entries. + function Build_Renamed_Formal_Declaration (New_F : Entity_Id; Formal : Entity_Id; @@ -424,6 +434,10 @@ package body Exp_Ch9 is -- the scope of Context_Id and Context_Decls is the declarative list of -- Context. + function First_Protected_Operation (D : List_Id) return Node_Id; + -- Given the declarations list for a protected body, find the + -- first protected operation body. + function Index_Object (Spec_Id : Entity_Id) return Entity_Id; -- Given a subprogram identifier, return the entity which is associated -- with the protection entry index in the Protected_Body_Subprogram or @@ -959,33 +973,6 @@ package body Exp_Ch9 is ----------------------------------- procedure Build_Activation_Chain_Entity (N : Node_Id) is - function Has_Activation_Chain (Stmt : Node_Id) return Boolean; - -- Determine whether an extended return statement has activation chain - - -------------------------- - -- Has_Activation_Chain -- - -------------------------- - - function Has_Activation_Chain (Stmt : Node_Id) return Boolean is - Decl : Node_Id; - - begin - Decl := First (Return_Object_Declarations (Stmt)); - while Present (Decl) loop - if Nkind (Decl) = N_Object_Declaration - and then Chars (Defining_Identifier (Decl)) = Name_uChain - then - return True; - end if; - - Next (Decl); - end loop; - - return False; - end Has_Activation_Chain; - - -- Local variables - Context : Node_Id; Context_Id : Entity_Id; Decls : List_Id; @@ -1010,19 +997,7 @@ package body Exp_Ch9 is -- If activation chain entity has not been declared already, create one - if Nkind (Context) = N_Extended_Return_Statement - or else No (Activation_Chain_Entity (Context)) - then - -- Since extended return statements do not store the entity of the - -- chain, examine the return object declarations to avoid creating - -- a duplicate. - - if Nkind (Context) = N_Extended_Return_Statement - and then Has_Activation_Chain (Context) - then - return; - end if; - + if No (Activation_Chain_Entity (Context)) then declare Loc : constant Source_Ptr := Sloc (Context); Chain : Entity_Id; @@ -1031,18 +1006,7 @@ package body Exp_Ch9 is begin Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); - -- Note: An extended return statement is not really a task - -- activator, but it does have an activation chain on which to - -- store the tasks temporarily. On successful return, the tasks - -- on this chain are moved to the chain passed in by the caller. - -- We do not build an Activation_Chain_Entity for an extended - -- return statement, because we do not want to build a call to - -- Activate_Tasks. Task activation is the responsibility of the - -- caller. - - if Nkind (Context) /= N_Extended_Return_Statement then - Set_Activation_Chain_Entity (Context, Chain); - end if; + Set_Activation_Chain_Entity (Context, Chain); Decl := Make_Object_Declaration (Loc, @@ -1184,155 +1148,6 @@ package body Exp_Ch9 is Parameter_Associations => New_List (Concurrent_Ref (N))); end Build_Call_With_Task; - ----------------------------- - -- Build_Class_Wide_Master -- - ----------------------------- - - procedure Build_Class_Wide_Master (Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (Typ); - Master_Decl : Node_Id; - Master_Id : Entity_Id; - Master_Scope : Entity_Id; - Name_Id : Node_Id; - Related_Node : Node_Id; - Ren_Decl : Node_Id; - - begin - -- No action needed if the run-time has no tasking support - - if Global_No_Tasking then - return; - end if; - - -- Find the declaration that created the access type, which is either a - -- type declaration, or an object declaration with an access definition, - -- in which case the type is anonymous. - - if Is_Itype (Typ) then - Related_Node := Associated_Node_For_Itype (Typ); - else - Related_Node := Parent (Typ); - end if; - - Master_Scope := Find_Master_Scope (Typ); - - -- Nothing to do if the master scope already contains a _master entity. - -- The only exception to this is the following scenario: - - -- Source_Scope - -- Transient_Scope_1 - -- _master - - -- Transient_Scope_2 - -- use of master - - -- In this case the source scope is marked as having the master entity - -- even though the actual declaration appears inside an inner scope. If - -- the second transient scope requires a _master, it cannot use the one - -- already declared because the entity is not visible. - - Name_Id := Make_Identifier (Loc, Name_uMaster); - Master_Decl := Empty; - - if not Has_Master_Entity (Master_Scope) - or else No (Current_Entity_In_Scope (Name_Id)) - then - declare - Ins_Nod : Node_Id; - Par_Nod : Node_Id; - - begin - Master_Decl := Build_Master_Declaration (Loc); - - -- Ensure that the master declaration is placed before its use - - Ins_Nod := Find_Hook_Context (Related_Node); - while not Is_List_Member (Ins_Nod) loop - Ins_Nod := Parent (Ins_Nod); - end loop; - - Par_Nod := Parent (List_Containing (Ins_Nod)); - - -- For internal blocks created by Wrap_Loop_Statement, Wrap_ - -- Statements_In_Block, and Build_Abort_Undefer_Block, remember - -- that they have a task master entity declaration; required by - -- Build_Master_Entity to avoid creating another master entity, - -- and also ensures that subsequent calls to Find_Master_Scope - -- return this scope as the master scope of Typ. - - if Is_Internal_Block (Par_Nod) then - Set_Has_Master_Entity (Entity (Identifier (Par_Nod))); - - elsif Nkind (Par_Nod) = N_Handled_Sequence_Of_Statements - and then Is_Internal_Block (Parent (Par_Nod)) - then - Set_Has_Master_Entity (Entity (Identifier (Parent (Par_Nod)))); - - -- Otherwise remember that this scope has an associated task - -- master entity declaration. - - else - Set_Has_Master_Entity (Master_Scope); - end if; - - Insert_Before (First (List_Containing (Ins_Nod)), Master_Decl); - Analyze (Master_Decl); - - -- Mark the containing scope as a task master. Masters associated - -- with return statements are already marked at this stage (see - -- Analyze_Subprogram_Body). - - if Ekind (Current_Scope) /= E_Return_Statement then - declare - Par : Node_Id := Related_Node; - - begin - while Nkind (Par) /= N_Compilation_Unit loop - Par := Parent (Par); - - -- If we fall off the top, we are at the outer level, - -- and the environment task is our effective master, - -- so nothing to mark. - - if Nkind (Par) in - N_Block_Statement | N_Subprogram_Body | N_Task_Body - then - Set_Is_Task_Master (Par); - exit; - end if; - end loop; - end; - end if; - end; - end if; - - Master_Id := - Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M')); - - -- Generate: - -- typeMnn renames _master; - - Ren_Decl := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Master_Id, - Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), - Name => Name_Id); - - -- If the master is declared locally, add the renaming declaration - -- immediately after it, to prevent access-before-elaboration in the - -- back-end. - - if Present (Master_Decl) then - Insert_After (Master_Decl, Ren_Decl); - Analyze (Ren_Decl); - - else - Insert_Action (Related_Node, Ren_Decl); - end if; - - Set_Master_Id (Typ, Master_Id); - end Build_Class_Wide_Master; - -------------------------------- -- Build_Corresponding_Record -- -------------------------------- @@ -3256,47 +3071,11 @@ package body Exp_Ch9 is Find_Enclosing_Context (Par, Context, Context_Id, Decls); end if; - -- When the enclosing context is a BIP function whose result type has - -- tasks, the function has an extra formal that is the master of the - -- tasks to be created by its returned object (that is, when its - -- enclosing context is a return statement). However, if the body of - -- the function creates tasks before its return statements, such tasks - -- need their own master. + pragma Assert (not Is_Finalizer (Context_Id)); - if Has_Master_Entity (Context_Id) - and then Ekind (Context_Id) = E_Function - and then Is_Build_In_Place_Function (Context_Id) - and then Needs_BIP_Task_Actuals (Context_Id) - then - -- No need to add it again if previously added - - declare - Master_Present : Boolean; + -- Nothing to do if the context already has a master - begin - -- Handle transient scopes - - if Context_Id /= Current_Scope then - Push_Scope (Context_Id); - Master_Present := - Present (Current_Entity_In_Scope (Name_uMaster)); - Pop_Scope; - else - Master_Present := - Present (Current_Entity_In_Scope (Name_uMaster)); - end if; - - if Master_Present then - return; - end if; - end; - - -- Nothing to do if the context already has a master; internally built - -- finalizers don't need a master. - - elsif Has_Master_Entity (Context_Id) - or else Is_Finalizer (Context_Id) - then + if Has_Master_Entity (Context_Id) then return; end if; @@ -3319,26 +3098,15 @@ package body Exp_Ch9 is Analyze (Decl); end if; - -- Mark the enclosing scope and its associated construct as being task - -- masters. - Set_Has_Master_Entity (Context_Id); - while Present (Context) - and then Nkind (Context) /= N_Compilation_Unit - loop - if Nkind (Context) in - N_Block_Statement | N_Subprogram_Body | N_Task_Body - then - Set_Is_Task_Master (Context); - exit; - - elsif Nkind (Parent (Context)) = N_Subunit then - Context := Corresponding_Stub (Parent (Context)); - end if; + -- Mark its associated construct as being a task master, but masters + -- associated with return statements are already marked at this stage + -- (see Analyze_Subprogram_Body_Helper). - Context := Parent (Context); - end loop; + if Nkind (Context) /= N_Extended_Return_Statement then + Mark_Construct_As_Task_Master (Context); + end if; end Build_Master_Entity; --------------------------- @@ -4680,6 +4448,13 @@ package body Exp_Ch9 is Owner := Unit_Declaration_Node (Corresponding_Spec (Owner)); end if; + -- An extended return statement is not really a task activator, but it + -- does have an activation chain on which to store tasks temporarily. + -- On successful return, the tasks on this chain are moved to the chain + -- passed in by the caller. + + pragma Assert (Nkind (Owner) /= N_Extended_Return_Statement); + Chain := Activation_Chain_Entity (Owner); -- Nothing to do when there are no tasks to activate. This is indicated @@ -13298,42 +13073,6 @@ package body Exp_Ch9 is pragma Assert (Present (Context_Decls)); end Find_Enclosing_Context; - ----------------------- - -- Find_Master_Scope -- - ----------------------- - - function Find_Master_Scope (E : Entity_Id) return Entity_Id is - S : Entity_Id; - - begin - -- In Ada 2005, the master is the innermost enclosing scope that is not - -- transient. If the enclosing block is the rewriting of a call or the - -- scope is an extended return statement this is valid master. The - -- master in an extended return is only used within the return, and is - -- subsequently overwritten in Move_Activation_Chain, but it must exist - -- now before that overwriting occurs. - - S := Scope (E); - - if Ada_Version >= Ada_2005 then - while Is_Internal (S) loop - if Nkind (Parent (S)) = N_Block_Statement - and then Has_Master_Entity (S) - then - exit; - - elsif Ekind (S) = E_Return_Statement then - exit; - - else - S := Scope (S); - end if; - end loop; - end if; - - return S; - end Find_Master_Scope; - ------------------------------- -- First_Protected_Operation -- ------------------------------- @@ -14650,6 +14389,32 @@ package body Exp_Ch9 is Attribute_Name => Name_Unchecked_Access))); end Make_Unlock_Statement; + ----------------------------------- + -- Mark_Construct_As_Task_Master -- + ----------------------------------- + + procedure Mark_Construct_As_Task_Master (N : Node_Id) is + Nod : Node_Id := N; + + begin + -- If we fall off the top, we are at the outer level, and the + -- environment task is our effective master, so nothing to mark. + + while Nkind (Nod) /= N_Compilation_Unit loop + if Nkind (Nod) in N_Block_Statement | N_Subprogram_Body | N_Task_Body + then + Set_Is_Task_Master (Nod); + exit; + + elsif Nkind (Parent (Nod)) = N_Subunit then + Nod := Corresponding_Stub (Parent (Nod)); + + else + Nod := Parent (Nod); + end if; + end loop; + end Mark_Construct_As_Task_Master; + ------------------------------ -- Next_Protected_Operation -- ------------------------------ diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 681114133fe1..4e5bdcc64347 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -50,11 +50,6 @@ package Exp_Ch9 is -- Task_Id of the associated task as the parameter. The caller is -- responsible for analyzing and resolving the resulting tree. - procedure Build_Class_Wide_Master (Typ : Entity_Id); - -- Given an access-to-limited class-wide type or an access-to-limited - -- interface, ensure that the designated type has a _master and generate - -- a renaming of the said master to service the access type. - function Build_Master_Declaration (Loc : Source_Ptr) return Node_Id; -- For targets supporting tasks, generate: -- _Master : constant Integer := Current_Master.all; @@ -99,16 +94,6 @@ package Exp_Ch9 is -- External is False if the call is to another protected subprogram within -- the same object. - procedure Build_Protected_Subprogram_Call_Cleanup - (Op_Spec : Node_Id; - Conc_Typ : Node_Id; - Loc : Source_Ptr; - Stmts : List_Id); - -- Append to Stmts the cleanups after a call to a protected subprogram - -- whose specification is Op_Spec. Conc_Typ is the concurrent type and Loc - -- the sloc for appended statements. The cleanup will either unlock the - -- protected object or serve pending entries. - procedure Build_Task_Activation_Call (N : Node_Id); -- This procedure is called for constructs that can be task activators, -- i.e. task bodies, subprogram bodies, package bodies and blocks. If the @@ -185,8 +170,7 @@ package Exp_Ch9 is (Sloc : Source_Ptr; Ent : Entity_Id; Index : Node_Id; - Ttyp : Entity_Id) - return Node_Id; + Ttyp : Entity_Id) return Node_Id; -- Returns an expression to compute a task entry index given the name of -- the entry or entry family. For the case of a task entry family, the -- Index parameter contains the expression for the subscript. Ttyp is the @@ -267,19 +251,6 @@ package Exp_Ch9 is -- Return the external version of a protected operation, which locks -- the object before invoking the internal protected subprogram body. - function Find_Master_Scope (E : Entity_Id) return Entity_Id; - -- When a type includes tasks, a master entity is created in the scope, to - -- be used by the runtime during activation. In general the master is the - -- immediate scope in which the type is declared, but in Ada 2005, in the - -- presence of synchronized classwide interfaces, the immediate scope of - -- an anonymous access type may be a transient scope, which has no run-time - -- presence. In this case, the scope of the master is the innermost scope - -- that comes from source. - - function First_Protected_Operation (D : List_Id) return Node_Id; - -- Given the declarations list for a protected body, find the - -- first protected operation body. - procedure Install_Private_Data_Declarations (Loc : Source_Ptr; Spec_Id : Entity_Id; @@ -345,6 +316,10 @@ package Exp_Ch9 is -- Given the entity of the record type created for a protected type, build -- a list of statements needed for proper initialization of the object. + procedure Mark_Construct_As_Task_Master (N : Node_Id); + -- Mark the innermost N_Block_Statement, N_Subprogram_Body or N_Task_Body + -- that is either N or enclosing N as being a task master. + function Next_Protected_Operation (N : Node_Id) return Node_Id; -- Given a protected operation node (a subprogram or entry body), find the -- following node in the declarations list. diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb index f9a35e892116..831b7c09f9e8 100644 --- a/gcc/ada/exp_smem.adb +++ b/gcc/ada/exp_smem.adb @@ -134,31 +134,18 @@ package body Exp_Smem is ------------------------------- procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is + Aft : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (N); Obj : constant Entity_Id := Entity (Expression (First_Actual (N))); - Vnm : String_Id; - Vid : Entity_Id; - Vde : Node_Id; - Aft : constant List_Id := New_List; In_Transient : constant Boolean := Scope_Is_Transient; + -- Whether we are already in a transient scope - function Build_Shared_Var_Lock_Call (RE : RE_Id) return Node_Id; - -- Return a procedure call statement for lock proc RTE - - -------------------------------- - -- Build_Shared_Var_Lock_Call -- - -------------------------------- + function Current_Scope return Int renames Scope_Stack.Last; + -- Return the index of the current scope - function Build_Shared_Var_Lock_Call (RE : RE_Id) return Node_Id is - begin - return - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE), Loc), - Parameter_Associations => - New_List (New_Occurrence_Of (Vid, Loc))); - end Build_Shared_Var_Lock_Call; + Vid : Entity_Id; + Vnm : String_Id; -- Start of processing for Add_Shared_Var_Lock_Procs @@ -176,53 +163,42 @@ package body Exp_Smem is -- If the lock/read/write/unlock actions for this object have already -- been emitted in the current scope, no need to perform them anew. - if In_Transient - and then Contains (Scope_Stack.Table (Scope_Stack.Last) - .Locked_Shared_Objects, - Obj) - then - return; + if In_Transient then + if Contains (Scope_Stack.Table (Current_Scope).Locked_Shared_Objects, + Obj) + then + return; + end if; + + else + Establish_Transient_Scope (N, Manage_Sec_Stack => False); end if; Build_Full_Name (Obj, Vnm); - -- Declare a constant string to hold the name of the shared object. - -- Note that this must occur outside of the transient scope, as the - -- scope's finalizer needs to have access to this object. Also, it - -- appears that GIGI does not support elaborating string literal - -- subtypes in transient scopes. + -- Declare a constant string to hold the name of the shared object Vid := Make_Temporary (Loc, 'N', Obj); - Vde := + Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Vid, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), - Expression => Make_String_Literal (Loc, Vnm)); - - -- Already in a transient scope. Make sure that we insert Vde outside - -- that scope. - - if In_Transient then - Insert_Before_And_Analyze (Node_To_Be_Wrapped, Vde); - - -- Not in a transient scope yet: insert Vde as an action on N prior to - -- establishing one. - - else - Insert_Action (N, Vde); - Establish_Transient_Scope (N, Manage_Sec_Stack => False); - end if; + Expression => Make_String_Literal (Loc, Vnm))); -- Mark object as locked in the current (transient) scope Append_New_Elmt - (Obj, - To => Scope_Stack.Table (Scope_Stack.Last).Locked_Shared_Objects); + (Obj, Scope_Stack.Table (Current_Scope).Locked_Shared_Objects); -- First insert the Lock call before - Insert_Action (N, Build_Shared_Var_Lock_Call (RE_Shared_Var_Lock)); + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Vid, Loc)))); -- Now, right after the Lock, insert a call to read the object @@ -237,7 +213,12 @@ package body Exp_Smem is -- Finally insert the Unlock call - Append_To (Aft, Build_Shared_Var_Lock_Call (RE_Shared_Var_Unlock)); + Append_To (Aft, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Vid, Loc)))); -- Store cleanup actions in transient scope diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index bb700a9a422c..f9292d808b4f 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -69,7 +69,6 @@ with Sinput.L; use Sinput.L; with SCIL_LL; with Tbuild; use Tbuild; with Types; use Types; -with VAST; with Warnsw; use Warnsw; procedure Frontend is @@ -518,10 +517,6 @@ begin null; end if; - -- Verify the validity of the tree - - VAST.VAST; - -- Validate all the subprogram calls; this work will be done by VAST; in -- the meantime it is done to check extra formals and it can be disabled -- using -gnatd_X (which also disables all the other assertions on extra diff --git a/gcc/ada/gcc-interface/lang.opt.urls b/gcc/ada/gcc-interface/lang.opt.urls index 3174c223a169..f2e837248f3a 100644 --- a/gcc/ada/gcc-interface/lang.opt.urls +++ b/gcc/ada/gcc-interface/lang.opt.urls @@ -1,7 +1,7 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/ada/gcc-interface/lang.opt and generated HTML I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) ; skipping UrlSuffix for 'Wall' due to multiple URLs: ; duplicate: 'gcc/Standard-Libraries.html#index-Wall-1' diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 9334c98e3945..750287f771bf 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -1015,6 +1015,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Extended_Return_Statement, N_Statement_Other_Than_Procedure_Call, (Sy (Return_Object_Declarations, List_Id), Sy (Handled_Statement_Sequence, Node_Id, Default_Empty), + Sm (Activation_Chain_Entity, Node_Id), Sm (Procedure_To_Call, Node_Id), Sm (Return_Statement_Entity, Node_Id), Sm (Storage_Pool, Node_Id))); diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 176f2e2a4a23..4653741501a1 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -83,6 +83,7 @@ with Uname; use Uname; with Urealp; with Usage; with Validsw; use Validsw; +with VAST; with Warnsw; use Warnsw; with System.Assertions; @@ -1451,6 +1452,10 @@ begin end if; end if; + -- Verify the validity of the tree (if enabled) + + VAST.VAST_If_Enabled; + -- In -gnatc mode we only do annotation if -gnatR is also set, or if -- -gnatwz is enabled (default setting) and there is an unchecked -- conversion that involves a type whose size is not statically known, diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 77db8789ca82..2b6ab38dd534 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Nov 18, 2025 +GNAT User's Guide for Native Platforms , Nov 27, 2025 AdaCore @@ -648,7 +648,7 @@ in an Ada program. This guide assumes a basic familiarity with the Ada 95 language, as described in the International Standard ANSI/ISO/IEC-8652:1995, January 1995. -Reference manuals for Ada 95, Ada 2005, and Ada 2012 are included in +Reference manuals for Ada 95, Ada 2005, Ada 2012 and Ada 2022 are included in the GNAT documentation package. @node Related Information,Conventions,What You Should Know before Reading This Guide,About This Guide @@ -663,12 +663,13 @@ following documents: @itemize * @item -@cite{Ada 95 Reference Manual}, @cite{Ada 2005 Reference Manual}, and -@cite{Ada 2012 Reference Manual}, which contain reference -material for the several revisions of the Ada language standard. +@cite{Ada 95 Reference Manual}, @cite{Ada 2005 Reference Manual}, +@cite{Ada 2012 Reference Manual}, and @cite{Ada 2022 Reference Manual}, +which contain reference material for the several revisions of the Ada language +standard. @item -@cite{GNAT Reference_Manual}, which contains all reference material for the GNAT +@cite{GNAT Reference Manual}, which contains all reference material for the GNAT implementation of Ada. @item @@ -682,11 +683,6 @@ main GNAT Studio features through examples. @item @cite{Debugging with GDB}, for all details on the use of the GNU source-level debugger. - -@item -@cite{GNU Emacs Manual}, -for full information on the extensible editor and programming -environment Emacs. @end itemize @node Conventions,,Related Information,About This Guide @@ -11942,13 +11938,13 @@ the resulting assigned value is never read. `Activate warnings on ineffective pragma Inlines.' -This switch activates warnings for failure of front end inlining -(activated by @code{-gnatN}) to inline a particular call. There are -many reasons for not being able to inline a call, including most -commonly that the call is too complex to inline. The default is -that such warnings are not given. -Warnings on ineffective inlining by the gcc back end can be activated -separately, using the gcc switch -Winline. +This switch activates warnings for failure of cross-unit inlining +(activated by @code{-gnatn}) to inline calls to a subprogram. +There are many reasons for not being able to inline these calls, +including most commonly that the subprogram body is too complex +to inline. The default is that such warnings are not given. +Warnings on ineffective inlining (within units) by the back end +can be activated separately, using the -Winline switch. @end table @geindex -gnatwP (gcc) diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index a966c28351f3..0cb879a7133a 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -34,7 +34,6 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; -with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; with Fname.UF; use Fname.UF; @@ -287,10 +286,6 @@ package body Inline is -- Return the entity node for the unit containing E. Always return the spec -- for a package. - function Has_Initialized_Type (E : Entity_Id) return Boolean; - -- If a candidate for inlining contains type declarations for types with - -- nontrivial initialization procedures, they are not worth inlining. - function Has_Single_Return (N : Node_Id) return Boolean; -- In general we cannot inline functions that return unconstrained type. -- However, we can handle such functions if all return statements return @@ -758,14 +753,15 @@ package body Inline is -- an instance whose body will be analyzed anyway or the subprogram was -- generated as a body by the compiler (for example an initialization -- procedure) or its declaration was provided along with the body (for - -- example an expression function) and it does not declare types with - -- nontrivial initialization procedures. + -- example an expression function). Note that we need to test again the + -- Is_Inlined flag because Analyze_Subprogram_Body_Helper may have reset + -- it if the body contains excluded declarations or statements. if (Is_Inlined (Pack) or else Is_Generic_Instance (Pack) or else Nkind (Decl) = N_Subprogram_Body or else Present (Corresponding_Body (Decl))) - and then not Has_Initialized_Type (E) + and then Is_Inlined (E) then Register_Backend_Inlined_Subprogram (E); @@ -4528,35 +4524,6 @@ package body Inline is return False; end Has_Excluded_Statement; - -------------------------- - -- Has_Initialized_Type -- - -------------------------- - - function Has_Initialized_Type (E : Entity_Id) return Boolean is - E_Body : constant Node_Id := Subprogram_Body (E); - Decl : Node_Id; - - begin - if No (E_Body) then -- imported subprogram - return False; - - else - Decl := First (Declarations (E_Body)); - while Present (Decl) loop - if Nkind (Decl) = N_Full_Type_Declaration - and then Comes_From_Source (Decl) - and then Present (Init_Proc (Defining_Identifier (Decl))) - then - return True; - end if; - - Next (Decl); - end loop; - end if; - - return False; - end Has_Initialized_Type; - ----------------------- -- Has_Single_Return -- ----------------------- diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb index 713aad4a304f..75c96619f994 100644 --- a/gcc/ada/libgnat/s-dwalin.adb +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -1915,7 +1915,7 @@ package body System.Dwarf_Lines is (Cin : Dwarf_Context; Traceback : STE.Tracebacks_Array; Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean; + Display_Mode : Display_Mode_Type; Symbol_Found : out Boolean; Res : in out System.Bounded_Strings.Bounded_String) is @@ -1954,7 +1954,7 @@ package body System.Dwarf_Lines is -- If we're not requested to suppress hex addresses, emit it now. - if not Suppress_Hex and then not Subprg_Name_Only then + if not Suppress_Hex and then Display_Mode = Full then Append_Address (Res, Addr_In_Traceback); Append (Res, ' '); end if; @@ -2007,7 +2007,7 @@ package body System.Dwarf_Lines is Append (Res, "???"); end if; - if not Subprg_Name_Only then + if Display_Mode = Full then Append (Res, " at "); Append (Res, String (File_Name (1 .. Last))); Append (Res, ':'); @@ -2023,7 +2023,7 @@ package body System.Dwarf_Lines is Append (Res, "???"); end if; - if not Subprg_Name_Only then + if Display_Mode = Full then Append (Res, " at ???"); end if; end if; diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads index 641e515e62f8..17bf0937608f 100644 --- a/gcc/ada/libgnat/s-dwalin.ads +++ b/gcc/ada/libgnat/s-dwalin.ads @@ -79,13 +79,19 @@ package System.Dwarf_Lines is procedure Enable_Cache (C : in out Dwarf_Context); -- Read symbol information to speed up Symbolic_Traceback. + type Display_Mode_Type is (Full, Subprg_Name_Only); + -- This type is used to configure how frames are displayed. + -- In Subprg_Name_Only mode, only the name of the subprogram is displayed + -- for a frame. In Full mode, additional information is displayed on top of + -- that. + procedure Symbolic_Traceback - (Cin : Dwarf_Context; - Traceback : STE.Tracebacks_Array; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean; - Symbol_Found : out Boolean; - Res : in out System.Bounded_Strings.Bounded_String); + (Cin : Dwarf_Context; + Traceback : STE.Tracebacks_Array; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type; + Symbol_Found : out Boolean; + Res : in out System.Bounded_Strings.Bounded_String); -- Generate a string for a traceback suitable for displaying to the user. -- If one or more symbols are found, Symbol_Found is set to True. This -- allows the caller to fall back to hexadecimal addresses. diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb index 09026c91efe8..0c4a036e1398 100644 --- a/gcc/ada/libgnat/s-trasym__dwarf.adb +++ b/gcc/ada/libgnat/s-trasym__dwarf.adb @@ -96,16 +96,15 @@ package body System.Traceback.Symbolic is -- Initialize Exec_Module if not already initialized function Symbolic_Traceback - (Traceback : System.Traceback_Entries.Tracebacks_Array; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean) return String; + (Traceback : System.Traceback_Entries.Tracebacks_Array; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type) return String; function Symbolic_Traceback (E : Ada.Exceptions.Exception_Occurrence; Suppress_Hex : Boolean) return String; -- Suppress_Hex means do not print any hexadecimal addresses, even if the - -- symbol is not available. Subprg_Name_Only means to only print the - -- subprogram name for each frame, as opposed to the complete description - -- of the frame. + -- symbol is not available. Display_Mode configures how frames for which + -- symbols are available are printed. function Lt (Left, Right : Module_Cache_Acc) return Boolean; -- Sort function for Module_Cache @@ -169,34 +168,34 @@ package body System.Traceback.Symbolic is -- Non-symbolic traceback (simply write addresses in hexa) procedure Symbolic_Traceback_No_Lock - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean; - Res : in out Bounded_String); + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type; + Res : in out Bounded_String); -- Like the public Symbolic_Traceback except there is no provision against -- concurrent accesses. procedure Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean; - Res : in out Bounded_String); + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type; + Res : in out Bounded_String); -- Returns the Traceback for a given module procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean; - Res : in out Bounded_String); + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type; + Res : in out Bounded_String); -- Build string containing symbolic traceback for the given call chain procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean; - Res : in out Bounded_String); + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type; + Res : in out Bounded_String); -- Likewise but using Module Max_String_Length : constant := 4096; @@ -357,7 +356,9 @@ package body System.Traceback.Symbolic is declare With_Trailing_Newline : constant String := Symbolic_Traceback - (Traceback, Suppress_Hex => True, Subprg_Name_Only => True); + (Traceback, + Suppress_Hex => True, + Display_Mode => Subprg_Name_Only); begin return With_Trailing_Newline @@ -487,31 +488,28 @@ package body System.Traceback.Symbolic is ------------------------------- procedure Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean; - Res : in out Bounded_String) + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type; + Res : in out Bounded_String) is Success : Boolean; begin - if Symbolic.Module_Name.Is_Supported and then not Subprg_Name_Only then + if Symbolic.Module_Name.Is_Supported and then Display_Mode = Full then Append (Res, '['); Append (Res, Module.Name.all); Append (Res, ']' & ASCII.LF); end if; Dwarf_Lines.Symbolic_Traceback - (Module.C, - Traceback, - Suppress_Hex, - Subprg_Name_Only, - Success, - Res); + (Module.C, Traceback, Suppress_Hex, Display_Mode, Success, Res); if not Success then Hexa_Traceback - (Traceback, Suppress_Hex or else Subprg_Name_Only, Res); + (Traceback, + Suppress_Hex or else Display_Mode = Subprg_Name_Only, + Res); end if; -- We must not allow an unhandled exception here, since this function @@ -527,10 +525,10 @@ package body System.Traceback.Symbolic is ------------------------------------- procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean; - Res : in out Bounded_String) + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type; + Res : in out Bounded_String) is F : constant Natural := Traceback'First; begin @@ -555,8 +553,8 @@ package body System.Traceback.Symbolic is Multi_Module_Symbolic_Traceback (Traceback, Modules_Cache (Mid).all, - Subprg_Name_Only, Suppress_Hex, + Display_Mode, Res); return; else @@ -569,7 +567,7 @@ package body System.Traceback.Symbolic is Multi_Module_Symbolic_Traceback (Traceback (F + 1 .. Traceback'Last), Suppress_Hex, - Subprg_Name_Only, + Display_Mode, Res); end; else @@ -577,7 +575,7 @@ package body System.Traceback.Symbolic is -- First try the executable if Is_Inside (Exec_Module.C, Traceback (F)) then Multi_Module_Symbolic_Traceback - (Traceback, Exec_Module, Suppress_Hex, Subprg_Name_Only, Res); + (Traceback, Exec_Module, Suppress_Hex, Display_Mode, Res); return; end if; @@ -593,7 +591,7 @@ package body System.Traceback.Symbolic is Init_Module (Module, Success, M_Name, Load_Addr); if Success then Multi_Module_Symbolic_Traceback - (Traceback, Module, Suppress_Hex, Subprg_Name_Only, Res); + (Traceback, Module, Suppress_Hex, Display_Mode, Res); Close_Module (Module); else -- Module not found @@ -601,7 +599,7 @@ package body System.Traceback.Symbolic is Multi_Module_Symbolic_Traceback (Traceback (F + 1 .. Traceback'Last), Suppress_Hex, - Subprg_Name_Only, + Display_Mode, Res); end if; end; @@ -609,11 +607,11 @@ package body System.Traceback.Symbolic is end Multi_Module_Symbolic_Traceback; procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean; - Res : in out Bounded_String) + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type; + Res : in out Bounded_String) is Pos : Positive; begin @@ -638,13 +636,10 @@ package body System.Traceback.Symbolic is (Traceback (Traceback'First .. Pos - 1), Module, Suppress_Hex, - Subprg_Name_Only, + Display_Mode, Res); Multi_Module_Symbolic_Traceback - (Traceback (Pos .. Traceback'Last), - Suppress_Hex, - Subprg_Name_Only, - Res); + (Traceback (Pos .. Traceback'Last), Suppress_Hex, Display_Mode, Res); end Multi_Module_Symbolic_Traceback; -------------------- @@ -674,22 +669,24 @@ package body System.Traceback.Symbolic is -------------------------------- procedure Symbolic_Traceback_No_Lock - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean; - Res : in out Bounded_String) is + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type; + Res : in out Bounded_String) is begin if Symbolic.Module_Name.Is_Supported then Multi_Module_Symbolic_Traceback - (Traceback, Suppress_Hex, Subprg_Name_Only, Res); + (Traceback, Suppress_Hex, Display_Mode, Res); else if Exec_Module_State = Failed then Append (Res, "Call stack traceback locations:" & ASCII.LF); Hexa_Traceback - (Traceback, Suppress_Hex or else Subprg_Name_Only, Res); + (Traceback, + Suppress_Hex or else Display_Mode = Subprg_Name_Only, + Res); else Module_Symbolic_Traceback - (Traceback, Exec_Module, Suppress_Hex, Subprg_Name_Only, Res); + (Traceback, Exec_Module, Suppress_Hex, Display_Mode, Res); end if; end if; end Symbolic_Traceback_No_Lock; @@ -702,9 +699,9 @@ package body System.Traceback.Symbolic is -- Copied from Ada.Exceptions.Exception_Data function Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Subprg_Name_Only : Boolean) return String + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Display_Mode : Display_Mode_Type) return String is Load_Address : constant Address := Get_Executable_Load_Address; Res : Bounded_String (Max_Length => Max_String_Length); @@ -712,13 +709,12 @@ package body System.Traceback.Symbolic is begin System.Soft_Links.Lock_Task.all; Init_Exec_Module; - if not Subprg_Name_Only and then Load_Address /= Null_Address then + if Display_Mode = Full and then Load_Address /= Null_Address then Append (Res, LDAD_Header); Append_Address (Res, Load_Address); Append (Res, ASCII.LF); end if; - Symbolic_Traceback_No_Lock - (Traceback, Suppress_Hex, Subprg_Name_Only, Res); + Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Display_Mode, Res); System.Soft_Links.Unlock_Task.all; return To_String (Res); @@ -734,7 +730,7 @@ package body System.Traceback.Symbolic is begin return Symbolic_Traceback - (Traceback, Suppress_Hex => False, Subprg_Name_Only => False); + (Traceback, Suppress_Hex => False, Display_Mode => Full); end Symbolic_Traceback; function Symbolic_Traceback_No_Hex @@ -742,7 +738,7 @@ package body System.Traceback.Symbolic is begin return Symbolic_Traceback - (Traceback, Suppress_Hex => True, Subprg_Name_Only => False); + (Traceback, Suppress_Hex => True, Display_Mode => Full); end Symbolic_Traceback_No_Hex; function Symbolic_Traceback @@ -752,9 +748,7 @@ package body System.Traceback.Symbolic is begin return Symbolic_Traceback - (Ada.Exceptions.Traceback.Tracebacks (E), - Suppress_Hex, - False); + (Ada.Exceptions.Traceback.Tracebacks (E), Suppress_Hex, Full); end Symbolic_Traceback; function Symbolic_Traceback diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index a8cb126d1929..14c293056900 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -283,6 +283,64 @@ package body Repinfo is return U >= Uint_0; end Is_Static_SO_Ref; + ----------- + -- Visit -- + ----------- + + procedure Visit (Expr : Node_Ref_Or_Val) is + begin + pragma Assert (Present (Expr)); + if Expr >= 0 then + Visit_Constant (Expr); + return; + end if; + + declare + Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Expr)); + begin + case Node.Expr is + when Cond_Expr => + Visit_Cond_Expr (Node.Op1, Node.Op2, Node.Op3); + + when Plus_Expr + | Minus_Expr + | Mult_Expr + | Trunc_Div_Expr + | Ceil_Div_Expr + | Floor_Div_Expr + | Trunc_Mod_Expr + | Ceil_Mod_Expr + | Floor_Mod_Expr + | Exact_Div_Expr + | Min_Expr + | Max_Expr + | Truth_And_Expr + | Truth_Or_Expr + | Truth_Xor_Expr + | Lt_Expr + | Le_Expr + | Gt_Expr + | Ge_Expr + | Eq_Expr + | Ne_Expr + | Bit_And_Expr + => + Visit_Binop (Node.Expr, Node.Op1, Node.Op2); + + when Negate_Expr + | Abs_Expr + | Truth_Not_Expr => + Visit_Unop (Node.Expr, Node.Op1); + + when Discrim_Val => + Visit_Discriminant (Node.Op1); + + when Dynamic_Val => + Visit_Variable (Node.Op1); + end case; + end; + end Visit; + --------- -- lgx -- --------- @@ -581,189 +639,177 @@ package body Repinfo is procedure List_GCC_Expression (U : Node_Ref_Or_Val) is - procedure Print_Expr (Val : Node_Ref_Or_Val); - -- Internal recursive procedure to print expression + procedure Unop (Code : TCode; Op : Node_Ref_Or_Val); + procedure Binop (Code : TCode; Lhs : Node_Ref_Or_Val; + Rhs : Node_Ref_Or_Val); + procedure Cond_Expr (Test : Node_Ref_Or_Val; + Lhs : Node_Ref_Or_Val; + Rhs : Node_Ref_Or_Val); + procedure Const (Val : Node_Ref_Or_Val); + procedure Discriminant (Val : Node_Ref_Or_Val); + procedure Variable (Val : Node_Ref_Or_Val); + + procedure Print_It is new Visit (Visit_Unop => Unop, + Visit_Binop => Binop, + Visit_Cond_Expr => Cond_Expr, + Visit_Constant => Const, + Visit_Discriminant => Discriminant, + Visit_Variable => Variable); + + procedure Unop (Code : TCode; Op : Node_Ref_Or_Val) is + procedure Emit (S : String); + procedure Emit (S : String) is + begin + if List_Representation_Info_To_JSON then + Write_Str ("{ ""code"": """); + if S (S'Last) = ' ' then + Write_Str (S (S'First .. S'Last - 1)); + else + Write_Str (S); + end if; + Write_Str (""", ""operands"": [ "); + Print_It (Op); + Write_Str (" ] }"); + else + Write_Str (S); + Print_It (Op); + end if; + end Emit; + begin + case Code is + when Negate_Expr => + Emit ("-"); + when Abs_Expr => + Emit ("abs "); + when Truth_Not_Expr => + Emit ("not "); + when Discrim_Val => + Emit ("#"); + when Dynamic_Val => + Emit ("var"); + when others => + Emit ("ERROR"); + end case; + end Unop; - ---------------- - -- Print_Expr -- - ---------------- + procedure Binop (Code : TCode; Lhs : Node_Ref_Or_Val; + Rhs : Node_Ref_Or_Val) + is + procedure Emit (S : String); + procedure Emit (S : String) is + begin + if List_Representation_Info_To_JSON then + Write_Str ("{ ""code"": """); + Write_Str (S (S'First + 1 .. S'Last - 1)); + Write_Str (""", ""operands"": [ "); + Print_It (Lhs); + Write_Str (", "); + Print_It (Rhs); + Write_Str (" ] }"); + else + Write_Char ('('); + Print_It (Lhs); + Write_Str (S); + Print_It (Rhs); + Write_Char (')'); + end if; + end Emit; - procedure Print_Expr (Val : Node_Ref_Or_Val) is begin - if Val >= 0 then - UI_Write (Val, Decimal); + case Code is + when Plus_Expr => + Emit (" + "); + when Minus_Expr => + Emit (" - "); + when Mult_Expr => + Emit (" * "); + when Trunc_Div_Expr => + Emit (" /t "); + when Ceil_Div_Expr => + Emit (" /c "); + when Floor_Div_Expr => + Emit (" /f "); + when Trunc_Mod_Expr => + Emit (" modt "); + when Ceil_Mod_Expr => + Emit (" modc "); + when Floor_Mod_Expr => + Emit (" modf "); + when Exact_Div_Expr => + Emit (" /e "); + when Min_Expr => + Emit (" min "); + when Max_Expr => + Emit (" max "); + when Truth_And_Expr => + Emit (" and "); + when Truth_Or_Expr => + Emit (" or "); + when Truth_Xor_Expr => + Emit (" xor "); + when Lt_Expr => + Emit (" < "); + when Le_Expr => + Emit (" <= "); + when Gt_Expr => + Emit (" > "); + when Ge_Expr => + Emit (" >= "); + when Eq_Expr => + Emit (" == "); + when Ne_Expr => + Emit (" != "); + when Bit_And_Expr => + Emit (" & "); + when others => + Emit ("ERROR"); + end case; + end Binop; + procedure Cond_Expr (Test : Node_Ref_Or_Val; + Lhs : Node_Ref_Or_Val; + Rhs : Node_Ref_Or_Val) is + begin + if List_Representation_Info_To_JSON then + Write_Str ("{ ""code"": ""?<>"""); + Write_Str (", ""operands"": [ "); + Print_It (Test); + Write_Str (", "); + Print_It (Lhs); + Write_Str (", "); + Print_It (Rhs); + Write_Str (" ] }"); else - declare - Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); - - procedure Unop (S : String); - -- Output text for unary operator with S being operator name - - procedure Binop (S : String); - -- Output text for binary operator with S being operator name - - ---------- - -- Unop -- - ---------- - - procedure Unop (S : String) is - begin - if List_Representation_Info_To_JSON then - Write_Str ("{ ""code"": """); - if S (S'Last) = ' ' then - Write_Str (S (S'First .. S'Last - 1)); - else - Write_Str (S); - end if; - Write_Str (""", ""operands"": [ "); - Print_Expr (Node.Op1); - Write_Str (" ] }"); - else - Write_Str (S); - Print_Expr (Node.Op1); - end if; - end Unop; - - ----------- - -- Binop -- - ----------- - - procedure Binop (S : String) is - begin - if List_Representation_Info_To_JSON then - Write_Str ("{ ""code"": """); - Write_Str (S (S'First + 1 .. S'Last - 1)); - Write_Str (""", ""operands"": [ "); - Print_Expr (Node.Op1); - Write_Str (", "); - Print_Expr (Node.Op2); - Write_Str (" ] }"); - else - Write_Char ('('); - Print_Expr (Node.Op1); - Write_Str (S); - Print_Expr (Node.Op2); - Write_Char (')'); - end if; - end Binop; - - -- Start of processing for Print_Expr - - begin - case Node.Expr is - when Cond_Expr => - if List_Representation_Info_To_JSON then - Write_Str ("{ ""code"": ""?<>"""); - Write_Str (", ""operands"": [ "); - Print_Expr (Node.Op1); - Write_Str (", "); - Print_Expr (Node.Op2); - Write_Str (", "); - Print_Expr (Node.Op3); - Write_Str (" ] }"); - else - Write_Str ("(if "); - Print_Expr (Node.Op1); - Write_Str (" then "); - Print_Expr (Node.Op2); - Write_Str (" else "); - Print_Expr (Node.Op3); - Write_Str (")"); - end if; - - when Plus_Expr => - Binop (" + "); - - when Minus_Expr => - Binop (" - "); - - when Mult_Expr => - Binop (" * "); - - when Trunc_Div_Expr => - Binop (" /t "); - - when Ceil_Div_Expr => - Binop (" /c "); - - when Floor_Div_Expr => - Binop (" /f "); - - when Trunc_Mod_Expr => - Binop (" modt "); - - when Ceil_Mod_Expr => - Binop (" modc "); - - when Floor_Mod_Expr => - Binop (" modf "); - - when Exact_Div_Expr => - Binop (" /e "); - - when Negate_Expr => - Unop ("-"); - - when Min_Expr => - Binop (" min "); - - when Max_Expr => - Binop (" max "); - - when Abs_Expr => - Unop ("abs "); - - when Truth_And_Expr => - Binop (" and "); - - when Truth_Or_Expr => - Binop (" or "); - - when Truth_Xor_Expr => - Binop (" xor "); - - when Truth_Not_Expr => - Unop ("not "); - - when Lt_Expr => - Binop (" < "); - - when Le_Expr => - Binop (" <= "); - - when Gt_Expr => - Binop (" > "); - - when Ge_Expr => - Binop (" >= "); - - when Eq_Expr => - Binop (" == "); - - when Ne_Expr => - Binop (" != "); - - when Bit_And_Expr => - Binop (" & "); + Write_Str ("(if "); + Print_It (Test); + Write_Str (" then "); + Print_It (Lhs); + Write_Str (" else "); + Print_It (Rhs); + Write_Str (")"); + end if; + end Cond_Expr; - when Discrim_Val => - Unop ("#"); + procedure Const (Val : Node_Ref_Or_Val) is + begin + UI_Write (Val, Decimal); + end Const; - when Dynamic_Val => - Unop ("var"); - end case; - end; - end if; - end Print_Expr; + procedure Discriminant (Val : Node_Ref_Or_Val) is + begin + Unop (Discrim_Val, Val); + end Discriminant; - -- Start of processing for List_GCC_Expression + procedure Variable (Val : Node_Ref_Or_Val) is + begin + Unop (Dynamic_Val, Val); + end Variable; begin if No (U) then Write_Unknown_Val; else - Print_Expr (U); + Print_It (U); end if; end List_GCC_Expression; diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index 98ba98375f38..597e8b987629 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -345,6 +345,38 @@ package Repinfo is -- and entity id values and the back end makes Get_Dynamic_SO_Ref -- calls to retrieve them. + generic + with procedure Visit_Unop (Code : TCode; Op : Node_Ref_Or_Val); + -- Visit a unary operation. The opcode and argument are passed + -- in. + + with procedure Visit_Binop (Code : TCode; Lhs : Node_Ref_Or_Val; + Rhs : Node_Ref_Or_Val); + -- Visit a binary operation. The opcode and the arguments are + -- passed in. + + with procedure Visit_Cond_Expr (Test : Node_Ref_Or_Val; + Lhs : Node_Ref_Or_Val; + Rhs : Node_Ref_Or_Val); + -- Visit a conditional operation. The arguments are passed in + -- (the opcode is always Cond_Expr). + + with procedure Visit_Constant (Val : Node_Ref_Or_Val); + -- Visit a constant operand. The constant is passed in. + + with procedure Visit_Discriminant (Val : Node_Ref_Or_Val); + -- Visit a discriminant. The discriminant number is passed in. + + with procedure Visit_Variable (Val : Node_Ref_Or_Val); + -- Visit a variable reference. The variable's index (see + -- Dynamic_Val) is passed in. + + procedure Visit (Expr : Node_Ref_Or_Val); + -- A way to walk over a back annotation expression. The user + -- provides callbacks which are called with the operands and (when + -- needed) the code. Users can recurse on the operands by calling + -- Visit again. + ------------------------------ -- External tools Interface -- ------------------------------ diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 46eb08e38f13..b90c73018953 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2167,12 +2167,10 @@ package body Sem_Ch13 is Pragma_Name : Name_Id) return Node_Id; -- This is a wrapper for Make_Pragma used for converting aspects -- to pragmas. It takes care of Sloc (set from Loc) and building - -- the pragma identifier from the given name. In addition the flag - -- Class_Present is set from the aspect node, as well as - -- Is_Ignored. This routine also sets the - -- From_Aspect_Specification in the resulting pragma node to True, - -- and sets Corresponding_Aspect to point to the aspect. The - -- resulting pragma is assigned to Aitem. + -- the pragma identifier from the given name. In addition + -- Class_Present and Is_Ignored are set from the aspect node. + -- This routine also sets From_Aspect_Specification to True, + -- and sets Corresponding_Aspect to point to the aspect. ------------------------------- -- Analyze_Aspect_Convention -- @@ -4814,12 +4812,10 @@ package body Sem_Ch13 is when Aspect_Annotate | Aspect_GNAT_Annotate => declare - Args : List_Id; - Pargs : List_Id; - Arg : Node_Id; - + Pargs : constant List_Id := New_List; -- pragma args begin - -- The argument can be a single identifier + -- The argument can be a single identifier; add it to + -- Pargs. if Nkind (Expr) = N_Identifier then @@ -4831,11 +4827,12 @@ package body Sem_Ch13 is Set_Paren_Count (Expr, 0); - -- Add the single item to the list - - Args := New_List (Expr); + Append_To (Pargs, + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))); - -- Otherwise we must have an aggregate + -- Otherwise we must have an aggregate; add all + -- expressions to Pargs. elsif Nkind (Expr) = N_Aggregate then @@ -4854,9 +4851,16 @@ package body Sem_Ch13 is ("redundant parentheses", Expr); end if; - -- List of arguments is list of aggregate expressions - - Args := Expressions (Expr); + declare + Arg : Node_Id := First (Expressions (Expr)); + begin + while Present (Arg) loop + Append_To (Pargs, + Make_Pragma_Argument_Association (Sloc (Arg), + Expression => Relocate_Node (Arg))); + Next (Arg); + end loop; + end; -- Anything else is illegal @@ -4865,17 +4869,6 @@ package body Sem_Ch13 is goto Continue; end if; - -- Prepare pragma arguments - - Pargs := New_List; - Arg := First (Args); - while Present (Arg) loop - Append_To (Pargs, - Make_Pragma_Argument_Association (Sloc (Arg), - Expression => Relocate_Node (Arg))); - Next (Arg); - end loop; - Append_To (Pargs, Make_Pragma_Argument_Association (Sloc (Ent), Chars => Name_Entity, @@ -8489,7 +8482,15 @@ package body Sem_Ch13 is if Etype (Expression (N)) = Any_Type then return; elsif not Is_RTE (Etype (Expression (N)), RE_Asm_Insn) then - Error_Msg_N ("incorrect type for code statement", N); + + -- Only emit an error message when not running in Relaxed RM + -- Semantics. This enables GNATSAS' GNAT Warnings engine to work on + -- VADS codebases. + + if not (Check_Semantics_Only_Mode and then Relaxed_RM_Semantics) then + Error_Msg_N ("incorrect type for code statement", N); + end if; + return; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index cc26ecab6ae1..e302908e9db7 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -958,7 +958,8 @@ package body Sem_Ch3 is if Is_Limited_Record (Desig_Type) and then Is_Class_Wide_Type (Desig_Type) then - Build_Class_Wide_Master (Anon_Type); + Build_Master_Entity (Defining_Identifier (Related_Nod)); + Build_Master_Renaming (Anon_Type); -- Similarly, if the type is an anonymous access that designates -- tasks, create a master entity for it in the current context. diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 87e1b30369ea..e6bba80c5f19 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -668,12 +668,13 @@ package body Sem_Ch5 is -- Error of assigning to limited type. We do however allow this in -- certain cases where the front end generates the assignments. -- Comes_From_Source test is needed to allow compiler-generated - -- streaming/put_image subprograms, which may ignore privacy. + -- constructor calls or streaming/put_image subprograms, which may + -- ignore privacy. elsif Is_Limited_Type (T1) and then not Assignment_OK (Lhs) and then not Assignment_OK (Original_Node (Lhs)) - and then (Comes_From_Source (N) or Is_Immutably_Limited_Type (T1)) + and then Comes_From_Source (N) then -- CPP constructors can only be called in declarations diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 1235ea453b6a..2e0df1df29eb 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1611,9 +1611,7 @@ package body Sem_Ch6 is procedure Analyze_Procedure_Call (N : Node_Id) is procedure Analyze_Call_And_Resolve; - -- Do Analyze and Resolve calls for procedure call. At the end, check - -- for illegal order dependence. - -- ??? where is the check for illegal order dependencies? + -- Do Analyze and Resolve for procedure call ------------------------------ -- Analyze_Call_And_Resolve -- @@ -1621,12 +1619,8 @@ package body Sem_Ch6 is procedure Analyze_Call_And_Resolve is begin - if Nkind (N) = N_Procedure_Call_Statement then - Analyze_Call (N); - Resolve (N, Standard_Void_Type); - else - Analyze (N); - end if; + Analyze_Call (N); + Resolve (N, Standard_Void_Type); end Analyze_Call_And_Resolve; -- Local variables @@ -2434,11 +2428,11 @@ package body Sem_Ch6 is procedure Build_Subprogram_Declaration; -- Create a matching subprogram declaration for subprogram body N - procedure Check_Anonymous_Return; - -- Ada 2005: if a function returns an access type that denotes a task, - -- or a type that contains tasks, we must create a master entity for - -- the anonymous type, which typically will be used in an allocator - -- in the body of the function. + procedure Check_Anonymous_Access_Return_With_Tasks; + -- If a function returns an anonymous access type that designates a task + -- or a type that contains tasks, create a master entity in the function + -- for the anonymous access type, and also mark the construct enclosing + -- the function as a task master. procedure Check_Inline_Pragma (Spec : in out Node_Id); -- Look ahead to recognize a pragma that may appear after the body. @@ -2795,13 +2789,12 @@ package body Sem_Ch6 is Body_Id := Analyze_Subprogram_Specification (Body_Spec); end Build_Subprogram_Declaration; - ---------------------------- - -- Check_Anonymous_Return -- - ---------------------------- + ---------------------------------------------- + -- Check_Anonymous_Access_Return_With_Tasks -- + ---------------------------------------------- - procedure Check_Anonymous_Return is + procedure Check_Anonymous_Access_Return_With_Tasks is Decl : Node_Id; - Par : Node_Id; Scop : Entity_Id; begin @@ -2837,29 +2830,14 @@ package body Sem_Ch6 is Set_Declarations (N, New_List (Decl)); end if; - Set_Master_Id (Etype (Scop), Defining_Identifier (Decl)); Set_Has_Master_Entity (Scop); + Set_Master_Id (Etype (Scop), Defining_Identifier (Decl)); - -- Now mark the containing scope as a task master - - Par := N; - while Nkind (Par) /= N_Compilation_Unit loop - Par := Parent (Par); - pragma Assert (Present (Par)); - - -- If we fall off the top, we are at the outer level, and - -- the environment task is our effective master, so nothing - -- to mark. + -- Now mark the enclosing construct as a task master - if Nkind (Par) - in N_Task_Body | N_Block_Statement | N_Subprogram_Body - then - Set_Is_Task_Master (Par, True); - exit; - end if; - end loop; + Mark_Construct_As_Task_Master (Parent (N)); end if; - end Check_Anonymous_Return; + end Check_Anonymous_Access_Return_With_Tasks; ------------------------- -- Check_Inline_Pragma -- @@ -4476,7 +4454,12 @@ package body Sem_Ch6 is Install_Private_With_Clauses (Body_Id); end if; - Check_Anonymous_Return; + -- If a function returns an anonymous access type that designates a task + -- or a type that contains tasks, we must create a master entity for the + -- anonymous access type, which typically will be used for an allocator + -- in the body of the function. + + Check_Anonymous_Access_Return_With_Tasks; -- Set the Protected_Formal field of each extra formal of the protected -- subprogram to reference the corresponding extra formal of the @@ -9420,10 +9403,6 @@ package body Sem_Ch6 is (E, Standard_Integer, E, BIP_Formal_Suffix (BIP_Task_Master)); - if Needs_BIP_Task_Actuals (Ref_E) then - Set_Has_Master_Entity (E); - end if; - Discard := Add_Extra_Formal (E, RTE (RE_Activation_Chain_Access), diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb index d2e78a3b4b73..d63f457175b8 100644 --- a/gcc/ada/sinfo-utils.adb +++ b/gcc/ada/sinfo-utils.adb @@ -183,6 +183,9 @@ package body Sinfo.Utils is -- break nnd if n = 12345 -- and run gnat1 again from the beginning. + -- NOTE WELL: Make sure gdb is in Ada mode, because "n = 12345" is always + -- true in C mode. + -- The other way is to set a breakpoint near the beginning (e.g. on -- gnat1drv), and run. Then set Watch_Node (nickname "ww") to 12345 in gdb: -- ww := 12345 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index c5d981d53023..bd0ef87e9e81 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -757,8 +757,8 @@ package Sinfo is -- When tasks are declared in the corresponding declarative region this -- entity is located by name (its name is always _Chain) and the declared -- tasks are added to the chain. Note that N_Extended_Return_Statement - -- does not have this attribute, although it does have an activation - -- chain. This chain is used to store the tasks temporarily, and is not + -- also has this attribute, although it is not really a task activator: + -- this chain is only used to store the tasks temporarily, and is not -- used for activating them. On successful completion of the return -- statement, the tasks are moved to the caller's chain, and the caller -- activates them. @@ -1274,8 +1274,9 @@ package Sinfo is -- that references the file the external initializer points to. -- Finally_Statements - -- Present in N_Handled_Statement_Sequences nodes. Points to a list - -- containing statements. + -- Present in N_Handled_Sequence_Of_Statements nodes. Points to a list + -- of statements to be executed on all possible execution paths on exit + -- to the sequence of statements. -- First_Inlined_Subprogram -- Present in the N_Compilation_Unit node for the main program. Points @@ -6920,10 +6921,11 @@ package Sinfo is -- Statements -- End_Label (set to Empty if expander generated) -- Exception_Handlers (set to No_List if none present) + -- Finally_Statements (set to No_List if no finally statements) -- At_End_Proc (set to Empty if no clean up procedure) - -- Note: A Handled_Sequence_Of_Statements can contain both - -- Exception_Handlers and an At_End_Proc. + -- Note: An N_Handled_Sequence_Of_Statements node can simultaneously + -- contain Exception_Handlers, Finally_Statements and an At_End_Proc. -- Note: the parent always contains a Declarations field which contains -- declarations associated with the handled sequence of statements. This diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index bf8417a92c85..868ecd850001 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -562,9 +562,9 @@ begin Write_Line (" .O* turn off warnings for out parameters assigned " & "but not read"); Write_Line (" p+ turn on warnings for ineffective pragma " & - "Inline in frontend"); + "Inline"); Write_Line (" P* turn off warnings for ineffective pragma " & - "Inline in frontend"); + "Inline"); Write_Line (" .p+ turn on warnings for suspicious parameter " & "order"); Write_Line (" .P* turn off warnings for suspicious parameter " & diff --git a/gcc/ada/vast.adb b/gcc/ada/vast.adb index 59470fdd0f15..429eeaf8c294 100644 --- a/gcc/ada/vast.adb +++ b/gcc/ada/vast.adb @@ -36,11 +36,14 @@ with System.Case_Util; with Atree; use Atree; with Debug; with Einfo.Entities; use Einfo.Entities; +-- with Errout; +with Exp_Tss; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Opt; use Opt; with Output; +with Sem_Util; with Sinfo.Nodes; use Sinfo.Nodes; with Sinput; with Table; @@ -64,9 +67,12 @@ package body VAST is Check_Sloc, Check_Analyzed, Check_Error_Nodes, + Check_FE_Only, Check_Sharing, Check_Parent_Present, - Check_Parent_Correct); + Check_Parent_Correct, + Check_Scope_Present, + Check_Scope_Correct); type Check_Status is -- Action in case of check failure: @@ -79,10 +85,13 @@ package body VAST is (Check_Other => Enabled, Check_Sloc => Disabled, Check_Analyzed => Disabled, - Check_Error_Nodes => Print_And_Continue, + Check_Error_Nodes => Enabled, + Check_FE_Only => Disabled, Check_Sharing => Disabled, - Check_Parent_Present => Print_And_Continue, - Check_Parent_Correct => Disabled); + Check_Parent_Present => Enabled, + Check_Parent_Correct => Disabled, + Check_Scope_Present => Print_And_Continue, + Check_Scope_Correct => Print_And_Continue); -- others => Print_And_Continue); -- others => Enabled); -- others => Disabled); @@ -109,6 +118,21 @@ package body VAST is Table_Increment => 100, Table_Name => "Node_Stack"); + type Pass_Number is range 1 .. 2; + Pass : Pass_Number; + + procedure VAST; + -- Called by VAST_If_Enabled to do all the checking + + procedure Fail + (Check : Check_Enum := Check_Other; + Detail : String := ""); + -- Print failure information if Check is not disabled. Called by Assert + -- when Condition is False and for other failures. + + procedure Fail_Breakpoint (N : Node_Id) with Export; + -- Does nothing. Called by Fail; useful to set a breakpoint in gdb on this. + procedure Assert (Condition : Boolean; Check : Check_Enum := Check_Other; @@ -121,6 +145,11 @@ package body VAST is function Image (Kind : Node_Kind) return String is (To_Mixed (Kind'Img)); function Image (Kind : Entity_Kind) return String is (To_Mixed (Kind'Img)); + function Kind_Image (N : Node_Or_Entity_Id) return String is + (if Nkind (N) in N_Entity then Image (Ekind (N)) + else Image (Nkind (N))); + function Node_Image (N : Node_Or_Entity_Id) return String is + (Kind_Image (N) & N'Img); procedure Put (S : String); procedure Put_Line (S : String); @@ -147,6 +176,11 @@ package body VAST is procedure Do_Tree (N : Node_Id); -- Do VAST checking on a tree of nodes + function Is_FE_Only (Kind : Node_Kind) return Boolean; + -- True if nodes of this Kind can appear only in the front end. They should + -- be transformed into something else before calling the back end, or else + -- they can only appear in illegal code. + function Has_Subtrees (N : Node_Id) return Boolean; -- True if N has one or more syntactic fields @@ -156,9 +190,15 @@ package body VAST is procedure Do_List (L : List_Id); -- Call Do_Tree on the list elements + procedure Do_Node_Pass_2 (N : Node_Id); + -- Called by Do_Tree in the second pass + procedure Do_Unit (U : Unit_Number_Type); -- Call Do_Tree on the root node of a compilation unit + function Is_On_Stack (Kind : Node_Kind) return Boolean; + -- True if there is at least one node on the stack with the specified Kind + function Ancestor_Node (Count : Node_Stack_Count) return Node_Id; -- Nth ancestor on the Node_Stack. Ancestor_Node(0) is the current node, -- Ancestor_Node(1) is its parent, Ancestor_Node(2) is its grandparent, @@ -166,20 +206,45 @@ package body VAST is function Top_Node return Node_Id is (Ancestor_Node (0)); - type Node_Set is array (Node_Id range <>) of Boolean; - pragma Pack (Node_Set); - type Node_Set_Ptr is access all Node_Set; - procedure Free is new Ada.Unchecked_Deallocation (Node_Set, Node_Set_Ptr); - - Visited : Node_Set_Ptr; - -- Giant array of Booleans; Visited (N) is True if and only if we have - -- visited N in the tree walk. Used to detect incorrect sharing of subtrees - -- or (worse) cycles. We don't allocate the set on the stack, for fear of - -- Storage_Error. + type Node_Info is record + Count : Nat := 0; + Prev_Parent : Node_Id := Empty; + In_Aspect : Boolean := False; + end record; + type Node_Info_Array is array (Node_Id range <>) of Node_Info; + type Node_Info_Array_Ptr is access all Node_Info_Array; + procedure Free is new Ada.Unchecked_Deallocation + (Node_Info_Array, Node_Info_Array_Ptr); + + Nodes_Info : Node_Info_Array_Ptr; + -- Nodes_Info (N).Prev_Parent is non-Empty if and only if the tree walk has + -- visited N. If non-Empty, it points to the most recent parent of N in the + -- tree walk; that is, the node that allowed us to get to N. Normally, each + -- reachable node is visited exactly once, and if the Parent pointers + -- aren't messed up, then Nodes_Info (N).Prev_Parent will be Parent (N). + -- (See below for the special case of the root compilation unit node.) + -- + -- Used to detect incorrect sharing of subtrees or (worse) cycles. We don't + -- allocate this on the stack, for fear of Storage_Error. + -- + -- Nodes_Info (N).Count is the number of ways N is reachable in the walk. + -- It should be 1 for all nodes except the root. function Get_Node_Field_Union is new Atree.Atree_Private_Part.Get_32_Bit_Field (Union_Id) with Inline; + function Has_Field (Kind : Node_Kind; F : Node_Field) return Boolean; + -- True if nodes of type Kind have field F + + function Related_Chars (N : Node_Id) return Name_Id; + -- Return a Name_Id related to N that is worth printing when we print + -- information about N. Returns No_Name if there is no interesting Name_Id. + -- This is typically "Chars (N)" or "Chars (Defining_Identifier (N))" or + -- similar. + + procedure Check_Scope (N : Node_Id); + -- Check that the Scope of N makes sense + -------------- -- To_Mixed -- -------------- @@ -213,6 +278,41 @@ package body VAST is end if; end Put_Line; + --------------- + -- Has_Field -- + --------------- + + function Has_Field (Kind : Node_Kind; F : Node_Field) return Boolean is + Fields : Node_Field_Array renames Node_Field_Table (Kind).all; + begin + for Index in Fields'Range loop + if Fields (Index) = F then + return True; + end if; + end loop; + + return False; + end Has_Field; + + ------------------- + -- Related_Chars -- + ------------------- + + function Related_Chars (N : Node_Id) return Name_Id is + begin + return Result : Name_Id := No_Name do + if Has_Field (Nkind (N), F_Chars) then + Result := Chars (N); + elsif Has_Field (Nkind (N), F_Defining_Identifier) then + Result := Related_Chars (Defining_Identifier (N)); + elsif Has_Field (Nkind (N), F_Defining_Unit_Name) then + Result := Related_Chars (Defining_Unit_Name (N)); + elsif Has_Field (Nkind (N), F_Specification) then + Result := Related_Chars (Specification (N)); + end if; + end return; + end Related_Chars; + -------------- -- Put_Node -- -------------- @@ -220,26 +320,21 @@ package body VAST is procedure Put_Node (N : Node_Id) is begin if Debug.Debug_Flag_Underscore_WW then - if Nkind (N) in N_Entity then - Put (Image (Ekind (N))); - else - Put (Image (Nkind (N))); - end if; - - Put (N'Img & " "); + Put (Node_Image (N) & " "); Sinput.Write_Location (Sloc (N)); if Comes_From_Source (N) then Put (" (s)"); end if; - case Nkind (N) is - when N_Has_Chars => + declare + Chars_To_Print : constant Name_Id := Related_Chars (N); + begin + if Present (Chars_To_Print) then Put (" "); - Write_Name_For_Debug (Chars (N), Quote => """"); - when others => null; - end case; - + Write_Name_For_Debug (Chars_To_Print, Quote => """"); + end if; + end; end if; end Put_Node; @@ -300,6 +395,21 @@ package body VAST is end loop; end Put_Node_Stack; + ----------------- + -- Is_On_Stack -- + ----------------- + + function Is_On_Stack (Kind : Node_Kind) return Boolean is + begin + for J in reverse Node_Stack.First .. Node_Stack.Last loop + if Nkind (Node_Stack.Table (J)) = Kind then + return True; + end if; + end loop; + + return False; + end Is_On_Stack; + ------------------- -- Ancestor_Node -- ------------------- @@ -309,12 +419,63 @@ package body VAST is return Node_Stack.Table (Node_Stack.Last - Count); end Ancestor_Node; + --------------------- + -- Fail_Breakpoint -- + --------------------- + + procedure Fail_Breakpoint (N : Node_Id) is + begin + null; + end Fail_Breakpoint; + + ---------- + -- Fail -- + ---------- + + VAST_Failure : exception; + + procedure Fail + (Check : Check_Enum := Check_Other; + Detail : String := "") + is + Part1 : constant String := "VAST fail"; + Part2 : constant String := + (if Check = Check_Other then "" + else ": " & To_Mixed (Check'Img)); + Part3 : constant String := + (if Detail = "" then "" else " -- " & Detail); + Message : constant String := Part1 & Part2 & Part3; + Save : constant Boolean := Debug.Debug_Flag_Underscore_WW; + begin + case Status (Check) is + when Disabled => null; + when Enabled | Print_And_Continue => + Debug.Debug_Flag_Underscore_WW := True; + -- ????We should probably avoid changing the debug flag here + Put (Message & ": "); + Put_Node (Top_Node); + Put_Line (""); + + Put ("VAST file: "); + Sinput.Write_Location (Sloc (Top_Node)); + Put_Line (""); + Put_Node_Stack; + + if Status (Check) = Enabled then + Put_Node_Stack; + raise VAST_Failure with Message; + end if; + + Debug.Debug_Flag_Underscore_WW := Save; + + Fail_Breakpoint (Ancestor_Node (0)); + end case; + end Fail; + ------------ -- Assert -- ------------ - VAST_Failure : exception; - procedure Assert (Condition : Boolean; Check : Check_Enum := Check_Other; @@ -322,57 +483,53 @@ package body VAST is is begin if not Condition then - declare - Part1 : constant String := "VAST fail"; - Part2 : constant String := - (if Check = Check_Other then "" - else ": " & To_Mixed (Check'Img)); - Part3 : constant String := - (if Detail = "" then "" else " -- " & Detail); - Message : constant String := Part1 & Part2 & Part3; - Save : constant Boolean := Debug.Debug_Flag_Underscore_WW; - begin - case Status (Check) is - when Disabled => null; - when Enabled | Print_And_Continue => - Debug.Debug_Flag_Underscore_WW := True; - -- ???We should probably avoid changing the debug flag here - Put (Message & ": "); - Put_Node (Top_Node); - Put_Line (""); - - if Status (Check) = Enabled then - Put_Node_Stack; - raise VAST_Failure with Message; - end if; - - Debug.Debug_Flag_Underscore_WW := Save; - end case; - end; + Fail (Check, Detail); end if; end Assert; - ------------- - -- Do_Tree -- - ------------- + ----------------- + -- Check_Scope -- + ----------------- - procedure Do_Tree (N : Node_Id) is + procedure Check_Scope (N : Node_Id) is + use Exp_Tss, Sem_Util; begin - Enter_Node (N); + if Present (Scope (N)) then + if False then -- ???? + Assert (Enclosing_Declaration (Scope (N)) = + Enclosing_Declaration (Enclosing_Declaration (N)), + Check_Scope_Correct); + end if; + else + if Ekind (N) = E_Void then + -- ????These seem to be SW, PI, &c, and their params. + null; + elsif Ekind (N) = E_Procedure and then Is_TSS (N, TSS_Put_Image) + then + null; -- also PI + elsif Ekind (N) = E_Protected_Body then + null; + else + Fail (Check_Scope_Present); + end if; + end if; + end Check_Scope; - -- Skip the rest if empty. Check Sloc: + -------------------- + -- Do_Node_Pass_2 -- + -------------------- - case Nkind (N) is - when N_Empty => - Assert (No (Sloc (N))); - goto Done; -- --------------> - -- Don't do any further checks on Empty + procedure Do_Node_Pass_2 (N : Node_Id) is + begin + -- Check Sloc: + case Nkind (N) is -- ???Some nodes, including exception handlers, have no Sloc; -- it's unclear why. when N_Exception_Handler => - Assert (if Comes_From_Source (N) then Present (Sloc (N))); + Assert + ((if Comes_From_Source (N) then Present (Sloc (N))), Check_Sloc); when others => Assert (Present (Sloc (N)), Check_Sloc); end case; @@ -382,24 +539,21 @@ package body VAST is Assert (Analyzed (N), Check_Analyzed); - -- If we visit the same node more than once, then there are shared - -- nodes; the "tree" is not a tree: - - Assert (not Visited (N), Check_Sharing); - Visited (N) := True; - -- Misc checks based on node/entity kind: case Nkind (N) is when N_Unused_At_Start | N_Unused_At_End => - Assert (False); + -- ????Can't get here, because Is_FE_Only. Also 'case' below. + Fail; when N_Error => -- VAST doesn't do anything when Serious_Errors_Detected > 0 (at -- least for now), so we shouldn't encounter any N_Error nodes. - Assert (False, Check_Error_Nodes); + Fail (Check_Error_Nodes); when N_Entity => + Check_Scope (N); + case Ekind (N) is when others => null; -- more to be done here @@ -416,7 +570,7 @@ package body VAST is raise Program_Error; -- can't get here when N_Error => - Assert (False, Check_Error_Nodes); + Fail (Check_Error_Nodes); -- The error node has no parent, but we shouldn't even be seeing -- error nodes in VAST at all. See earlier "when N_Error". @@ -440,10 +594,95 @@ package body VAST is Assert (Parent (N) = Ancestor_Node (1), Check_Parent_Correct); end if; end case; + end Do_Node_Pass_2; + + ------------- + -- Do_Tree -- + ------------- + + procedure Do_Tree (N : Node_Id) is + Visited : constant Boolean := Present (Nodes_Info (N).Prev_Parent); + begin + if False and Nkind (N) = N_Aspect_Specification then + -- ????This cuts failures 453490/235214 = 1.9. + return; + end if; + + if Pass = 1 then + Nodes_Info (N).Count := Nodes_Info (N).Count + 1; + -- ????Get rid of asserts: + pragma Assert + (if Nkind (N) not in N_Empty | N_Compilation_Unit then + Visited = (Nodes_Info (N).Count > 1)); + + if Is_On_Stack (N_Aspect_Specification) then + Nodes_Info (N).In_Aspect := True; + end if; + elsif Pass = 2 then + pragma Assert (Nodes_Info (N).Count > 0); + end if; + + Enter_Node (N); + + Assert (not Is_FE_Only (Nkind (N)), Check_FE_Only); + -- ????Also check for particular pragmas, etc. + -- And Ekind. + + if Nkind (N) = N_Empty then + Assert (N = Empty); + Assert (No (Sloc (N))); + goto Done; -- --------------> + -- Don't do any further checks on Empty + end if; + + -- If we visit the same node more than once, then there are shared + -- nodes; the "tree" is not a tree: + -- We know that the "extra formals" involve shared subtrees, + -- and that's probably unavoidable. See Expand_Call_Helper. + -- A lot of shared subtrees come from aspect specifications, + -- probably because they get turned into pragmas, and the + -- subtrees get placed inside the pragmas without removing + -- them from the original aspect specifications. + + if Pass = 2 and then Nodes_Info (N).Count > 1 and then + not Nodes_Info (N).In_Aspect -- ????cuts failures by 1.9 + then + declare + Count : constant String := + (if Nodes_Info (N).Count = 2 then "" + else Nodes_Info (N).Count'Img & "par"); + Aspect : constant String := + (if Nodes_Info (N).In_Aspect then "{asp}" else ""); + begin + Fail (Check_Sharing, + "(prev-par=" & + Node_Image (Nodes_Info (N).Prev_Parent) & ")" & + Count & Aspect); + if Status (Check_Sharing) /= Disabled then + Output.Write_Line + (Kind_Image (Ancestor_Node (1)) & "```" & Kind_Image (N)); + Output.Write_Line (""); + end if; + end; + end if; - Do_Subtrees (N); + if Node_Stack.Last = 1 then + Nodes_Info (N).Prev_Parent := Ancestor_Node (0); + Assert (Nkind (N) = N_Compilation_Unit); + -- This is the root node. Set the parent to itself, + -- for no particular reason except to make it not Empty. + else + Nodes_Info (N).Prev_Parent := Ancestor_Node (1); + end if; + if not Visited then -- Don't walk it more than once + if Pass = 2 then + Do_Node_Pass_2 (N); + end if; + Do_Subtrees (N); + end if; <> + Leave_Node (N); end Do_Tree; @@ -455,7 +694,7 @@ package body VAST is Offsets : Traversed_Offset_Array renames Traversed_Fields (Nkind (N)); begin - -- True if sentinel comes first + -- True if the first Offset is not the sentinel return Offsets (Offsets'First) /= No_Field_Offset; end Has_Subtrees; @@ -559,14 +798,67 @@ package body VAST is ---------- procedure VAST is + begin + Put_Line ("VAST"); + + -- Operating_Mode = Generate_Code implies there are no legality errors: + + pragma Assert (Serious_Errors_Detected = 0); + -- ????pragma Assert (not Errout.Compilation_Errors); + + Put_Line ("VAST checking" & Last_Unit'Img & " units"); + + declare + use Atree_Private_Part; + Last_Node : constant Node_Id := Node_Offsets.Last; + begin + pragma Assert (Nodes_Info = null); + Nodes_Info := new Node_Info_Array (Node_Id'First .. Last_Node); + + -- Walk all nodes in all units doing Pass 1, and so on + -- for each Pass. + + for P in Pass_Number loop + Pass := P; + + Put_Line ("VAST Pass" & Pass'Img); + if Pass = 2 then -- ????Is this needed? + for Index in Nodes_Info'Range loop + Nodes_Info (Index).Prev_Parent := Empty; + end loop; + end if; + + for U in Main_Unit .. Last_Unit loop + -- Main_Unit is the one passed to the back end, but here we are + -- walking all the units. + Do_Unit (U); + end loop; + end loop; + + -- We shouldn't have allocated any new nodes during VAST: + + pragma Assert (Node_Offsets.Last = Last_Node); + Free (Nodes_Info); + end; + + Put_Line ("VAST done."); + end VAST; + + --------------------- + -- VAST_If_Enabled -- + --------------------- + + procedure VAST_If_Enabled is + -- This is the public entry point + pragma Assert (Expander_Active = (Operating_Mode = Generate_Code)); -- ???So why do we need both Operating_Mode and Expander_Active? use Debug; begin -- Do nothing if we're not calling the back end; the main point of VAST - -- is to protect against code-generation bugs. This includes the - -- case where legality errors were detected; the tree is known to be - -- malformed in some error cases. + -- is to protect against code-generation bugs. VAST is disabled if + -- legality errors were detected; the tree is known to be malformed + -- in some error cases. The -gnatc switch also disables VAST. if Operating_Mode /= Generate_Code then return; @@ -575,46 +867,276 @@ package body VAST is -- If -gnatd_W (VAST in verbose mode) is enabled, then that should imply -- -gnatd_V (enable VAST). - if Debug_Flag_Underscore_WW then + if Debug_Flag_Underscore_WW or Force_Enable_VAST then Debug_Flag_Underscore_VV := True; end if; -- Do nothing if VAST is disabled - if not (Debug_Flag_Underscore_VV or Force_Enable_VAST) then + if not Debug_Flag_Underscore_VV then return; end if; - -- Turn off output unless verbose mode is enabled - - Put_Line ("VAST"); - - -- Operating_Mode = Generate_Code implies there are no legality errors: - - Assert (Serious_Errors_Detected = 0); - - Put_Line ("VAST checking" & Last_Unit'Img & " units"); - - declare - use Atree_Private_Part; - Last_Node : constant Node_Id := Node_Offsets.Last; - begin - pragma Assert (Visited = null); - Visited := new Node_Set'(Node_Id'First .. Last_Node => False); - - for U in Main_Unit .. Last_Unit loop - -- Main_Unit is the one passed to the back end, but here we are - -- walking all the units. - Do_Unit (U); - end loop; - - -- We shouldn't have allocated any new nodes during VAST: + VAST; + end VAST_If_Enabled; - pragma Assert (Node_Offsets.Last = Last_Node); - Free (Visited); - end; + ---------------- + -- Is_FE_Only -- + ---------------- - Put_Line ("VAST done."); - end VAST; + function Is_FE_Only (Kind : Node_Kind) return Boolean is + -- ????This is work in progress; see "?" marks below + begin + case Kind is + when N_Abortable_Part + | N_Abort_Statement + | N_Asynchronous_Select + | N_Compound_Statement + | N_Conditional_Entry_Call + | N_Continue_Statement + | N_Contract + | N_Delay_Alternative + | N_Delay_Until_Statement + | N_Delta_Constraint + | N_Entry_Call_Alternative + | N_Entry_Index_Specification + | N_Error + | N_Formal_Derived_Type_Definition + | N_Formal_Package_Declaration + | N_Goto_When_Statement + | N_Interpolated_String_Literal + | N_Iterated_Element_Association + | N_Mod_Clause + | N_Raise_When_Statement + | N_Return_When_Statement + | N_SCIL_Dispatching_Call + | N_SCIL_Dispatch_Table_Tag_Init + | N_SCIL_Membership_Test + | N_Timed_Entry_Call + | N_Triggering_Alternative + | N_Unused_At_End + | N_Unused_At_Start + => return True; + + when N_Empty + | N_Delay_Relative_Statement -- ????not turned into rt call? + | N_Expression_Function + | N_Iterated_Component_Association -- ???? + | N_Single_Protected_Declaration + | N_Accept_Alternative -- ????not turned into rt call? + | N_Accept_Statement -- ????not turned into rt call? + | N_Decimal_Fixed_Point_Definition + | N_Digits_Constraint + | N_Entry_Call_Statement -- ????not turned into rt call? + | N_Requeue_Statement -- ????not turned into rt call? + | N_Selective_Accept -- ????not turned into rt call? + | N_Terminate_Alternative -- ????not turned into rt call? + | N_Defining_Character_Literal + | N_Access_Function_Definition + | N_Formal_Discrete_Type_Definition + | N_Formal_Modular_Type_Definition + | N_Iterator_Specification + | N_Op_Expon + | N_Variant + | N_Variant_Part + | N_Access_Definition + | N_Access_Procedure_Definition + | N_Access_To_Object_Definition + | N_Aspect_Specification + | N_Case_Statement_Alternative + | N_Compilation_Unit_Aux + | N_Component_Clause + | N_Component_Declaration + | N_Component_Definition + | N_Component_List + | N_Constrained_Array_Definition + | N_Derived_Type_Definition + | N_Designator + | N_Discriminant_Association + | N_Discriminant_Specification + | N_Elsif_Part + | N_Enumeration_Type_Definition + | N_Floating_Point_Definition + | N_Formal_Concrete_Subprogram_Declaration + | N_Formal_Floating_Point_Definition + | N_Formal_Object_Declaration + | N_Formal_Private_Type_Definition + | N_Formal_Signed_Integer_Type_Definition + | N_Formal_Type_Declaration + | N_Generic_Association + | N_Index_Or_Discriminant_Constraint + | N_Iteration_Scheme + | N_Loop_Parameter_Specification + | N_Modular_Type_Definition + | N_Others_Choice + | N_Parameter_Association + | N_Parameter_Specification + | N_Quantified_Expression -- ???? + | N_Range + | N_Range_Constraint + | N_Record_Definition + | N_Signed_Integer_Type_Definition + | N_Subtype_Indication + | N_Unconstrained_Array_Definition + | N_Pragma_Argument_Association + | N_Case_Expression + | N_Case_Expression_Alternative + | N_Delta_Aggregate -- ???? + | N_Entry_Body_Formal_Part + | N_Entry_Declaration + | N_Extended_Return_Statement -- ???? + | N_Formal_Abstract_Subprogram_Declaration + | N_Formal_Decimal_Fixed_Point_Definition + | N_Formal_Incomplete_Type_Definition + | N_Formal_Ordinary_Fixed_Point_Definition + | N_Ordinary_Fixed_Point_Definition + | N_Protected_Definition + | N_Raise_Expression + | N_Real_Range_Specification + | N_Target_Name -- ???? + | N_Task_Definition + => return False; + -- ???? + + when N_Abstract_Subprogram_Declaration + | N_Aggregate + | N_Allocator + | N_And_Then + | N_Assignment_Statement + | N_At_Clause + | N_Attribute_Definition_Clause + | N_Attribute_Reference + | N_Block_Statement + | N_Call_Marker + | N_Case_Statement + | N_Character_Literal + | N_Code_Statement + | N_Compilation_Unit + | N_Component_Association + | N_Defining_Identifier + | N_Defining_Operator_Symbol + | N_Defining_Program_Unit_Name + | N_Entry_Body + | N_Enumeration_Representation_Clause + | N_Exception_Declaration + | N_Exception_Handler + | N_Exception_Renaming_Declaration + | N_Exit_Statement + | N_Expanded_Name + | N_Explicit_Dereference + | N_Expression_With_Actions + | N_Extension_Aggregate + | N_External_Initializer + | N_Free_Statement + | N_Freeze_Entity + | N_Freeze_Generic_Entity + | N_Full_Type_Declaration + | N_Function_Call + | N_Function_Instantiation + | N_Function_Specification + | N_Generic_Function_Renaming_Declaration + | N_Generic_Package_Declaration + | N_Generic_Package_Renaming_Declaration + | N_Generic_Procedure_Renaming_Declaration + | N_Generic_Subprogram_Declaration + | N_Goto_Statement + | N_Handled_Sequence_Of_Statements + | N_Identifier + | N_If_Expression + | N_If_Statement + | N_Implicit_Label_Declaration + | N_In + | N_Incomplete_Type_Declaration + | N_Indexed_Component + | N_Integer_Literal + | N_Itype_Reference + | N_Label + | N_Loop_Statement + | N_Not_In + | N_Null + | N_Null_Statement + | N_Number_Declaration + | N_Object_Declaration + | N_Object_Renaming_Declaration + | N_Op_Abs + | N_Op_Add + | N_Op_And + | N_Op_Concat + | N_Op_Divide + | N_Op_Eq + | N_Operator_Symbol + | N_Op_Ge + | N_Op_Gt + | N_Op_Le + | N_Op_Lt + | N_Op_Minus + | N_Op_Mod + | N_Op_Multiply + | N_Op_Ne + | N_Op_Not + | N_Op_Or + | N_Op_Plus + | N_Op_Rem + | N_Op_Rotate_Left + | N_Op_Rotate_Right + | N_Op_Shift_Left + | N_Op_Shift_Right + | N_Op_Shift_Right_Arithmetic + | N_Op_Subtract + | N_Op_Xor + | N_Or_Else + | N_Package_Body + | N_Package_Body_Stub + | N_Package_Declaration + | N_Package_Instantiation + | N_Package_Renaming_Declaration + | N_Package_Specification + | N_Pop_Constraint_Error_Label + | N_Pop_Program_Error_Label + | N_Pop_Storage_Error_Label + | N_Pragma + | N_Private_Extension_Declaration + | N_Private_Type_Declaration + | N_Procedure_Call_Statement + | N_Procedure_Instantiation + | N_Procedure_Specification + | N_Protected_Body + | N_Protected_Body_Stub + | N_Protected_Type_Declaration + | N_Push_Constraint_Error_Label + | N_Push_Program_Error_Label + | N_Push_Storage_Error_Label + | N_Qualified_Expression + | N_Raise_Constraint_Error + | N_Raise_Program_Error + | N_Raise_Statement + | N_Raise_Storage_Error + | N_Real_Literal + | N_Record_Representation_Clause + | N_Reference + | N_Selected_Component + | N_Simple_Return_Statement + | N_Single_Task_Declaration + | N_Slice + | N_String_Literal + | N_Subprogram_Body + | N_Subprogram_Body_Stub + | N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration + | N_Subtype_Declaration + | N_Subunit + | N_Task_Body + | N_Task_Body_Stub + | N_Task_Type_Declaration + | N_Type_Conversion + | N_Unchecked_Type_Conversion + | N_Use_Package_Clause + | N_Use_Type_Clause + | N_Validate_Unchecked_Conversion + | N_Variable_Reference_Marker + | N_With_Clause + => return False; + end case; + end Is_FE_Only; end VAST; diff --git a/gcc/ada/vast.ads b/gcc/ada/vast.ads index faecd9a33f3c..7888121817c9 100644 --- a/gcc/ada/vast.ads +++ b/gcc/ada/vast.ads @@ -28,6 +28,6 @@ package VAST is - procedure VAST; + procedure VAST_If_Enabled; end VAST; diff --git a/gcc/algol68/ChangeLog b/gcc/algol68/ChangeLog new file mode 100644 index 000000000000..121d8c4350bd --- /dev/null +++ b/gcc/algol68/ChangeLog @@ -0,0 +1,99 @@ +2025-11-30 Jose E. Marchesi + + * a68-diagnostics.cc (diagnostic): Copypasto "a meek" + should be "a firm". Support printing line number for programs + longer than 9 lines. Use obstack_append_str rather than + obstack_grow. + (obstack_append_str): New function. + +2025-11-30 Andrew Pinski + + * lang.opt.urls: Regenerate. + +2025-11-30 Jose E. Marchesi + + * lang.opt: New file. + * lang.opt.urls: Generate. + +2025-11-30 Jose E. Marchesi + + * ga68-internals.texi: New file. + * ga68.texi: Likewise. + * Make-lang.in: New file. + * config-lang.in: Likewise. + +2025-11-30 Jose E. Marchesi + + * a68-unistr.c: New file. + * a68-lang.cc: Likewise. + * a68spec.cc: Likewise. + * lang-specs.h: Likewise. + * README: Likewise. + * a68-tree.def: Likewise. + * a68-types.h: Likewise. + * a68.h: Likewise. + * ga68.vw: Likewise. + * a68-low-moids.cc: Likewise. + * a68-low-coercions.cc: Likewise. + * a68-low-generator.cc: Likewise. + * a68-low-units.cc: Likewise. + * a68-low-ranges.cc: Likewise. + * a68-low-builtins.cc: Likewise. + * a68-low-runtime.cc: Likewise. + * a68-low-runtime.def: Likewise. + * a68-low-clauses.cc: Likewise. + * a68-low-decls.cc: Likewise. + * a68-low-posix.cc: Likewise. + * a68-low-prelude.cc: Likewise. + * a68-low-multiples.cc: Likewise. + * a68-low-structs.cc: Likewise. + * a68-low-unions.cc: Likewise. + * a68-low-bits.cc: Likewise. + * a68-low-bools.cc: Likewise. + * a68-low-chars.cc: Likewise. + * a68-low-complex.cc: Likewise. + * a68-low-ints.cc: Likewise. + * a68-low-procs.cc: Likewise. + * a68-low-reals.cc: Likewise. + * a68-low-refs.cc: Likewise. + * a68-low-strings.cc: Likewise. + * a68-low.cc: Likewise. + * a68-low-misc.cc: Likewise. + * a68-parser-pragmat.cc: Likewise. + * a68-parser-serial-dsa.cc: Likewise. + * a68-parser-debug.cc: Likewise. + +2025-11-30 Jose E. Marchesi + Marcel van der Veer + + * a68-parser-extract.cc: New file. + * a68-parser-scope.cc: Likewise. + * a68-parser-taxes.cc: Likewise. + * a68-moids-diagnostics.cc: Likewise. + * a68-moids-misc.cc: Likewise. + * a68-moids-to-string.cc: Likewise. + * a68-parser-modes.cc: Likewise. + * a68-parser-moids-check.cc: Likewise. + * a68-parser-moids-coerce.cc: Likewise. + * a68-parser-moids-equivalence.cc: Likewise. + * a68-postulates.cc: Likewise. + * a68-parser-prelude.cc: Likewise. + * a68-parser-victal.cc: Likewise. + * a68-parser-bottom-up.cc: Likewise. + * a68-parser-brackets.cc: Likewise. + * a68-parser-top-down.cc: Likewise. + * a68-parser-keywords.cc: Likewise. + * a68-parser-scanner.cc: Likewise. + * a68-parser-attrs.def: Likewise. + * a68-parser.cc: Likewise. + * a68-imports.cc: Likewise. + * a68-exports.cc: Likewise. + * ga68-exports.pk: Likewise. + * a68-diagnostics.cc: Likewise. + + +Copyright (C) 2025 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. diff --git a/gcc/algol68/Make-lang.in b/gcc/algol68/Make-lang.in new file mode 100644 index 000000000000..11756f772627 --- /dev/null +++ b/gcc/algol68/Make-lang.in @@ -0,0 +1,287 @@ +# Make-lang.in -- Top level -*- makefile -*- fragment for GCC Algol 68 +# frontend. + +# Copyright (C) 2025 Free Software Foundation, Inc. + +# This file is NOT part of GCC. + +# GCC is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3, or (at your option) +# any later version. + +# GCC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# This file provides the language dependent support in the main Makefile. + +.PHONY: algol68 + +# Installation name. + +A68_INSTALL_NAME = $(shell echo ga68|sed '$(program_transform_name)') +A68_TARGET_INSTALL_NAME = $(target_noncanonical)-$(shell echo ga68|sed '$(program_transform_name)') + +# General hooks + +algol68: a681$(exeext) +algol68.serial = a681$(exeext) + +.PHONY: algol68 + +# Use maximal warnings for this front end. +algol68-warn = $(STRICT_WARN) + +# First the driver, ga68. + +GA68_OBJS = \ + $(GCC_OBJS) \ + algol68/a68spec.o \ + $(END) + +a68spec.o: $(srcdir)/algol68/a68spec.cc $(SYSTEM_H) coretypes.h $(TM_H) $(GCC_H) \ + $(CONFIG_H) opts.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(DRIVER_DEFINES) \ + $(INCLUDES) $(srcdir)/algol68/a68spec.cc + +ga68$(exeext): $(GA68_OBJS) $(EXTRA_GCC_OBJS) libcommon-target.a $(LIBDEPS) + +$(LINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \ + $(GA68_OBJS) $(EXTRA_GCC_OBJS) libcommon-target.a \ + $(EXTRA_GCC_LIBS) $(LIBS) + +# Now the compiler proper, a681. + +ALGOL68_OBJS = algol68/a68-lang.o \ + algol68/a68-unistr.o \ + algol68/a68-moids-diagnostics.o \ + algol68/a68-moids-misc.o \ + algol68/a68-moids-to-string.o \ + algol68/a68-postulates.o \ + algol68/a68-diagnostics.o \ + algol68/a68-exports.o \ + algol68/a68-imports.o \ + algol68/a68-parser.o \ + algol68/a68-parser-keywords.o \ + algol68/a68-parser-bottom-up.o \ + algol68/a68-parser-brackets.o \ + algol68/a68-parser-debug.o \ + algol68/a68-parser-extract.o \ + algol68/a68-parser-modes.o \ + algol68/a68-parser-moids-check.o \ + algol68/a68-parser-moids-coerce.o \ + algol68/a68-parser-moids-equivalence.o \ + algol68/a68-parser-pragmat.o \ + algol68/a68-parser-scanner.o \ + algol68/a68-parser-scope.o \ + algol68/a68-parser-serial-dsa.o \ + algol68/a68-parser-taxes.o \ + algol68/a68-parser-top-down.o \ + algol68/a68-parser-victal.o \ + algol68/a68-parser-prelude.o \ + algol68/a68-low.o \ + algol68/a68-low-builtins.o \ + algol68/a68-low-clauses.o \ + algol68/a68-low-coercions.o \ + algol68/a68-low-decls.o \ + algol68/a68-low-generator.o \ + algol68/a68-low-misc.o \ + algol68/a68-low-moids.o \ + algol68/a68-low-multiples.o \ + algol68/a68-low-refs.o \ + algol68/a68-low-procs.o \ + algol68/a68-low-structs.o \ + algol68/a68-low-chars.o \ + algol68/a68-low-strings.o \ + algol68/a68-low-ints.o \ + algol68/a68-low-bools.o \ + algol68/a68-low-reals.o \ + algol68/a68-low-complex.o \ + algol68/a68-low-bits.o \ + algol68/a68-low-posix.o \ + algol68/a68-low-prelude.o \ + algol68/a68-low-ranges.o \ + algol68/a68-low-runtime.o \ + algol68/a68-low-unions.o \ + algol68/a68-low-units.o \ + $(END) + +ALGOL68_ALL_OBJS = $(ALGOL68_OBJS) + +algol68_OBJS = $(ALGOL68_ALL_OBJS) algol68/a68spec.o + +a681$(exeext): $(ALGOL68_ALL_OBJS) attribs.o $(BACKEND) $(LIBDEPS) $(algol68.prev) + @$(call LINK_PROGRESS,$(INDEX.algol68),start) + +$(LLINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \ + $(ALGOL68_OBJS) attribs.o $(BACKEND) $(LIBS) $(A681_LIBS) $(BACKENDLIBS) + @$(call LINK_PROGRESS,$(INDEX.algol68),end) + +algol68/tfspec.o: $(srcdir)/algol68/tfspec.c \ + $(SYSTEM_H) coretypes.h $(TM_H) $(GCC_H) $(CONFIG_H) $(TREE_H) + +# Documentation. + +A68_MANUAL_FILES = + +A68_MANUAL_FILES = \ + algol68/ga68.texi \ + $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gpl_v3.texi \ + $(gcc_docdir)/include/gcc-common.texi \ + gcc-vers.texi + +A68_INT_MANUAL_FILES = \ + algol68/ga68-internals.texi \ + $(gcc_docdir)/include/fdl.texi \ + $(gcc_docdir)/include/gcc-common.texi \ + gcc-vers.texi + +A68_TEXI_FILES = $(A68_MANUAL_FILES) $(A68_INT_MANUAL_FILES) + +doc/ga68.info: $(A68_MANUAL_FILES) + if test "x$(BUILD_INFO)" = xinfo; then \ + rm -f doc/ga68.info*; \ + $(MAKEINFO) $(MAKEINFOFLAGS) -I $(gcc_docdir) \ + -I $(gcc_docdir)/include -o $@ $<; \ + else true; fi + +doc/ga68-internals.info: $(A68_INT_MANUAL_FILES) + if test "x$(BUILD_INFO)" = xinfo; then \ + rm -f doc/ga68-internals.info*; \ + $(MAKEINFO) $(MAKEINFOFLAGS) -I $(gcc_docdir) \ + -I $(gcc_docdir)/include -o $@ $<; \ + else true; fi + +doc/ga68.dvi: $(A68_MANUAL_FILES) + $(TEXI2DVI) -I $(abs_docdir)/include -o $@ $< + +doc/ga68-internals.dvi: $(A68_INT_MANUAL_FILES) + $(TEXI2DVI) -I $(abs_docdir)/include -o $@ $< + +doc/ga68.pdf: $(A68_MANUAL_FILES) + $(TEXI2PDF) -I $(abs_docdir)/include -o $@ $< + +doc/ga68-internals.pdf: $(A68_INT_MANUAL_FILES) + $(TEXI2PDF) -I $(abs_docdir)/include -o $@ $< + +$(build_htmldir)/ga68/index.html: $(A68_MANUAL_FILES) + $(mkinstalldirs) $(@D) + rm -f $(@D)/* + $(TEXI2HTML) $(MAKEINFO_TOC_INLINE_FLAG) \ + -I $(gcc_docdir)/include -I $(srcdir)/d -o $(@D) $< + +$(build_htmldir)/ga68-internals/index.html: $(A68_INT_MANUAL_FILES) + $(mkinstalldirs) $(@D) + rm -f $(@D)/* + $(TEXI2HTML) $(MAKEINFO_TOC_INLINE_FLAG) \ + -I $(gcc_docdir)/include -I $(srcdir)/d -o $(@D) $< + +.INTERMEDIATE: ga68.pod + +ga68.pod: algol68/ga68.texi + -$(TEXI2POD) -D ga68 < $< > $@ + +# Build hooks. + +algol68.srcextra: + +algol68.all.cross: ga68$(exeext) +algol68.start.encap: ga68$(exeect) +algol68.rest.encap: +algol68.info: doc/ga68.info doc/ga68-internals.info +algol68.dvi: doc/ga68.dvi doc/ga68-internals.dvi +algol68.pdf: doc/ga68.pdf doc/ga68-internals.pdf +algol68.install-pdf: +algol68.html: $(build_htmldir)/ga68/index.html $(build_htmldir)/ga68-internals/index.html +algol68.man: doc/ga68.1 +algol68.srcinfo: doc/ga68.info doc/ga68-internals.info + -cp -p $^ $(srcdir)/doc +algol68.srcinfo: +algol68.srcman: +algol68.srcman: doc/ga68.1 + -cp -p $^ $(srcdir)/doc +algol68.install-plugin: + +algol68.tags: force + cd $(srcdir)/algol68; etags -o TAGS.sub *.c *.h; \ + etags --include TAGS.sub --include ../TAGS.sub + +lang_checks += check-algol68 +lang_checks_parallelized += check-algol68 +check_algol68_parallelize = 10 + +selftest-algol68: + +# +# Install hooks: + +algol68.install-common: installdirs + -rm -f $(DESTDIR)$(bindir)/$(A68_INSTALL_NAME)$(exeext) + $(INSTALL_PROGRAM) ga68$(exeext) $(DESTDIR)$(bindir)/$(A68_INSTALL_NAME)$(exeext) + +algol68.install-man: $(DESTDIR)$(man1dir)/$(A68_INSTALL_NAME)$(man1ext) + +$(DESTDIR)$(man1dir)/$(A68_INSTALL_NAME)$(man1ext): doc/ga68.1 installdirs + -rm -f $@ + -$(INSTALL_DATA) $< $@ + -chmod a-x $@ + +$(DESTDIR)$(man7dir)/%.7algol: doc/%.7algol installdirs + -rm -f $@ + -$(INSTALL_DATA) $< $@ + -chmod a-x $@ + +algol68.install-info: $(DESTDIR)$(infodir)/ga68.info $(DESTDIR)$(infodir)/ga68-internals.info + +algol68.install-html: $(build_htmldir)/ga68 $(build_htmldir)/ga68-internals + @$(NORMAL_INSTALL) + test -z "$(htmldir)" || $(mkinstalldirs) "$(DESTDIR)$(htmldir)" + @for p in $(build_htmldir)/ga68; do \ + if test -f "$$p" || test -d "$$p"; then d=""; else d="$(srcdir)/"; fi; \ + f=$(html__strip_dir) \ + if test -d "$$d$$p"; then \ + echo " $(mkinstalldirs) '$(DESTDIR)$(htmldir)/$$f'"; \ + $(mkinstalldirs) "$(DESTDIR)$(htmldir)/$$f" || exit 1; \ + echo " $(INSTALL_DATA) '$$d$$p'/* '$(DESTDIR)$(htmldir)/$$f'"; \ + $(INSTALL_DATA) "$$d$$p"/* "$(DESTDIR)$(htmldir)/$$f"; \ + else \ + echo " $(INSTALL_DATA) '$$d$$p' '$(DESTDIR)$(htmldir)/$$f'"; \ + $(INSTALL_DATA) "$$d$$p" "$(DESTDIR)$(htmldir)/$$f"; \ + fi; \ + done + +algol68.uninstall: +# +# Clean hooks: +# A lot of the ancillary files are deleted by the main makefile. +# We just have to delete files specific to us. +algol68.mostlyclean: + -rm -f algol68/*$(objext) algol68/xforward algol68/fflags + -rm -f algol68/*$(coverageexts) +algol68.clean: algol68.mostlyclean +algol68.distclean: + -rm -f algol68/Makefile algol68/Make-host algol68/Make-target + -rm -f algol68/config.status algol68/config.cache +algol68.maintainer-clean: + -rm -f $(gcc_docdir)/*.7algol + +# +# Stage hooks: + +algol68.stage1: stage1-start + -mv algol68/*$(objext) stage1/algol68 +algol68.stage2: stage2-start + -mv algol68/*$(objext) stage2/algol68 +algol68.stage3: stage3-start + -mv algol68/*$(objext) stage3/algol68 +algol68.stage4: stage4-start + -mv algol68/*$(objext) stage4/algol68 +algol68.stageprofile: stageprofile-start + -mv algol68/*$(objext) stageprofile/algol68 +algol68.stagefeedback: stagefeedback-start + -mv algol68/*$(objext) stagefeedback/algol68 diff --git a/gcc/algol68/README b/gcc/algol68/README new file mode 100644 index 000000000000..9d1595ad8d8c --- /dev/null +++ b/gcc/algol68/README @@ -0,0 +1,130 @@ +This is the GNU Algol 68 compiler. + +This compiler implements the Algol 68 programming language +(https://www.algol68-lang.org) as defined in the Revised Report, along +with several GNU extensions to the language which are oriented to +enhance its application in systems programming and to achieve a good +integration in POSIX systems. + +The parser component used in this front-end has been adapted from +Algol 68 Genie, an Algol 68 interpreter written by Marcel van der +Veer. It is worth noting that this parser is not your typical garden +variety parser, as it is capable of effectively parsing the two-level +grammar of Algol 68, which is no small task. Parsing Algol 68 is +notoriously difficult, and without Marcel's careful work of many years +this front-end would most probably not exist. It is also a beautiful +implementation that is a delight to both read and work with. + +The syntax tree built by the parser is lowered into a GENERIC tree by +a lowering pass, which then invokes the gimplifier and hands the +resulting gimple IR over to the rest of the compilation, down the +rabbit hole all the way to optimized assembly code. + +The compiler driver is called `ga68'. +The compiler proper is called `a681'. + +Programs built by this compiler make use of the libga68 run-time +library. + +Building +======== + +Configure and build GCC with: + + $ mkdir build-algol68 + $ cd build-algol68 + $ ../configure --enable-languages=algol68 + $ make + $ make install + +Alternatively you can configure and build a non-bootstrapped compiler, +which is much faster to build. But note that in this case you better +pass some flags so the compiler gets built optimized, or the resulting +compiler will be rather slow: + + $ mkdir build-algol68 + $ cd build-algol68 + $ ../configure --enable-languages=algol68 BOOT_CFLAGS="-O2 -g" \ + BOOT_CXXFLAGS="-O2 -g" \ + STAGE1_CFLAGS="-O2 -g" \ + STAGE1_CXXFLAGS="-O2 -g" + $ make + $ make install + +Debugging +========= + +A few front-end specific options useful for debugging are: + + '-fa68-dump-ast' + Emits a textual representation of the parse tree as produced by the parser. + + '-fa68-dump-modes' + Emits a list of all parsed modes. + +See the Developer Options section in the GNU Algol Compiler manual for +more hacking related options. + +Testing +======= + +Invoke the full testsuite from the build directory: + + $ make check-algol68 + +You can pass -jN to run tests in parallel: + + $ make -jN check-algol68 + +Invoke a subset of the testsuite. For example, to only run tests that +involve compilation but not running: + + $ make check-algol68 RUNTESTFLAGS="compile.exp" + +There are the following sets of tests: + + compile.exp - compilation tests + +Invoke only a specific test: + + $ make check-algol68 RUNTESTFLAGS="--all compile.exp=bad-coercion-1.a68" + +Test in both 32-bit and 64-bit in multilib arches: + + $ make check-algol68 RUNTESTFLAGS="--target_board=unix\{-m64,-m32\}" + +Test that integration with the GCC GC is correct: + + $ make check-algol68 RUNTESTFLAGS="CFLAGS_FOR_TARGET='--param=ggc-min-expand=0 --param=ggc-min-heapsize=0'" + +Logs (with corresponding commands) can be found in +BUILD/gcc/testsuite/algol68/algol68.log. + +See https://gcc.gnu.org/install/test.html for more details. + +Useful Resources +================ + +- An Emacs mode for editing Algol 68 programs can be found at + https://git.sr.ht/~jemarch/a68-mode. It supports automatic + indentation, pretty-printing of bold tags, an auto-stropping minor + mode and other features. + +- The Algol 68 Jargon File at https://jemarch.net/a68-jargon provides + a comprehensive list of definitions of many of the technical and + non-technical terms used in the context of Algol 68. + +- The very formal Revised Report on the Algorithmic Language ALGOL 68 + can be found at [1]. + +- The truly delightful Informal Introduction to ALGOL 68 by C.H + Lindsey and van der Meulen can be found at [2]. + +Community +========= + +mailing list: algol68@gcc.gnu.org +irc: irc.oftc.net - #gnualgol + +[1] https://www.softwarepreservation.org/projects/ALGOL/report/Algol68_revised_report-AB-600dpi.pdf +[2] https://inria.hal.science/hal-03027689/file/Lindsey_van_der_Meulen-IItA68-Revised.pdf diff --git a/gcc/algol68/a68-diagnostics.cc b/gcc/algol68/a68-diagnostics.cc new file mode 100644 index 000000000000..254be5f49b2e --- /dev/null +++ b/gcc/algol68/a68-diagnostics.cc @@ -0,0 +1,389 @@ +/* Error and warning routines. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted and expanded for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "diagnostic.h" + +#include "a68.h" + +/* + * Error handling routines. + */ + +#define TABULATE(n) (8 * (n / 8 + 1) - n) + +/* Severities handled by the DIAGNOSTIC function defined below. */ + +#define A68_ERROR 0 +#define A68_WARNING 1 +#define A68_FATAL 2 +#define A68_SCAN_ERROR 3 +#define A68_INFORM 4 + +/* Auxiliary function used to grow an obstack by the contents of some given + string. */ + +static void +obstack_append_str (obstack *b, const char *str) +{ + obstack_grow (b, str, strlen (str)); +} + +/* Give a diagnostic message. */ + +#if __GNUC__ >= 10 +#pragma GCC diagnostic ignored "-Wsuggest-attribute=format" +#endif + +static bool +diagnostic (int sev, int opt, + NODE_T *p, + LINE_T *line, + char *pos, + const char *loc_str, va_list args) +{ + int res = 0; + MOID_T *moid = NO_MOID; + const char *t = loc_str; + obstack b; + + /* + * Synthesize diagnostic message. + * + * Legend for special symbols: + * * as first character, copy rest of string literally + * @ AST node + * A AST node attribute + * B keyword + * C context + * L line number + * M moid - if error mode return without giving a message + * O moid - operand + * S quoted symbol, when possible with typographical display features + * X expected attribute + * Y string literal. + * Z quoted string. */ + + static va_list argp; /* Note this is empty. */ + gcc_obstack_init (&b); + + if (t[0] == '*') + obstack_append_str (&b, t + 1); + else + while (t[0] != '\0') + { + if (t[0] == '@') + { + const char *nt = a68_attribute_name (ATTRIBUTE (p)); + if (t != NO_TEXT) + obstack_append_str (&b, nt); + else + obstack_append_str (&b, "construct"); + } + else if (t[0] == 'A') + { + enum a68_attribute att = (enum a68_attribute) va_arg (args, int); + const char *nt = a68_attribute_name (att); + if (nt != NO_TEXT) + obstack_append_str (&b, nt); + else + obstack_append_str (&b, "construct"); + } + else if (t[0] == 'B') + { + enum a68_attribute att = (enum a68_attribute) va_arg (args, int); + KEYWORD_T *nt = a68_find_keyword_from_attribute (A68 (top_keyword), att); + if (nt != NO_KEYWORD) + { + const char *strop_keyword = a68_strop_keyword (TEXT (nt)); + + obstack_append_str (&b, "%<"); + obstack_append_str (&b, strop_keyword); + obstack_append_str (&b, "%>"); + } + else + obstack_append_str (&b, "keyword"); + } + else if (t[0] == 'C') + { + int att = va_arg (args, int); + const char *sort = NULL; + + switch (att) + { + case NO_SORT: sort = "this"; break; + case SOFT: sort = "a soft"; break; + case WEAK: sort = "a weak"; break; + case MEEK: sort = "a meek"; break; + case FIRM: sort = "a firm"; break; + case STRONG: sort = "a strong"; break; + default: + gcc_unreachable (); + } + + obstack_append_str (&b, sort); + } + else if (t[0] == 'L') + { + LINE_T *a = va_arg (args, LINE_T *); + gcc_assert (a != NO_LINE); + if (NUMBER (a) == 0) + obstack_append_str (&b, "in standard environment"); + else if (p != NO_NODE && NUMBER (a) == LINE_NUMBER (p)) + obstack_append_str (&b, "in this line"); + else + { + char d[18]; + if (snprintf (d, 18, "in line %d", NUMBER (a)) < 0) + gcc_unreachable (); + obstack_append_str (&b, d); + } + } + else if (t[0] == 'M') + { + const char *moidstr = NULL; + + moid = va_arg (args, MOID_T *); + if (moid == NO_MOID || moid == M_ERROR) + moid = M_UNDEFINED; + + if (IS (moid, SERIES_MODE)) + { + if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) + moidstr = a68_moid_to_string (MOID (PACK (moid)), + MOID_ERROR_WIDTH, p); + else + moidstr = a68_moid_to_string (moid, MOID_ERROR_WIDTH, p); + } + else + moidstr = a68_moid_to_string (moid, MOID_ERROR_WIDTH, p); + + obstack_append_str (&b, "%<"); + obstack_append_str (&b, moidstr); + obstack_append_str (&b, "%>"); + } + else if (t[0] == 'O') + { + moid = va_arg (args, MOID_T *); + if (moid == NO_MOID || moid == M_ERROR) + moid = M_UNDEFINED; + if (moid == M_VOID) + obstack_append_str (&b, "UNION (VOID, ..)"); + else if (IS (moid, SERIES_MODE)) + { + const char *moidstr = NULL; + + if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) + moidstr = a68_moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p); + else + moidstr = a68_moid_to_string (moid, MOID_ERROR_WIDTH, p); + obstack_append_str (&b, moidstr); + } + else + { + const char *moidstr = a68_moid_to_string (moid, MOID_ERROR_WIDTH, p); + obstack_append_str (&b, moidstr); + } + } + else if (t[0] == 'S') + { + if (p != NO_NODE && NSYMBOL (p) != NO_TEXT) + { + const char *txt = NSYMBOL (p); + char *sym = NCHAR_IN_LINE (p); + int n = 0, size = (int) strlen (txt); + + obstack_append_str (&b, "%<"); + if (txt[0] != sym[0] || (int) strlen (sym) < size) + obstack_append_str (&b, txt); + else + { + while (n < size) + { + if (ISPRINT (sym[0])) + obstack_1grow (&b, sym[0]); + if (TOLOWER (txt[0]) == TOLOWER (sym[0])) + { + txt++; + n++; + } + sym++; + } + } + obstack_append_str (&b, "%>"); + } + else + obstack_append_str (&b, "symbol"); + } + else if (t[0] == 'X') + { + enum a68_attribute att = (enum a68_attribute) (va_arg (args, int)); + const char *att_name = a68_attribute_name (att); + obstack_append_str (&b, att_name); + } + else if (t[0] == 'Y') + { + char *loc_string = va_arg (args, char *); + obstack_append_str (&b, loc_string); + } + else if (t[0] == 'Z') + { + char *str = va_arg (args, char *); + obstack_append_str (&b, "%<"); + obstack_append_str (&b, str); + obstack_append_str (&b, "%>"); + } + else + obstack_1grow (&b, t[0]); + + t++; + } + + obstack_1grow (&b, '\0'); + char *format = (char *) obstack_finish (&b); + + /* Construct a diagnostic message. */ + if (sev == A68_WARNING) + WARNING_COUNT (&A68_JOB)++; + else if (sev != A68_INFORM) + ERROR_COUNT (&A68_JOB)++; + + /* Emit the corresponding GCC diagnostic at the proper location. */ + location_t loc = UNKNOWN_LOCATION; + + if (p != NO_NODE) + loc = a68_get_node_location (p); + else if (line != NO_LINE) + { + if (pos == NO_TEXT) + pos = STRING (line); + loc = a68_get_line_location (line, pos); + } + + /* Prepare rich location and diagnostics. */ + rich_location rich_loc (line_table, loc); + diagnostics::diagnostic_info diagnostic; + enum diagnostics::kind kind; + + switch (sev) + { + case A68_FATAL: + kind = diagnostics::kind::fatal; + break; + case A68_INFORM: + kind = diagnostics::kind::note; + break; + case A68_WARNING: + kind = diagnostics::kind::warning; + break; + case A68_SCAN_ERROR: + case A68_ERROR: + kind = diagnostics::kind::error; + break; + default: + gcc_unreachable (); + } + + diagnostic_set_info (&diagnostic, format, + &argp, + &rich_loc, kind); + if (opt != 0) + diagnostic.m_option_id = opt; + res = diagnostic_report_diagnostic (global_dc, &diagnostic); + + if (sev == A68_SCAN_ERROR) + exit (FATAL_EXIT_CODE); + return res; +} + +/* Give an intelligible error and exit. A line is provided rather than a + node so this can be used at scanning time. */ + +void +a68_scan_error (LINE_T * u, char *v, const char *txt, ...) +{ + va_list args; + + va_start (args, txt); + diagnostic (A68_SCAN_ERROR, 0, NO_NODE, u, v, txt, args); + va_end (args); +} + +/* Report a compilation error. */ + +void +a68_error (NODE_T *p, const char *loc_str, ...) +{ + va_list args; + + va_start (args, loc_str); + diagnostic (A68_ERROR, 0, p, NO_LINE, NO_TEXT, loc_str, args); + va_end (args); +} + +/* Report a compilation error in a node's pragmat. */ + +void +a68_error_in_pragmat (NODE_T *p, size_t off, + const char *loc_str, ...) +{ + va_list args; + + LINE_T *line = NPRAGMAT_LINE (p); + char *pos = NPRAGMAT_CHAR_IN_LINE (p) + off; + + va_start (args, loc_str); + diagnostic (A68_ERROR, 0, NO_NODE, line, pos, loc_str, args); + va_end (args); + a68_inform (p, "pragmat applies to this construct"); +} + +/* Report a compilation warning. + This function returns a boolean indicating whether a warning was + emitted. */ + +bool +a68_warning (NODE_T *p, int opt, + const char *loc_str, ...) +{ + bool res; + va_list args; + + va_start (args, loc_str); + res = diagnostic (A68_WARNING, opt, p, NO_LINE, NO_TEXT, loc_str, args); + va_end (args); + return res; +} + +/* Report a compilation note. */ + +void +a68_inform (NODE_T *p, const char *loc_str, ...) +{ + va_list args; + + va_start (args, loc_str); + diagnostic (A68_INFORM, 0, p, NO_LINE, NO_TEXT, loc_str, args); + va_end (args); +} diff --git a/gcc/algol68/a68-exports.cc b/gcc/algol68/a68-exports.cc new file mode 100644 index 000000000000..375b6213cefb --- /dev/null +++ b/gcc/algol68/a68-exports.cc @@ -0,0 +1,599 @@ +/* Exporting Algol 68 module interfaces. + Copyright (C) 2025 Jose E. Marchesi. + Copyright (C) 2010-2025 Free Software Foundation, Inc. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "memmodel.h" +#include "tree.h" +#include "target.h" +#include "tm_p.h" +#include "simple-object.h" +#include "varasm.h" +#include "intl.h" +#include "output.h" /* for assemble_string */ +#include "common/common-target.h" +#include "dwarf2asm.h" + +#include + +#include "a68.h" + +#ifndef TARGET_AIX_OS +#define TARGET_AIX_OS 0 +#endif + +/* The size of the target's pointer type. */ +#ifndef PTR_SIZE +#define PTR_SIZE (POINTER_SIZE / BITS_PER_UNIT) +#endif + +/* Create a new module interface, initially with no modes and no + extracts. MODULE_NAME is the name of the module as it is accessed at the + source level, which corresponds to a bold word. */ + +MOIF_T * +a68_moif_new (const char *module_name) +{ + MOIF_T *moif = ggc_cleared_alloc (); + + VERSION (moif) = GA68_EXPORTS_VERSION; + NAME (moif) = (module_name == NULL ? NULL : ggc_strdup (module_name)); + PRELUDE (moif) = NULL; + POSTLUDE (moif) = NULL; + vec_alloc (MODES (moif), 16); + vec_alloc (MODULES (moif), 16); + vec_alloc (IDENTIFIERS (moif), 16); + vec_alloc (INDICANTS (moif), 16); + vec_alloc (PRIOS (moif), 16); + vec_alloc (OPERATORS (moif), 16); + return moif; +} + +/* Add a new mode to a module interface. */ + +static void +a68_add_moid_to_moif (MOIF_T *moif, MOID_T *m) +{ + if (! MODES(moif)->contains (m)) + vec_safe_push (MODES (moif), m); +} + +/* Add a new identifier extract to a module interface. */ + +void +a68_add_identifier_to_moif (MOIF_T *moif, TAG_T *tag) +{ + EXTRACT_T *e = ggc_alloc (); + const char *tag_symbol = IDENTIFIER_POINTER (DECL_NAME (TAX_TREE_DECL (tag))); + + EXTRACT_KIND (e) = GA68_EXTRACT_IDEN; + EXTRACT_SYMBOL (e) = ggc_strdup (tag_symbol); + EXTRACT_MODE (e) = MOID (tag); + EXTRACT_PRIO (e) = 0; + EXTRACT_VARIABLE (e) = VARIABLE (tag); + EXTRACT_IN_PROC (e) = IN_PROC (tag); + + if (! IDENTIFIERS (moif)->contains (e)) + { + a68_add_moid_to_moif (moif, MOID (tag)); + vec_safe_push (IDENTIFIERS (moif), e); + } +} + +/* Add a new mode indicant extract to a module interface. */ + +static void +a68_add_indicant_to_moif (MOIF_T *moif, TAG_T *tag) +{ + EXTRACT_T *e = ggc_alloc (); + /* Mode tags are not associated with declarations, so we have to do the + mangling here. */ + tree id = a68_get_mangled_indicant (NSYMBOL (NODE (tag)), NAME (moif)); + const char *tag_symbol = IDENTIFIER_POINTER (id); + + EXTRACT_KIND (e) = GA68_EXTRACT_MODE; + EXTRACT_SYMBOL (e) = ggc_strdup (tag_symbol); + EXTRACT_MODE (e) = MOID (tag); + EXTRACT_PRIO (e) = 0; + EXTRACT_VARIABLE (e) = false; + EXTRACT_IN_PROC (e) = false; + + if (! INDICANTS (moif)->contains (e)) + { + a68_add_moid_to_moif (moif, MOID (tag)); + vec_safe_push (INDICANTS (moif), e); + } +} + +/* Add a new module extract to a module interface. */ + +static void +a68_add_module_to_moif (MOIF_T *moif, TAG_T *tag) +{ + EXTRACT_T *e = ggc_alloc (); + /* Module tags are not associated with declarations, so we have to do the + mangling here. */ + tree id = a68_get_mangled_indicant (NSYMBOL (NODE (tag)), NAME (moif)); + const char *tag_symbol = IDENTIFIER_POINTER (id); + + EXTRACT_KIND (e) = GA68_EXTRACT_MODU; + EXTRACT_SYMBOL (e) = ggc_strdup (tag_symbol); + EXTRACT_MODE (e) = NO_MOID; + EXTRACT_PRIO (e) = 0; + EXTRACT_VARIABLE (e) = false; + EXTRACT_IN_PROC (e) = false; + + if (! MODULES (moif)->contains (e)) + vec_safe_push (MODULES (moif), e); +} + +/* Add a new priority extract to a module interface. */ + +static void +a68_add_prio_to_moif (MOIF_T *moif, TAG_T *tag) +{ + EXTRACT_T *e = ggc_alloc (); + /* Priority tags are not associated with declarations, so we have to do the + mangling here. */ + tree id = a68_get_mangled_indicant (NSYMBOL (NODE (tag)), NAME (moif)); + const char *tag_symbol = IDENTIFIER_POINTER (id); + + EXTRACT_KIND (e) = GA68_EXTRACT_PRIO; + EXTRACT_SYMBOL (e) = ggc_strdup (tag_symbol); + EXTRACT_MODE (e) = NO_MOID; + EXTRACT_PRIO (e) = PRIO (tag); + EXTRACT_VARIABLE (e) = false; + EXTRACT_IN_PROC (e) = false; + + if (! PRIOS (moif)->contains (e)) + vec_safe_push (PRIOS (moif), e); +} + +/* Add a new operator extract to a module interface. */ + +static void +a68_add_operator_to_moif (MOIF_T *moif, TAG_T *tag) +{ + EXTRACT_T *e = ggc_alloc (); + const char *tag_symbol = IDENTIFIER_POINTER (DECL_NAME (TAX_TREE_DECL (tag))); + + EXTRACT_KIND (e) = GA68_EXTRACT_OPER; + EXTRACT_SYMBOL (e) = ggc_strdup (tag_symbol); + EXTRACT_MODE (e) = MOID (tag); + EXTRACT_PRIO (e) = 0; + EXTRACT_VARIABLE (e) = EXTRACT_VARIABLE (tag); + /* There are no operatorvariable-declarations */ + gcc_assert (EXTRACT_VARIABLE (e) == false); + EXTRACT_IN_PROC (e) = IN_PROC (tag); + + if (! OPERATORS (moif)->contains (e)) + { + a68_add_moid_to_moif (moif, MOID (tag)); + vec_safe_push (OPERATORS (moif), e); + } +} + +/* Make the exports section the asm_out_file's new current section. */ + +static void +a68_switch_to_export_section (void) +{ + static section *exports_sec; + + if (exports_sec == NULL) + { + gcc_assert (targetm_common.have_named_sections); +#ifdef OBJECT_FORMAT_MACHO + exports_sec + = get_section (A68_EXPORT_SEGMENT_NAME "," A68_EXPORT_SECTION_NAME, + SECTION_DEBUG, NULL); +#else + exports_sec = get_section (A68_EXPORT_SECTION_NAME, + TARGET_AIX_OS ? SECTION_EXCLUDE : SECTION_DEBUG, + NULL); +#endif + } + + switch_to_section (exports_sec); +} + +/* Output a sized string. */ + +static void +a68_asm_output_string (const char *s, const char *comment) +{ + dw2_asm_output_data (2, strlen (s) + 1, comment); + assemble_string (s, strlen (s) + 1); +} + +/* Output a mode to the exports section if it hasn't been emitted already. */ + +static void +a68_asm_output_mode (MOID_T *m, const char *module_label) +{ + /* Do nothing if the mode has been already emitted and therefore there is + already a label to access it. */ + if (ASM_LABEL (m) != NULL) + return; + + /* Mode indicants are not emitted in the mode table, but as mode extracts in + the extracts table. Still we have to emit the named mode. */ + if (IS (m, INDICANT)) + m = MOID (NODE (m)); + + /* Collection of modes. */ + if (IS (m, SERIES_MODE) || IS (m, STOWED_MODE)) + { + for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) + a68_asm_output_mode (MOID (p), module_label); + return; + } + + /* Ok we got a mode to output. */ + + /* First emit referred modes and sub-modes. Note how we have to create a + label for the mode and install it in the NODE_T in order to avoid infinite + recursion in case of ref-induced recursive mode definitions. */ + + static long int cnt; + static char label[100]; + ASM_GENERATE_INTERNAL_LABEL (label, "LM", cnt++); + ASM_LABEL (m) = ggc_strdup (label); + + if (IS_REF(m) || IS_FLEX (m)) + a68_asm_output_mode (SUB (m), module_label); + else if (m != M_STRING && IS_FLEXETY_ROW (m)) + a68_asm_output_mode (SUB (m), module_label); + else if (!IS_COMPLEX (m) && (IS_STRUCT (m) || IS_UNION (m))) + { + for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) + a68_asm_output_mode (MOID (p), module_label); + } + else if (IS (m, PROC_SYMBOL)) + { + a68_asm_output_mode (SUB (m), module_label); + for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) + a68_asm_output_mode (MOID (p), module_label); + } + + /* No recursion below this point pls. */ + + /* Emit a label for this mode. */ + ASM_OUTPUT_LABEL (asm_out_file, ASM_LABEL (m)); + + /* Now emit assembly for the mode entry. */ + if (m == M_VOID) + dw2_asm_output_data (1, GA68_MODE_VOID, "void"); + else if (m == M_CHAR) + dw2_asm_output_data (1, GA68_MODE_CHAR, "char"); + else if (m == M_BOOL) + dw2_asm_output_data (1, GA68_MODE_BOOL, "bool"); + else if (m == M_STRING) + dw2_asm_output_data (1, GA68_MODE_STRING, "string"); + else if (IS_INTEGRAL (m)) + { + dw2_asm_output_data (1, GA68_MODE_INT, "int"); + dw2_asm_output_data (1, DIM (m), "sizety"); + } + else if (IS_REAL (m)) + { + dw2_asm_output_data (1, GA68_MODE_REAL, "real"); + dw2_asm_output_data (1, DIM (m), "sizety"); + } + else if (IS_BITS (m)) + { + dw2_asm_output_data (1, GA68_MODE_BITS, "bits"); + dw2_asm_output_data (1, DIM (m), "sizety"); + } + else if (IS_BYTES (m)) + { + dw2_asm_output_data (1, GA68_MODE_BYTES, "bytes"); + dw2_asm_output_data (1, DIM (m), "sizety"); + } + else if (IS_COMPLEX (m)) + { + /* Complex is a struct of two reals of the right sizety. */ + int dim = DIM (MOID (PACK (m))); + dw2_asm_output_data (1, GA68_MODE_CMPL, "compl"); + dw2_asm_output_data (1, dim, "sizety"); + } + else if (IS_REF (m)) + { + dw2_asm_output_data (1, GA68_MODE_NAME, "ref"); + dw2_asm_output_delta (PTR_SIZE, ASM_LABEL (SUB (m)), module_label, "referred mode"); + } + else if (IS_FLEX (m)) + { + dw2_asm_output_data (1, GA68_MODE_FLEX, "flex"); + dw2_asm_output_delta (PTR_SIZE, ASM_LABEL (SUB (m)), module_label, "flexible row mode"); + } + else if (IS_ROW (m)) + { + dw2_asm_output_data (1, GA68_MODE_ROW, "row"); + dw2_asm_output_data (1, DIM (m), "dim"); + /* XXX for now emit zeroes as triplets. */ + for (int i = 0; i < DIM (m); ++i) + { + dw2_asm_output_data (PTR_SIZE, 0, "lb"); + dw2_asm_output_data (PTR_SIZE, 0, "ub"); + } + dw2_asm_output_delta (PTR_SIZE, ASM_LABEL (SUB (m)), module_label, "row of"); + } + else if (IS_STRUCT (m)) + { + dw2_asm_output_data (1, GA68_MODE_STRUCT, "struct"); + dw2_asm_output_data (2, DIM (m), "nfields"); + for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) + { + dw2_asm_output_delta (PTR_SIZE, ASM_LABEL (MOID (p)), module_label, "field mode"); + if (TEXT (p) != NO_TEXT) + a68_asm_output_string (TEXT (p), "field name"); + else + a68_asm_output_string ("", "field name"); + } + } + else if (IS_UNION (m)) + { + dw2_asm_output_data (1, GA68_MODE_UNION, "union"); + dw2_asm_output_data (2, DIM (m), "nmodes"); + for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) + dw2_asm_output_delta (PTR_SIZE, ASM_LABEL (MOID (p)), module_label, "united mode"); + } + else if (IS (m, PROC_SYMBOL)) + { + dw2_asm_output_data (1, GA68_MODE_PROC, "proc"); + dw2_asm_output_delta (PTR_SIZE, ASM_LABEL (SUB (m)), module_label, "ret mode"); + dw2_asm_output_data (1, DIM (m), "nargs"); + for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) + { + dw2_asm_output_delta (PTR_SIZE, ASM_LABEL (MOID (p)), module_label, "arg mode"); + if (TEXT (p) != NO_TEXT) + a68_asm_output_string (TEXT (p), "arg name"); + else + a68_asm_output_string ("", "arg name"); + } + } + else + dw2_asm_output_data (1, GA68_MODE_UNKNOWN, "unknown mode %s", + a68_moid_to_string (m, 80, NO_NODE, false)); +} + +/* Output an extract for a given tag to the extracts section. */ + +static void +a68_asm_output_extract (const char *module_label, int kind, + const char *symbol, MOID_T *mode, int prio, + bool variable, bool in_proc) +{ + static char begin_label[100]; + static char end_label[100]; + static long int cnt; + + ASM_GENERATE_INTERNAL_LABEL (begin_label, "LEBL", cnt); + ASM_GENERATE_INTERNAL_LABEL (end_label, "LEEL", cnt); + cnt++; + + dw2_asm_output_delta (PTR_SIZE, end_label, begin_label, "extract size"); + ASM_OUTPUT_LABEL (asm_out_file, begin_label); + + bool encode_mdextra = false; + switch (kind) + { + case GA68_EXTRACT_MODU: + dw2_asm_output_data (1, GA68_EXTRACT_MODU, "module extract %s", symbol); + a68_asm_output_string (symbol, "module indication"); + break; + case GA68_EXTRACT_MODE: + dw2_asm_output_data (1, GA68_EXTRACT_MODE, "mode extract %s", symbol); + a68_asm_output_string (symbol, "mode indication"); + dw2_asm_output_delta (PTR_SIZE, ASM_LABEL (mode), module_label, "mode"); + break; + case GA68_EXTRACT_IDEN: + dw2_asm_output_data (1, GA68_EXTRACT_IDEN, "identifier extract %s", symbol); + a68_asm_output_string (symbol, "name"); + dw2_asm_output_delta (PTR_SIZE, ASM_LABEL (mode), module_label, "mode"); + encode_mdextra = true; + break; + case GA68_EXTRACT_PRIO: + dw2_asm_output_data (1, GA68_EXTRACT_PRIO, "prio extract %s", symbol); + a68_asm_output_string (symbol, "opname"); + dw2_asm_output_data (1, prio, "priority"); + break; + case GA68_EXTRACT_OPER: + dw2_asm_output_data (1, GA68_EXTRACT_OPER, "operator extract %s", symbol); + a68_asm_output_string (symbol, "opname"); + dw2_asm_output_delta (PTR_SIZE, ASM_LABEL (mode), module_label, "mode"); + encode_mdextra = true; + break; + default: + gcc_unreachable (); + } + + if (encode_mdextra) + { + dw2_asm_output_data (PTR_SIZE, 2, "mdextra size"); + dw2_asm_output_data (1, variable, "variable"); + dw2_asm_output_data (1, in_proc, "in_proc"); + } + else + dw2_asm_output_data (PTR_SIZE, 0, "mdextra size"); + + ASM_OUTPUT_LABEL (asm_out_file, end_label); +} + +/* Output a module interface. */ + +static void +a68_asm_output_moif (MOIF_T *moif) +{ + a68_switch_to_export_section (); + + static char module_label[100]; + static long int moifcnt; + ASM_GENERATE_INTERNAL_LABEL (module_label, "LMOIF", moifcnt++); + ASM_OUTPUT_LABEL (asm_out_file, module_label); + + if (flag_debug_asm) + { + fputs (ASM_COMMENT_START " MODIF START ", asm_out_file); + fputs (NAME (moif), asm_out_file); + fputc ('\n', asm_out_file); + } + + dw2_asm_output_data (1, A68_EXPORT_MAGIC1, "magic1"); + dw2_asm_output_data (1, A68_EXPORT_MAGIC2, "magic2"); + dw2_asm_output_data (2, VERSION (moif), "exports version"); + a68_asm_output_string (NAME (moif), "module name"); + a68_asm_output_string (PRELUDE (moif) ? PRELUDE (moif) : "", "prelude symbol"); + a68_asm_output_string (POSTLUDE (moif) ? POSTLUDE (moif) : "", "postlude symbol"); + + /* Modes table. */ + static char modes_begin_label[100]; + static char modes_end_label[100]; + static long int modescnt; + ASM_GENERATE_INTERNAL_LABEL (modes_begin_label, "LMTL", modescnt++); + ASM_GENERATE_INTERNAL_LABEL (modes_end_label, "LMTL", modescnt++); + + if (flag_debug_asm) + fputs ("\t" ASM_COMMENT_START " modes table\n", asm_out_file); + dw2_asm_output_delta (PTR_SIZE, modes_end_label, modes_begin_label, + "modes size"); + ASM_OUTPUT_LABEL (asm_out_file, modes_begin_label); + for (MOID_T *m : MODES (moif)) + a68_asm_output_mode (m, module_label); + ASM_OUTPUT_LABEL (asm_out_file, modes_end_label); + + /* Extracts table. */ + static char extracts_begin_label[100]; + static char extracts_end_label[100]; + static long int extractscnt; + ASM_GENERATE_INTERNAL_LABEL (extracts_begin_label, "LETL", extractscnt++); + ASM_GENERATE_INTERNAL_LABEL (extracts_end_label, "LETL", extractscnt++); + + if (flag_debug_asm) + fputs ("\t" ASM_COMMENT_START " extracts table\n", asm_out_file); + dw2_asm_output_delta (PTR_SIZE, extracts_end_label, extracts_begin_label, + "extracts size"); + ASM_OUTPUT_LABEL (asm_out_file, extracts_begin_label); + for (EXTRACT_T *e : MODULES (moif)) + a68_asm_output_extract (module_label, GA68_EXTRACT_MODU, + EXTRACT_SYMBOL (e), EXTRACT_MODE (e), EXTRACT_PRIO (e), + EXTRACT_VARIABLE (e), EXTRACT_IN_PROC (e)); + for (EXTRACT_T *e : INDICANTS (moif)) + a68_asm_output_extract (module_label, GA68_EXTRACT_MODE, + EXTRACT_SYMBOL (e), EXTRACT_MODE (e), EXTRACT_PRIO (e), + EXTRACT_VARIABLE (e), EXTRACT_IN_PROC (e)); + for (EXTRACT_T *e : IDENTIFIERS (moif)) + a68_asm_output_extract (module_label, GA68_EXTRACT_IDEN, + EXTRACT_SYMBOL (e), EXTRACT_MODE (e), EXTRACT_PRIO (e), + EXTRACT_VARIABLE (e), EXTRACT_IN_PROC (e)); + for (EXTRACT_T *e : PRIOS (moif)) + a68_asm_output_extract (module_label, GA68_EXTRACT_PRIO, + EXTRACT_SYMBOL (e), EXTRACT_MODE (e), EXTRACT_PRIO (e), + EXTRACT_VARIABLE (e), EXTRACT_IN_PROC (e)); + for (EXTRACT_T *e : OPERATORS (moif)) + a68_asm_output_extract (module_label, GA68_EXTRACT_OPER, + EXTRACT_SYMBOL (e), EXTRACT_MODE (e), EXTRACT_PRIO (e), + EXTRACT_VARIABLE (e), EXTRACT_IN_PROC (e)); + ASM_OUTPUT_LABEL (asm_out_file, extracts_end_label); + + if (flag_debug_asm) + { + fputs (ASM_COMMENT_START " MODIF END ", asm_out_file); + fputs (NAME (moif), asm_out_file); + fputc ('\n', asm_out_file); + } +} + +/* Emit export information for the module definition in the parse tree P. */ + +void +a68_do_exports (NODE_T *p) +{ + for (;p != NO_NODE; FORWARD (p)) + { + if (IS (p, DEFINING_MODULE_INDICANT)) + { + // XXX only do this if the defining module is to be + // exported. Accessed modules without PUB are not exported. */ + TAG_T *tag = a68_find_tag_global (TABLE (p), MODULE_SYMBOL, NSYMBOL (p)); + gcc_assert (tag != NO_TAG); + + if (EXPORTED (tag)) + { + tree module_id = a68_get_mangled_indicant (NSYMBOL (p)); + MOIF_T *moif = a68_moif_new (IDENTIFIER_POINTER (module_id)); + char *prelude = xasprintf ("%s__prelude", IDENTIFIER_POINTER (module_id)); + char *postlude = xasprintf ("%s__postlude", IDENTIFIER_POINTER (module_id)); + PRELUDE (moif) = ggc_strdup (prelude); + POSTLUDE (moif) = ggc_strdup (postlude); + free (prelude); + free (postlude); + + NODE_T *module_text = NEXT (NEXT (p)); + gcc_assert (IS (module_text, MODULE_TEXT)); + NODE_T *def_part = (IS (SUB (module_text), REVELATION_PART) + ? NEXT_SUB (module_text) + : SUB (module_text)); + gcc_assert (IS (def_part, DEF_PART)); + TABLE_T *table = TABLE (SUB (def_part)); + gcc_assert (PUBLIC_RANGE (table)); + + for (TAG_T *t = MODULES (table); t != NO_TAG; FORWARD (t)) + { + if (PUBLICIZED (t)) + a68_add_module_to_moif (moif, t); + } + + for (TAG_T *t = INDICANTS (table); t != NO_TAG; FORWARD (t)) + { + if (PUBLICIZED (t)) + a68_add_indicant_to_moif (moif, t); + } + + for (TAG_T *t = IDENTIFIERS (table); t != NO_TAG; FORWARD (t)) + { + if (PUBLICIZED (t)) + a68_add_identifier_to_moif (moif, t); + } + + for (TAG_T *t = PRIO (table); t != NO_TAG; FORWARD (t)) + { + if (PUBLICIZED (t)) + a68_add_prio_to_moif (moif, t); + } + + for (TAG_T *t = OPERATORS (table); t != NO_TAG; FORWARD (t)) + { + if (PUBLICIZED (t)) + a68_add_operator_to_moif (moif, t); + } + + a68_asm_output_moif (moif); + if (flag_a68_dump_moif) + a68_dump_moif (moif); + } + } + else + a68_do_exports (SUB (p)); + } +} diff --git a/gcc/algol68/a68-imports.cc b/gcc/algol68/a68-imports.cc new file mode 100644 index 000000000000..6b203b26273b --- /dev/null +++ b/gcc/algol68/a68-imports.cc @@ -0,0 +1,1264 @@ +/* Importing Algol 68 module interfaces. + Copyright (C) 2025 Jose E. Marchesi. + Copyright (C) 2010-2025 Free Software Foundation, Inc. + + Written by Jose E. Marchesi. + + The following utility functions have been adapted from the Go front-end: + + a68_open_packet + a68_try_packet_in_directory + a68_try_suffixes + a68_find_export_data + a68_find_object_export_data + a68_read_export_data + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "memmodel.h" +#include "tree.h" +#include "target.h" +#include "tm_p.h" +#include "simple-object.h" +#include "varasm.h" +#include "intl.h" +#include "common/common-target.h" +#include "dwarf2asm.h" + +#include + +#include "a68.h" + +/* Read exports from an object file. + + FD is a file descriptor open for reading. + + OFFSET is the offset within the file where the object file starts; this will + be 0 except when reading an archive. + + On success this returns NULL and sets *PBUF to a buffer allocated using + malloc, of size *PLEN, holding the export data. + + If the data is not found this returns NULL and sets *PBUF to NULL and *PLEN + to 0. + + If some error occurs, this returns an error message and sets *PERR to an + errno value or 0 if there is no relevant errno. */ + +static const char * +a68_read_export_data (int fd, uint64_t offset, char **pbuf, size_t *plen, + int *perr) +{ + simple_object_read *sobj; + const char *errmsg; + off_t sec_offset; + off_t sec_length; + int found; + char *buf; + ssize_t c; + + *pbuf = NULL; + *plen = 0; + + sobj = simple_object_start_read (fd, offset, A68_EXPORT_SEGMENT_NAME, + &errmsg, perr); + if (sobj == NULL) + { + /* If we get an error here, just pretend that we didn't find any + export data. This is the right thing to do if the error is + that the file was not recognized as an object file. This + will ignore file I/O errors, but it's not too big a deal + because we will wind up giving some other error later. */ + return NULL; + } + + found = simple_object_find_section (sobj, A68_EXPORT_SECTION_NAME, + &sec_offset, &sec_length, + &errmsg, perr); + simple_object_release_read (sobj); + if (!found) + return errmsg; + + if (lseek (fd, offset + sec_offset, SEEK_SET) < 0) + { + *perr = errno; + return _("lseek failed while reading export data"); + } + + buf = XNEWVEC (char, sec_length); + if (buf == NULL) + { + *perr = errno; + return _("memory allocation failed while reading export data"); + } + + c = read (fd, buf, sec_length); + if (c < 0) + { + *perr = errno; + free (buf); + return _("read failed while reading export data"); + } + + if (c < sec_length) + { + free (buf); + return _("short read while reading export data"); + } + + *pbuf = buf; + *plen = sec_length; + return NULL; +} + +/* Look for export data in an object file. */ + +static char * +a68_find_object_export_data (const std::string& filename, + int fd, uint64_t offset, size_t *psize) +{ + char *buf; + size_t len; + int err; + + const char *errmsg = a68_read_export_data (fd, offset, &buf, &len, &err); + if (errmsg != NULL) + { + if (err == 0) + a68_error (NO_NODE, "Z: Z", filename.c_str (), errmsg); + else + a68_error (NO_NODE, "Z: Z: Z", filename.c_str(), errmsg, + xstrerror(err)); + return NULL; + } + + *psize = len; + return buf; +} + +/* Look for export data in the file descriptor FD. */ + +static char * +a68_find_export_data (const std::string &filename, int fd, size_t *psize) +{ + /* See if we can read this as an object file. */ + char *exports = a68_find_object_export_data (filename, fd, 0, psize); + if (exports != NULL) + return exports; + + if (lseek (fd, 0, SEEK_SET) < 0) + { + a68_error (NO_NODE, "lseek Z failed", filename.c_str ()); + return NULL; + } + + char buf[A68_EXPORT_MAGIC_LEN]; + ssize_t c = ::read(fd, buf, A68_EXPORT_MAGIC_LEN); + if (c < A68_EXPORT_MAGIC_LEN) + return NULL; + + /* Check for a file containing nothing but Algol 68 export data. */ + if (buf[0] == '\x0a' && buf[1] == '\xad') + { + /* XXX read whole file. */ + return exports; + } + +#if 0 + /* See if we can read this as an archive. */ + if (Import::is_archive_magic(buf)) + return Import::find_archive_export_data(filename, fd, location); +#endif + + return NULL; + +} + +/* Given *PFILENAME, where *PFILENAME does not exist, try various suffixes. If + we find one, set *FILENAME to the one we found. Return the open file + descriptor. */ + +static int +a68_try_suffixes (std::string *pfilename) +{ + std::string filename = *pfilename + ".m68"; + int fd = open (filename.c_str(), O_RDONLY | O_BINARY); + if (fd >= 0) + { + *pfilename = filename; + return fd; + } + + const char* basename = lbasename (pfilename->c_str()); + size_t basename_pos = basename - pfilename->c_str (); + filename = pfilename->substr (0, basename_pos) + "lib" + basename + ".so"; + fd = open (filename.c_str (), O_RDONLY | O_BINARY); + if (fd >= 0) + { + *pfilename = filename; + return fd; + } + + filename = pfilename->substr (0, basename_pos) + "lib" + basename + ".a"; + fd = open (filename.c_str (), O_RDONLY | O_BINARY); + if (fd >= 0) + { + *pfilename = filename; + return fd; + } + + filename = *pfilename + ".o"; + fd = open (filename.c_str(), O_RDONLY | O_BINARY); + if (fd >= 0) + { + *pfilename = filename; + return fd; + } + + return -1; +} + +/* Try to find the export data for FILENAME. */ + +static char * +a68_try_packet_in_directory (const std::string &filename, size_t *psize) +{ + std::string found_filename = filename; + int fd = open (found_filename.c_str(), O_RDONLY | O_BINARY); + + if (fd >= 0) + { + struct stat s; + if (fstat (fd, &s) >= 0 && S_ISDIR (s.st_mode)) + { + close (fd); + fd = -1; + errno = EISDIR; + } + } + + if (fd < 0) + { + if (errno != ENOENT && errno != EISDIR) + a68_warning (NO_NODE, 0, "cannot open file Z for imports", + filename.c_str ()); + + fd = a68_try_suffixes (&found_filename); + if (fd < 0) + return NULL; + } + + /* The export data may not be in this file. */ + char *exports = a68_find_export_data (found_filename, fd, psize); + if (exports != NULL) + return exports; + + close (fd); + + a68_error (NO_NODE, "file Z exists but does not contain any export data", + found_filename.c_str ()); + + return NULL; +} + +/* Find import data in FILENAME. + + This searches the file system for FILENAME, reads exports information from + it, and returns a pointer to the beginning of an allocated buffer with the + exports data, its size in *psize. It is up to the caller of this function + to release the buffer when it is no longer necessary. If the file is not + found, this function returns NULL. + + When FILENAME is not an absolute path and does not start with ./ or ../, we + use the search path provided by -I and -L options. + + When FILENAME does start with ./ or ../, we use RELATIVE_IMPORT_PATH as a + prefix. + + When FILENAME does not exist, we try modifying FILENAME to find the file. + We use the first of these which exists: + + - We append ".m68". + - We turn the base of FILENAME info libFILENAME.so. + - We turn the base of FILENAME into libFILENAME.a. + - We append ".o". + + When using a search path, we apply each of these transformations at each + entry on the search path before moving on to the next entry. If the file + exists, but does not contain Algol 68 export data, we stop; we do not keep + looking for another file with the same name later in the search path. */ + +static char * +a68_get_packet_exports (const std::string &filename, + const std::string &relative_import_path, + size_t *psize) +{ + char *exports; + + bool is_local; + if (IS_ABSOLUTE_PATH (filename)) + is_local = true; + else if (filename[0] == '.' + && (filename[1] == '\0' || IS_DIR_SEPARATOR (filename[1]))) + is_local = true; + else if (filename[0] == '.' + && filename[1] == '.' + && (filename[2] == '\0' || IS_DIR_SEPARATOR (filename[2]))) + is_local = true; + else + is_local = false; + + std::string fn = filename; + if (is_local && !IS_ABSOLUTE_PATH (filename) + && !relative_import_path.empty ()) + { + if (fn == ".") + /* A special case. */ + fn = relative_import_path; + else if (fn[0] == '.' && fn[1] == '.' + && (fn[2] == '\0' || IS_DIR_SEPARATOR (fn[2]))) + { + /* We are going to join relative_import_path and fn, and it will look + like DIR/../PATH. BUt DIR does not necessarily exist in this + case, and if it doesn't the use of .. will fail although it + shouldn't. */ + size_t index; + for (index = relative_import_path.length () - 1; + index > 0 && !IS_DIR_SEPARATOR (relative_import_path[index]); + index--) + ; + if (index > 0) + fn = relative_import_path.substr (0, index) + fn.substr (2); + else + fn = relative_import_path + '/' + fn; + } + else + fn = relative_import_path + '/' + fn; + is_local = false; + } + + if (!is_local) + { + for (std::string path : A68_IMPORT_PATHS) + { + if (path.empty () && path[path.size () - 1] != '/') + path += '/'; + path += fn; + exports = a68_try_packet_in_directory (path, psize); + if (exports != NULL) + return exports; + } + } + + return a68_try_packet_in_directory (fn, psize); +} + +/* The size of the target's pointer type, in bytes. */ +#ifndef PTR_SIZE +#define PTR_SIZE ((int)(POINTER_SIZE / BITS_PER_UNIT)) +#endif + +/* Collection of decoding helper macros, to be exclusively used in the + a68_decode_* functions below. */ + +#define DINT8(V) \ + do \ + { \ + if (pos + 1 > size) \ + goto decode_error; \ + (V) = (int8_t)data[pos++]; \ + } \ + while (0) + +#define DUINT8(V) \ + do \ + { \ + if (pos + 1 > size) \ + goto decode_error; \ + (V) = (uint8_t)data[pos++]; \ + } \ + while (0) + +#define DUINT16(V) \ + do \ + { \ + if (pos + 2 > size) \ + goto decode_error; \ + if (BYTES_BIG_ENDIAN) \ + (V) = ((uint8_t) data[pos] << 8) | (uint8_t) data[pos + 1]; \ + else \ + (V) = ((uint8_t) data[pos + 1] << 8) | (uint8_t) data[pos]; \ + pos += 2; \ + } \ + while (0) + +#define DOFFSET(V) \ + do \ + { \ + if (pos + PTR_SIZE > size) \ + goto decode_error; \ + (V) = 0; \ + uint64_t ptr_bit_size = 8 * PTR_SIZE; \ + if (BYTES_BIG_ENDIAN) \ + { \ + for (int i = 0; i < PTR_SIZE; i++) \ + (V) = ((V) | ((uint8_t) data[pos + i] << (ptr_bit_size - (i * 8)))); \ + } \ + else \ + { \ + for (int i = 0; i < PTR_SIZE; i++) \ + (V) = ((V) | ((uint8_t) data[pos + i] << (i * 8))); \ + } \ + pos += PTR_SIZE; \ + } \ + while (0) + +#define DSTR(V) \ + do \ + { \ + uint16_t len; \ + char *str = NULL; \ + DUINT16 (len); \ + if (pos + len > size) \ + goto decode_error; \ + if (len > 0) \ + { \ + str = (char *) xmalloc (len); \ + memcpy (str, data + pos, len); \ + pos += len; \ + } \ + (V) = str; \ + } \ + while (0) + +/* Types to denote encoded modes. */ + +struct encoded_triplet +{ + uint64_t lb; + uint64_t ub; +}; + +struct encoded_field +{ + uint64_t mode_offset; + char *name; +}; + +struct encoded_arg +{ + uint64_t arg_mode_offset; + char *arg_name; +}; + +struct encoded_mode +{ + MOID_T *moid; + uint64_t offset; + uint8_t kind; + int8_t sizety; + union + { + struct + { + uint64_t sub_offset; + } name; + + struct + { + uint8_t sub_offset; + } flex; + + struct + { + uint8_t ndims; + struct encoded_triplet *triplets; + uint64_t sub_offset; + } row; + + struct + { + uint16_t nfields; + struct encoded_field *fields; + } sct; + + struct + { + uint8_t nmodes; + uint64_t *modes; + } union_; + + struct + { + uint64_t ret_mode_offset; + uint8_t nargs; + struct encoded_arg *args; + } proc; + + } data; +}; + +/* Free the memory used by an encoded mode. */ + +static void +encoded_mode_free (struct encoded_mode *em) +{ + switch (em->kind) + { + case GA68_MODE_ROW: + free (em->data.row.triplets); + break; + case GA68_MODE_STRUCT: + /* Note that the field names are installed in moids in + encoded_mode_to_moid, so we shoud not free them. */ + free (em->data.sct.fields); + break; + case GA68_MODE_UNION: + free (em->data.union_.modes); + break; + case GA68_MODE_PROC: + for (uint8_t i = 0; i < em->data.proc.nargs; i++) + free (em->data.proc.args[i].arg_name); + free (em->data.proc.args); + break; + default: + break; + } + free (em); +} + +/* A collection of encoded modes indexed by offsets. */ + +#define NO_OFFSET ((uint64_t) -1) + +typedef hash_map, + struct encoded_mode *> encoded_modes_map_t; + +/* Complete a encoded mode. */ + +static MOID_T * +complete_encoded_mode (encoded_modes_map_t &encoded_modes, uint64_t offset) +{ + struct encoded_mode *em = *(encoded_modes.get (offset)); + MOID_T *sub; + PACK_T *pack; + + if (em->moid != NO_MOID) + return em->moid; + + switch (em->kind) + { + case GA68_MODE_VOID: em->moid = M_VOID; break; + case GA68_MODE_CHAR: em->moid = M_CHAR; break; + case GA68_MODE_BOOL: em->moid = M_BOOL; break; + case GA68_MODE_STRING: em->moid = M_FLEX_ROW_CHAR; break; + case GA68_MODE_INT: + switch (em->sizety) + { + case 0: em->moid = M_INT; break; + case 1: em->moid = M_LONG_INT; break; + case 2: em->moid = M_LONG_LONG_INT; break; + case -1: em->moid = M_SHORT_INT; break; + case -2: em->moid = M_SHORT_SHORT_INT; break; + default: + gcc_unreachable (); + } + break; + case GA68_MODE_BITS: + switch (em->sizety) + { + case 0: em->moid = M_BITS; break; + case 1: em->moid = M_LONG_BITS; break; + case 2: em->moid = M_LONG_LONG_BITS; break; + case -1: em->moid = M_SHORT_BITS; break; + case -2: em->moid = M_SHORT_SHORT_BITS; break; + default: + gcc_unreachable (); + } + break; + case GA68_MODE_BYTES: + switch (em->sizety) + { + case 0: em->moid = M_BYTES; break; + case 1: em->moid = M_LONG_BYTES; break; + default: + gcc_unreachable (); + } + break; + case GA68_MODE_REAL: + switch (em->sizety) + { + case 0: em->moid = M_REAL; break; + case 1: em->moid = M_LONG_REAL; break; + case 2: em->moid = M_LONG_LONG_REAL; break; + default: + gcc_unreachable (); + } + break; + case GA68_MODE_CMPL: + switch (em->sizety) + { + case 0: em->moid = M_COMPLEX; break; + case 1: em->moid = M_LONG_COMPLEX; break; + case 2: em->moid = M_LONG_LONG_COMPLEX; break; + default: + gcc_unreachable (); + } + break; + case GA68_MODE_NAME: + case GA68_MODE_FLEX: + /* For recursive declarations. */ + em->moid = a68_create_mode (em->kind == GA68_MODE_NAME ? REF_SYMBOL : FLEX_SYMBOL, + 0, NO_NODE, M_ERROR, NO_PACK); + sub = complete_encoded_mode (encoded_modes, em->data.name.sub_offset); + if (sub == NO_MOID) + { + /* Free em->moid */ + return NO_MOID; + } + SUB (em->moid) = sub; + break; + case GA68_MODE_ROW: + /* XXX how to convey actual bounds. */ + /* For recursive declarations. */ + em->moid = a68_create_mode (ROW_SYMBOL, 0, NO_NODE, M_ERROR, NO_PACK); + sub = complete_encoded_mode (encoded_modes, em->data.row.sub_offset); + if (sub == NO_MOID) + { + /* Free em->moid */ + return NO_MOID; + } + SUB (em->moid) = sub; + DIM (em->moid) = em->data.row.ndims; + break; + case GA68_MODE_STRUCT: + /* For recursive declarations. */ + em->moid = a68_create_mode (STRUCT_SYMBOL, 0, NO_NODE, NO_MOID, NO_PACK); + pack = NO_PACK; + for (uint16_t i = 0; i < em->data.sct.nfields; i++) + { + /* Note we have to do this from last field to first field, because + a68_add_mode_to_pack prepends to the list. */ + uint16_t index = em->data.sct.nfields - 1 - i; + char *field_name = em->data.sct.fields[index].name; + MOID_T *field_moid = complete_encoded_mode (encoded_modes, + em->data.sct.fields[index].mode_offset); + if (field_moid == NO_MOID) + { + /* XXX free em->moid */ + em->moid = NO_MOID; + return NO_MOID; + } + (void) a68_add_mode_to_pack (&pack, field_moid, field_name, NO_NODE); + } + DIM (em->moid) = a68_count_pack_members (pack); + PACK (em->moid) = pack; + break; + case GA68_MODE_UNION: + /* For recursive declarations. */ + em->moid = a68_create_mode (UNION_SYMBOL, 0, NO_NODE, NO_MOID, NO_PACK); + pack = NO_PACK; + for (uint8_t i = 0; i < em->data.union_.nmodes; i++) + { + /* Union alternatives are internally stored in reverse order in the + pack. */ + uint16_t index = i; + MOID_T *united_moid = complete_encoded_mode (encoded_modes, + em->data.union_.modes[index]); + if (united_moid == NO_MOID) + { + /* XXX free em->moid */ + em->moid = NO_MOID; + return NO_MOID; + } + (void) a68_add_mode_to_pack (&pack, united_moid, NO_TEXT, NO_NODE); + } + DIM (em->moid) = a68_count_pack_members (pack); + PACK (em->moid) = pack; + break; + case GA68_MODE_PROC: + /* For recursive declarations. */ + em->moid = a68_create_mode (PROC_SYMBOL, 0, NO_NODE, NO_MOID, NO_PACK); + pack = NO_PACK; + for (uint8_t i = 0; i < em->data.proc.nargs; i++) + { + /* Note we have to do this from last argument mode to first argument + mode, because a68_add_mode_to_pack prepends to the list. */ + uint16_t index = em->data.proc.nargs - 1 - i; + char *arg_name = em->data.proc.args[index].arg_name; + MOID_T *arg_moid = complete_encoded_mode (encoded_modes, + em->data.proc.args[index].arg_mode_offset); + if (arg_moid == NO_MOID) + { + /* XXX free em->moid */ + em->moid = NO_MOID; + return NO_MOID; + } + (void) a68_add_mode_to_pack (&pack, arg_moid, arg_name, NO_NODE); + } + SUB (em->moid) = complete_encoded_mode (encoded_modes, + em->data.proc.ret_mode_offset); + if (SUB (em->moid) == NO_MOID) + { + /* Free em->moid */ + em->moid = NO_MOID; + return NO_MOID; + } + DIM (em->moid) = a68_count_pack_members (pack); + PACK (em->moid) = pack; + break; + default: + gcc_unreachable (); + } + + return em->moid; +} + +/* Dump the contents of an encoded_mode, for debugging purposes. */ + +ATTRIBUTE_UNUSED static void +dump_encoded_mode (struct encoded_mode *em) +{ + printf ("[%" PRIu64 "] kind: %" PRIu8, em->offset, em->kind); + switch (em->kind) + { + case GA68_MODE_VOID: + printf (" void\n"); + break; + case GA68_MODE_CHAR: + printf (" char\n"); + break; + case GA68_MODE_BOOL: + printf (" bool\n"); + break; + case GA68_MODE_STRING: + printf (" basic\n"); + break; + case GA68_MODE_NAME: + printf (" name\n"); + printf (" sub: %" PRIu64 "\n", em->data.name.sub_offset); + break; + case GA68_MODE_STRUCT: + printf (" struct\n"); + printf (" nfields: %" PRIu16 "\n", em->data.sct.nfields); + for (uint16_t i = 0; i < em->data.sct.nfields; i++) + printf (" %s : [%" PRIu64 "]\n", + em->data.sct.fields[i].name, em->data.sct.fields[i].mode_offset); + break; + case GA68_MODE_FLEX: + printf (" flex\n"); + printf (" sub: %" PRIu64 "\n", em->data.name.sub_offset); + break; + case GA68_MODE_UNION: + printf (" union\n"); + printf (" nmodes: %" PRIu8 "\n", em->data.union_.nmodes); + printf (" "); + for (uint8_t i = 0; i < em->data.union_.nmodes; i++) + printf (" [%" PRIu64 "]", em->data.union_.modes[i]); + printf ("\n"); + break; + case GA68_MODE_PROC: + printf (" proc\n"); + printf (" retmode: [%" PRIu64 "]\n", em->data.proc.ret_mode_offset); + printf (" nargs: %" PRIu8 "\n", em->data.proc.nargs); + for (uint8_t i = 0; i < em->data.proc.nargs; i++) + printf (" %s : [%" PRIu64 "]\n", + em->data.proc.args[i].arg_name, + em->data.proc.args[i].arg_mode_offset); + break; + case GA68_MODE_ROW: + printf (" row\n"); + printf (" ndims: %" PRIu8 "\n", em->data.row.ndims); + for (uint8_t i = 0; i < em->data.row.ndims; i++) + { + printf (" lb: %" PRIu64 "\n", em->data.row.triplets[i].lb); + printf (" ub: %" PRIu64 "\n", em->data.row.triplets[i].ub); + } + printf (" sub: [%" PRIu64 "]\n", em->data.row.sub_offset); + break; + default: + break; + } +} + +/* Substitute any reference to mode M in T to R. */ + +static void +a68_replace_submode (MOID_T *t, MOID_T *m, MOID_T *r) +{ + if (SUB (t) == m) + SUB (t) = r; + + for (PACK_T *p = PACK (t); p != NO_PACK; FORWARD (p)) + { + if (MOID (p) == m) + MOID (p) = r; + } +} + +/* Substitute mode M with mode R in all modes in MODES_LIST. + The entry for M in MODES_LIST is set to NO_MOID. */ + +static void +a68_replace_equivalent_mode (vec *mode_list, + MOID_T *m, MOID_T *r) +{ + for (size_t i = 0; i < mode_list->length (); ++i) + { + if ((*mode_list)[i] == m) + (*mode_list)[i] = NO_MOID; + else if ((*mode_list)[i] != NO_MOID) + a68_replace_submode ((*mode_list)[i], m, r); + } +} + +/* Decode a modes table at DATA + POS. */ + +static bool +a68_decode_modes (MOIF_T *moif, encoded_modes_map_t &encoded_modes, + const char *data, size_t size, size_t pos, + size_t *ppos, const char **errstr) +{ + bool siga; + uint8_t kind; + uint64_t mode_table_size, mode_table_end; + + /* Get the size of the modes table. */ + DOFFSET (mode_table_size); + mode_table_end = pos + mode_table_size; + + /* Decode all the mode entries and fill in encoded_modes. */ + while (pos < mode_table_end) + { + int8_t sizety; + uint8_t ndims, nmodes, nargs; + uint16_t nfields; + uint64_t mode_offset = pos; + uint64_t sub, ret_mode_offset; + struct encoded_mode *encoded_mode; + + DUINT8 (kind); + encoded_mode = (struct encoded_mode *) xmalloc (sizeof (struct encoded_mode)); + encoded_mode->moid = NO_MOID; + encoded_mode->offset = mode_offset; + encoded_mode->kind = kind; + encoded_mode->sizety = 0; + switch (kind) + { + case GA68_MODE_VOID: + case GA68_MODE_CHAR: + case GA68_MODE_BOOL: + case GA68_MODE_STRING: + break; + case GA68_MODE_INT: + case GA68_MODE_REAL: + case GA68_MODE_BITS: + case GA68_MODE_BYTES: + case GA68_MODE_CMPL: + DINT8 (sizety); + encoded_mode->sizety = sizety; + break; + case GA68_MODE_NAME: + DOFFSET (sub); + encoded_mode->data.name.sub_offset = sub; + break; + case GA68_MODE_FLEX: + DOFFSET (sub); + encoded_mode->data.flex.sub_offset = sub; + break; + case GA68_MODE_ROW: + DUINT8 (ndims); + encoded_mode->data.row.triplets + = (struct encoded_triplet *) xmalloc (sizeof (struct encoded_triplet) * ndims); + for (uint8_t i = 0; i < ndims; i++) + { + uint64_t lb, ub; + DOFFSET (lb); + DOFFSET (ub); + encoded_mode->data.row.triplets[i].lb = lb; + encoded_mode->data.row.triplets[i].ub = ub; + } + DOFFSET (sub); + encoded_mode->data.row.ndims = ndims; + encoded_mode->data.row.sub_offset = sub; + break; + case GA68_MODE_UNION: + DUINT16 (nmodes); + encoded_mode->data.union_.nmodes = nmodes; + encoded_mode->data.union_.modes + = (uint64_t *) xmalloc (sizeof (uint64_t) * nmodes); + for (uint8_t i = 0; i < nmodes; i++) + { + uint64_t mode; + DOFFSET (mode); + encoded_mode->data.union_.modes[i] = mode; + } + break; + case GA68_MODE_PROC: + DOFFSET (ret_mode_offset); + DUINT8 (nargs); + encoded_mode->data.proc.ret_mode_offset = ret_mode_offset; + encoded_mode->data.proc.nargs = nargs; + encoded_mode->data.proc.args + = (struct encoded_arg *) xmalloc (sizeof (struct encoded_arg) * nargs); + for (uint8_t i = 0; i < nargs; i++) + { + uint64_t arg_mode_offset; + char *arg_name; + DOFFSET (arg_mode_offset); + DSTR (arg_name); + encoded_mode->data.proc.args[i].arg_mode_offset = arg_mode_offset; + encoded_mode->data.proc.args[i].arg_name = arg_name; + } + break; + case GA68_MODE_STRUCT: + DUINT16 (nfields); + encoded_mode->data.sct.nfields = nfields; + encoded_mode->data.sct.fields + = (struct encoded_field *) xmalloc (sizeof (struct encoded_field) * nfields); + for (uint16_t i = 0; i < nfields; i++) + { + uint64_t mode_offset; + char *field_name; + DOFFSET (mode_offset); + DSTR (field_name); + encoded_mode->data.sct.fields[i].mode_offset = mode_offset; + encoded_mode->data.sct.fields[i].name = field_name; + } + break; + case GA68_MODE_UNKNOWN: + default: + *errstr = "invalid kind in mode"; + goto decode_error; + break; + } + + encoded_modes.put (mode_offset, encoded_mode); + } + + /* Sanity check. */ + if (pos != mode_table_end) + { + *errstr = "invalid mode table size"; + goto decode_error; + } + + /* Complete all encoded modes. + This operation must conform a transitive closure. */ + siga = true; + while (siga) + { + siga = false; + for (auto entry : encoded_modes) + { + uint64_t offset = entry.first; + struct encoded_mode *em = entry.second; + + if (em->moid == NO_MOID + && complete_encoded_mode (encoded_modes, offset) != NO_MOID) + siga = true; + } + } + + /* At this point all the encoded modes are complete and they are all + associated with moids. Put them in the moif. */ + for (auto entry : encoded_modes) + { + struct encoded_mode *em = entry.second; + vec_safe_push (MODES (moif), em->moid); + } + + /* Next step is to see if equivalent modes the any of the modes in the moif + DIM already exist in the compiler's mode list. In that case, replace the + DIM moif's mode with the existing mode anywhere in the moif. */ + for (MOID_T *m : MODES (moif)) + { + MOID_T *r = a68_search_equivalent_mode (m); + if (r != NO_MOID) + { + a68_replace_equivalent_mode (MODES (moif), m, r); + + /* Update encoded_modes to reflect the replacement. */ + for (auto entry : encoded_modes) + { + struct encoded_mode *em = entry.second; + if (em->moid == m) + em->moid = r; + } + } + } + + *errstr = NULL; + *ppos = pos; + return true; + decode_error: + if (*errstr == NULL) + *errstr = "error decoding mode"; + return false; +} + +/* Decode an extracts table at DATA + POS. */ + +static bool +a68_decode_extracts (MOIF_T *moif, encoded_modes_map_t &encoded_modes, + const char *data, size_t size, size_t pos, + size_t *ppos, const char **errstr) +{ + uint64_t extracts_table_size, extracts_table_end; + + /* Get the size of the extracts table. */ + DOFFSET (extracts_table_size); + extracts_table_end = pos + extracts_table_size; + + /* Decode all the extracts entries, adding them to MOIF as we go. */ + while (pos < extracts_table_end) + { + uint8_t marker, prio, variable, in_proc; + uint64_t extract_size, extract_end, mode_offset; + uint64_t mdextra_size; + char *name; + + EXTRACT_T *e = (EXTRACT_T *) ggc_cleared_alloc (); + + DOFFSET (extract_size); + extract_end = pos + extract_size; + + DUINT8 (marker); + switch (marker) + { + case GA68_EXTRACT_MODU: + DSTR (name); + DOFFSET (mdextra_size); + if (mdextra_size != 0) + { + *errstr = "non-empty mdextra in module extract"; + goto decode_error; + } + EXTRACT_KIND (e) = GA68_EXTRACT_MODU; + EXTRACT_SYMBOL (e) = ggc_strdup (name); + EXTRACT_MODE (e) = NO_MOID; + EXTRACT_PRIO (e) = 0; + EXTRACT_VARIABLE (e) = false; + EXTRACT_IN_PROC (e) = false; + vec_safe_push (MODULES (moif), e); + break; + case GA68_EXTRACT_IDEN: + DSTR (name); + DOFFSET (mode_offset); + DOFFSET (mdextra_size); + if (mdextra_size != 2) + { + *errstr = "mdextra size should be 2 in iden extract"; + goto decode_error; + } + DUINT8 (variable); + DUINT8 (in_proc); + EXTRACT_KIND (e) = GA68_EXTRACT_IDEN; + EXTRACT_SYMBOL (e) = ggc_strdup (name); + EXTRACT_MODE (e) = (*(encoded_modes.get (mode_offset)))->moid; + EXTRACT_PRIO (e) = 0; + EXTRACT_VARIABLE (e) = variable; + EXTRACT_IN_PROC (e) = in_proc; + vec_safe_push (IDENTIFIERS (moif), e); + break; + case GA68_EXTRACT_MODE: + DSTR (name); + DOFFSET (mode_offset); + DOFFSET (mdextra_size); + if (mdextra_size != 0) + { + *errstr = "non-empty mdextra in indicant extract"; + goto decode_error; + } + EXTRACT_KIND (e) = GA68_EXTRACT_MODE; + EXTRACT_SYMBOL (e) = ggc_strdup (name); + EXTRACT_MODE (e) = (*(encoded_modes.get (mode_offset)))->moid; + EXTRACT_PRIO (e) = 0; + EXTRACT_VARIABLE (e) = false; + EXTRACT_IN_PROC (e) = false; + vec_safe_push (INDICANTS (moif), e); + break; + case GA68_EXTRACT_PRIO: + DSTR (name); + DUINT8 (prio); + DOFFSET (mdextra_size); + if (mdextra_size != 0) + { + *errstr = "non-empty mdextra in prio extract"; + goto decode_error; + } + EXTRACT_KIND (e) = GA68_EXTRACT_PRIO; + EXTRACT_SYMBOL (e) = ggc_strdup (name); + EXTRACT_MODE (e) = NO_MOID; + EXTRACT_PRIO (e) = prio; + EXTRACT_VARIABLE (e) = false; + EXTRACT_IN_PROC (e) = false; + vec_safe_push (PRIOS (moif), e); + break; + case GA68_EXTRACT_OPER: + DSTR (name); + DOFFSET (mode_offset); + DOFFSET (mdextra_size); + if (mdextra_size != 2) + { + *errstr = "mdextra size should be 2 in oper extract"; + goto decode_error; + } + DUINT8 (variable); + DUINT8 (in_proc); + EXTRACT_KIND (e) = GA68_EXTRACT_OPER; + EXTRACT_SYMBOL (e) = ggc_strdup (name); + EXTRACT_MODE (e) = (*(encoded_modes.get (mode_offset)))->moid; + EXTRACT_PRIO (e) = 0; + EXTRACT_VARIABLE (e) = variable; + EXTRACT_IN_PROC (e) = in_proc; + vec_safe_push (OPERATORS (moif), e); + break; + default: + *errstr = "invalid marker in extract"; + goto decode_error; + break; + } + + /* Sanity check. */ + if (pos != extract_end) + { + *errstr = "invalid extract size"; + goto decode_error; + } + } + + /* Sanity check. */ + if (pos != extracts_table_end) + { + *errstr = "invalid extracts table size"; + goto decode_error; + } + + *errstr = NULL; + *ppos = pos; + return true; + decode_error: + if (*errstr == NULL) + *errstr = "error decoding extract"; + return false; +} + +/* Decode the given exports data into a moif. If there is a decoding error + then put an explicative mssage in *ERRSTR and return NULL. */ + +static MOIF_T * +a68_decode_moif (const char *data, size_t size, const char **errstr) +{ + size_t pos = 0; + MOIF_T *moif = a68_moif_new (NULL /* name */); + encoded_modes_map_t encoded_modes (16); + + uint8_t magic1, magic2; + uint16_t version; + char *name, *prelude, *postlude; + + DUINT8 (magic1); + DUINT8 (magic2); + if (magic1 != A68_EXPORT_MAGIC1 || magic2 != A68_EXPORT_MAGIC2) + { + *errstr = "invalid magic number"; + goto decode_error; + } + + DUINT16 (version); + if (version != 1) + { + *errstr = "invalid a68 exports version"; + goto decode_error; + } + + DSTR (name); + DSTR (prelude); + DSTR (postlude); + NAME (moif) = name; + PRELUDE (moif) = prelude; + POSTLUDE (moif) = postlude; + + /* Decode the modes table. + This installs the resulting moids in MOIF. */ + if (!a68_decode_modes (moif, encoded_modes, data, size, pos, &pos, errstr)) + goto decode_error; + + /* Decode the extracts table. + This installs the resulting tags in MOIF. */ + if (!a68_decode_extracts (moif, encoded_modes, data, size, pos, &pos, errstr)) + goto decode_error; + + /* We don't need the encoded modes anymore. */ + for (auto entry : encoded_modes) + { + struct encoded_mode *em = entry.second; + encoded_mode_free (em); + } + + /* Got some juicy exports for youuuuuu... */ + return moif; + decode_error: + if (*errstr == NULL) + *errstr = "premature end of data"; + return NULL; +} + +/* Get a moif with the exports for module named MODULE. If no exports can be + found then return NULL. */ + +MOIF_T * +a68_open_packet (const char *module) +{ + /* Look in the modules location maps to see if there is an entry for MODULE. + If there is one, use the specified filename. Otherwise canonicalize the + module name to a file name. */ + char *filename; + const char **pfilename = A68_MODULE_FILES->get (module); + if (pfilename == NULL) + { + /* Turn the module indicant in MODULE to lower-case. */ + filename = (char *) alloca (strlen (module) + 1); + size_t i = 0; + for (; i < strlen (module); i++) + filename[i] = TOLOWER (module[i]); + filename[i] = '\0'; + } + else + { + size_t len = strlen (*pfilename) + 1; + filename = (char *) alloca (len); + memcpy (filename, *pfilename, len); + } + + /* Try to read exports data in a buffer. */ + char *exports_data; + size_t exports_data_size; + exports_data = a68_get_packet_exports (std::string (filename), + std::string ("."), + &exports_data_size); + if (exports_data == NULL) + return NULL; + + /* Got some data. Parse it into a moif. */ + const char *errstr = NULL; + MOIF_T *moif = a68_decode_moif (exports_data, exports_data_size, &errstr); + return moif; +} diff --git a/gcc/algol68/a68-lang.cc b/gcc/algol68/a68-lang.cc new file mode 100644 index 000000000000..8ba0259ce29d --- /dev/null +++ b/gcc/algol68/a68-lang.cc @@ -0,0 +1,755 @@ +/* Language-dependent hooks for Algol 68. + Copyright (C) 2025 Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "toplev.h" +#include "langhooks.h" +#include "langhooks-def.h" +#include "target.h" +#include "stringpool.h" +#include "debug.h" +#include "diagnostic.h" +#include "opts.h" +#include "machmode.h" +#include "stor-layout.h" /* For layout_type */ +#include "vec.h" + +#include "a68.h" + +/* Global state for the Algol 68 front end. */ + +A68_T a68_common; + +/* Types expected by gcc's garbage collector. + These types exist to allow language front-ends to + add extra information in gcc's parse tree data structure. */ + +struct GTY(()) lang_type +{ + MOID_T * moid; +}; + +struct GTY(()) lang_decl +{ + NODE_T * node; +}; + +/* Language-specific identifier information. This must include a + tree_identifier. */ +struct GTY(()) lang_identifier +{ + struct tree_identifier common; +}; + + +struct GTY(()) language_function +{ + int dummy; +}; + +/* The Algol68 frontend Type AST for GCC type NODE. */ +#define TYPE_LANG_FRONTEND(NODE) \ + (TYPE_LANG_SPECIFIC (NODE) \ + ? TYPE_LANG_SPECIFIC (NODE)->type : NULL) + +/* The resulting tree type. */ + +union GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"), + chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), " + "TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN " + "(&%h.generic)) : NULL"))) lang_tree_node +{ + union tree_node GTY((tag ("0"), + desc ("tree_node_structure (&%h)"))) generic; + struct lang_identifier GTY ((tag ("1"))) identifier; +}; + +/* Allocate and return a lang specific structure for type tree nodes. */ + +struct lang_type * +a68_build_lang_type (MOID_T *moid) +{ + tree ctype = CTYPE (moid); + struct lang_type *lt = ctype ? TYPE_LANG_SPECIFIC (ctype) : NULL; + + if (lt == NULL) + lt = (struct lang_type *) ggc_cleared_alloc (); + if (lt->moid == NULL) + lt->moid = moid; + return lt; +} + +/* Allocate and return a lang specific structure for decl tree nodes. */ + +struct lang_decl * +a68_build_lang_decl (NODE_T *node) +{ + tree cdecl = CDECL (node); + struct lang_decl *ld = cdecl ? DECL_LANG_SPECIFIC (cdecl) : NULL; + + if (ld == NULL) + ld = (struct lang_decl *) ggc_cleared_alloc (); + if (ld->node == NULL) + ld->node = node; + return ld; +} + +/* Get the front-end mode associated with the given TYPE. If no mode is + associated then this function returns NO_MODE. */ + +MOID_T * +a68_type_moid (tree type) +{ + gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL + && TYPE_LANG_SPECIFIC (type)->moid != NO_MOID); + return TYPE_LANG_SPECIFIC (type)->moid; +} + +/* Build the type trees in a68_global_trees. */ + +static void +a68_build_a68_type_nodes (void) +{ + /* VOID */ + a68_void_type = make_node (RECORD_TYPE); + TYPE_NAME (a68_void_type) = get_identifier ("void%"); + TYPE_FIELDS (a68_void_type) = NULL_TREE; + TYPE_READONLY (a68_void_type) = 1; + TYPE_CXX_ODR_P (a68_void_type) = 1; + layout_type (a68_void_type); + + /* BOOL */ + a68_bool_type = boolean_type_node; + + /* CHAR */ + a68_char_type = uint32_type_node; + + /* SHORT SHORT INT + SHORT INT + INT */ + a68_short_short_int_type = signed_char_type_node; + a68_short_int_type = short_integer_type_node; + a68_int_type = integer_type_node; + + /* LONG INT */ + if (int_size_in_bytes (long_integer_type_node) + > int_size_in_bytes (a68_int_type)) + a68_long_int_type = long_integer_type_node; + else if (int_size_in_bytes (long_long_integer_type_node) + > int_size_in_bytes (a68_int_type)) + a68_long_int_type = long_long_integer_type_node; + else + a68_long_int_type = a68_int_type; + + /* LONG LONG INT */ + if (int_size_in_bytes (long_integer_type_node) + > int_size_in_bytes (a68_long_int_type)) + a68_long_long_int_type = long_integer_type_node; + else if (int_size_in_bytes (long_long_integer_type_node) + > int_size_in_bytes (a68_long_int_type)) + a68_long_long_int_type = long_long_integer_type_node; + else + a68_long_long_int_type = a68_long_int_type; + + /* SHORT SHORT BITS + SHORT BITS + BITS */ + a68_short_short_bits_type = unsigned_char_type_node; + a68_short_bits_type = short_unsigned_type_node; + a68_bits_type = unsigned_type_node; + + /* LONG BITS */ + if (int_size_in_bytes (long_unsigned_type_node) + > int_size_in_bytes (a68_bits_type)) + a68_long_bits_type = long_unsigned_type_node; + else if (int_size_in_bytes (long_long_unsigned_type_node) + > int_size_in_bytes (a68_bits_type)) + a68_long_bits_type = long_long_unsigned_type_node; + else + a68_long_bits_type = a68_bits_type; + + /* LONG LONG BITS */ + if (int_size_in_bytes (long_unsigned_type_node) + > int_size_in_bytes (a68_long_bits_type)) + a68_long_long_bits_type = long_unsigned_type_node; + else if (int_size_in_bytes (long_long_unsigned_type_node) + > int_size_in_bytes (a68_long_bits_type)) + a68_long_long_bits_type = long_long_unsigned_type_node; + else + a68_long_long_bits_type = a68_long_bits_type; + + /* BYTES + LONG BYTES */ + a68_bytes_type = unsigned_type_node; + a68_long_bytes_type = long_unsigned_type_node; + + /* REAL + LONG REAL + LONG LONG REAL */ + a68_real_type = float_type_node; + a68_long_real_type = double_type_node; + a68_long_long_real_type = long_double_type_node; +} + +/* Language hooks data structures. This is the main interface between + the GCC front-end and the GCC middle-end/back-end. A list of + language hooks can be found in langhooks.h. */ + +#undef LANG_HOOKS_NAME +#define LANG_HOOKS_NAME "GNU Algol 68" + +/* LANG_HOOKS_INIT gets called to initialize the front-end. + Invoked after option handling. */ + +static bool +a68_init (void) +{ + build_common_tree_nodes (false); + targetm.init_builtins (); + a68_build_a68_type_nodes (); + build_common_builtin_nodes (); + a68_install_builtins (); + + /* Initialize binding contexts. */ + a68_init_ranges (); + + /* Set the type of size_t. */ + if (TYPE_MODE (long_unsigned_type_node) == ptr_mode) + size_type_node = long_unsigned_type_node; + else if (TYPE_MODE (long_long_unsigned_type_node) == ptr_mode) + size_type_node = long_long_unsigned_type_node; + else + size_type_node = long_unsigned_type_node; + + /* Create an empty module files map. */ + A68_MODULE_FILES = hash_map::create_ggc (16); + A68_MODULE_FILES->empty (); + + return true; +} + +#undef LANG_HOOKS_INIT +#define LANG_HOOKS_INIT a68_init + +/* LANG_HOOKS_OPTION_LANG_MASK */ + +static unsigned int +a68_option_lang_mask (void) +{ + return CL_Algol68; +} + +#undef LANG_HOOKS_OPTION_LANG_MASK +#define LANG_HOOKS_OPTION_LANG_MASK a68_option_lang_mask + + +/* Return a data type that has machine mode MODE. If the mode is an + integer, then UNSIGNEDP selects between signed and unsigned types. */ + +static tree +a68_type_for_mode (enum machine_mode mode, int unsignedp) +{ + if (mode == QImode) + return unsignedp ? a68_short_short_bits_type :a68_short_short_int_type; + + if (mode == HImode) + return unsignedp ? a68_short_bits_type : a68_short_int_type; + + if (mode == SImode) + return unsignedp ? a68_bits_type : a68_int_type; + + if (mode == DImode) + return unsignedp ? a68_long_bits_type : a68_long_int_type; + + if (mode == TYPE_MODE (a68_long_long_bits_type)) + return unsignedp ? a68_long_long_bits_type : a68_long_long_int_type; + + if (mode == TYPE_MODE (a68_real_type)) + return a68_real_type; + + if (mode == TYPE_MODE (a68_long_real_type)) + return a68_long_real_type; + + if (mode == TYPE_MODE (a68_long_long_real_type)) + return a68_long_long_real_type; + + if (mode == TYPE_MODE (build_pointer_type (char_type_node))) + return build_pointer_type (char_type_node); + + if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) + return build_pointer_type (integer_type_node); + + for (int i = 0; i < NUM_INT_N_ENTS; i ++) + { + if (int_n_enabled_p[i] && mode == int_n_data[i].m) + { + if (unsignedp) + return int_n_trees[i].unsigned_type; + else + return int_n_trees[i].signed_type; + } + } + + return 0; +} + +#undef LANG_HOOKS_TYPE_FOR_MODE +#define LANG_HOOKS_TYPE_FOR_MODE a68_type_for_mode + + +/* Return an integer type with BITS bits of precision, + that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ + +static tree +a68_type_for_size (unsigned int bits, int unsignedp) +{ + if (unsignedp) + { + if (bits <= TYPE_PRECISION (a68_short_short_bits_type)) + return a68_short_short_bits_type; + if (bits <= TYPE_PRECISION (a68_short_bits_type)) + return a68_short_bits_type; + if (bits <= TYPE_PRECISION (a68_bits_type)) + return a68_bits_type; + if (bits <= TYPE_PRECISION (a68_long_bits_type)) + return a68_long_bits_type; + if (bits <= TYPE_PRECISION (a68_long_long_bits_type)) + return a68_long_long_bits_type; + } + else + { + if (bits <= TYPE_PRECISION (a68_short_short_int_type)) + return a68_short_short_int_type; + if (bits <= TYPE_PRECISION (a68_short_int_type)) + return a68_short_int_type; + if (bits <= TYPE_PRECISION (a68_int_type)) + return a68_int_type; + if (bits <= TYPE_PRECISION (a68_long_int_type)) + return a68_long_int_type; + if (bits <= TYPE_PRECISION (a68_long_long_int_type)) + return a68_long_long_int_type; + } + + for (int i = 0; i < NUM_INT_N_ENTS; ++i) + { + if (int_n_enabled_p[i] && bits == int_n_data[i].bitsize) + { + if (unsignedp) + return int_n_trees[i].unsigned_type; + else + return int_n_trees[i].signed_type; + } + } + + return 0; +} + +#undef LANG_HOOKS_TYPE_FOR_SIZE +#define LANG_HOOKS_TYPE_FOR_SIZE a68_type_for_size + + +/* Implements the lang_hooks.decls.global_bindings_p routine for Algol 68. + Return true if we are in the global binding level. */ + +static bool +a68_global_bindings_p (void) +{ + return (current_function_decl == NULL_TREE); +} + +#undef LANG_HOOKS_GLOBAL_BINDINGS_P +#define LANG_HOOKS_GLOBAL_BINDINGS_P a68_global_bindings_p + +/* Implements the lang_hooks.decls.getdecls routine. + Return the list of declarations of the current level. */ + +static tree +a68_getdecls (void) +{ + return a68_range_names (); +} + +#undef LANG_HOOKS_GETDECLS +#define LANG_HOOKS_GETDECLS a68_getdecls + +/* Return A68_GLOBAL_CONTEXT, but create it first if need be. */ + +static tree +get_global_context (void) +{ + if (!A68_GLOBAL_CONTEXT) + { + A68_GLOBAL_CONTEXT = build_translation_unit_decl (NULL_TREE); + debug_hooks->register_main_translation_unit (A68_GLOBAL_CONTEXT); + } + + return A68_GLOBAL_CONTEXT; +} + +/* Implements the lang_hooks.decls.pushdecl routine. + Record DECL as belonging to the current lexical scope. */ + +static tree +pushdecl (tree decl) +{ + /* Set the context of the decl. If current_function_decl did not help in + determining the context, use global scope. */ + if (!DECL_CONTEXT (decl)) + { + if (current_function_decl) + DECL_CONTEXT (decl) = current_function_decl; + else + DECL_CONTEXT (decl) = get_global_context (); + } + + /* Put decls on list in reverse order. */ + if (TREE_STATIC (decl) || a68_global_bindings_p ()) + vec_safe_push (A68_GLOBAL_DECLARATIONS, decl); + else + a68_add_decl (decl); + + return decl; +} + +#undef LANG_HOOKS_PUSHDECL +#define LANG_HOOKS_PUSHDECL pushdecl + +/* Implements the lang_hooks.init_options routine for language Algol 68. This + initializes the global state for the frontend before calling the option + handlers. */ + +static void +a68_init_options (unsigned int argc ATTRIBUTE_UNUSED, + cl_decoded_option *decoded_options ATTRIBUTE_UNUSED) +{ + /* Nothing to do here for now. */ +} + +#undef LANG_HOOKS_INIT_OPTIONS +#define LANG_HOOKS_INIT_OPTIONS a68_init_options + + +/* Handle -fcheck= option. */ + +static void +a68_handle_runtime_check_option (const char *arg) +{ + int pos = 0; + + while (*arg) + { + /* We accept entries like -fcheck=nil,,bounds and -fcheck=,all. */ + while (*arg == ',') + arg++; + + while (arg[pos] && arg[pos] != ',') + pos++; + + /* Process an option flag in the -fcheck= specification. + + "all" means enable all run-time checks. + "none" means disable all run-time checks. + + Options are processed from left to right, with increase + precedende. */ + + if (strncmp (arg, "all", pos) == 0) + { + OPTION_NIL_CHECKING (&A68_JOB) = true; + OPTION_BOUNDS_CHECKING (&A68_JOB) = true; + } + else if (strncmp (arg, "none", pos) == 0) + { + OPTION_NIL_CHECKING (&A68_JOB) = false; + OPTION_BOUNDS_CHECKING (&A68_JOB) = false; + } + else if (strncmp (arg, "nil", pos) == 0) + OPTION_NIL_CHECKING (&A68_JOB) = true; + else if (strncmp (arg, "no-nil", pos) == 0) + OPTION_NIL_CHECKING (&A68_JOB) = false; + else if (strncmp (arg, "bounds", pos) == 0) + OPTION_BOUNDS_CHECKING (&A68_JOB) = true; + else if (strncmp (arg, "no-bounds", pos) == 0) + OPTION_BOUNDS_CHECKING (&A68_JOB) = false; + else + fatal_error (UNKNOWN_LOCATION, + "Argument to %<-fcheck%> is not valid: %s", arg); + + /* Process next flag. */ + arg += pos; + pos = 0; + } +} + +/* Handle Algol 68 specific options. Return false if we didn't do + anything. */ + +static bool +a68_handle_option (size_t scode, + const char *arg, + HOST_WIDE_INT value ATTRIBUTE_UNUSED, + int kind ATTRIBUTE_UNUSED, + location_t loc ATTRIBUTE_UNUSED, + const cl_option_handlers *handlers ATTRIBUTE_UNUSED) +{ + opt_code code = (opt_code) scode; + + switch (code) + { + case OPT_std_algol68: + OPTION_STRICT (&A68_JOB) = 1; + break; + case OPT_fbrackets: + OPTION_BRACKETS (&A68_JOB) = flag_brackets; + break; + case OPT_fassert: + OPTION_ASSERT (&A68_JOB) = flag_assert; + break; + case OPT_fcheck_: + a68_handle_runtime_check_option (arg); + break; + case OPT_fstropping_: + if (value == 0) + OPTION_STROPPING (&A68_JOB) = UPPER_STROPPING; + else + OPTION_STROPPING (&A68_JOB) = SUPPER_STROPPING; + break; + case OPT_I: + vec_safe_push (A68_INCLUDE_PATHS, arg); + vec_safe_push (A68_IMPORT_PATHS, arg); + break; + case OPT_L: + vec_safe_push (A68_IMPORT_PATHS, arg); + break; + default: + break; + } + + return true; +} + +#undef LANG_HOOKS_HANDLE_OPTION +#define LANG_HOOKS_HANDLE_OPTION a68_handle_option + +/* LANG_HOOKS_INIT_OPTIONS_STRUCT is called so the front-end can + change some default values in the compiler's option structure. */ + +static void +a68_init_options_struct (struct gcc_options *opts) +{ + /* Operations are always wrapping in algol68, even on signed + integer. */ + opts->x_flag_wrapv = 1; + /* Do not warn for voiding by default. */ + opts->x_warn_algol68_voiding = 0; + /* Do not warn for usage of Algol 68 extensions by default. */ + opts->x_warn_algol68_extensions = 0; + /* Do not warn for potential scope violations by default. */ + opts->x_warn_algol68_scope = 0; + /* Do not warn for hidden declarations by default. */ + opts->x_warn_algol68_hidden_declarations = 0; + /* Enable assertions by default. */ + OPTION_ASSERT (&A68_JOB) = 1; + /* Disable run-time nil checking by default. */ + OPTION_NIL_CHECKING (&A68_JOB) = 0; + /* Enable run-time bounds checking by default. */ + OPTION_BOUNDS_CHECKING (&A68_JOB) = 1; + opts->x_flag_assert = 1; + /* Allow GNU extensions by default. */ + OPTION_STRICT (&A68_JOB) = 0; + /* The default stropping regime is SUPPER. */ + OPTION_STROPPING (&A68_JOB) = SUPPER_STROPPING; +} + +#undef LANG_HOOKS_INIT_OPTIONS_STRUCT +#define LANG_HOOKS_INIT_OPTIONS_STRUCT a68_init_options_struct + +/* Deal with any options that imply the turning on/off of features. FILENAME + is the main input file passed on the command line. */ + +static bool +a68_post_options (const char **filename ATTRIBUTE_UNUSED) +{ + /* -fbounds-check is equivalent to -fcheck=bounds */ + if (flag_bounds_check) + OPTION_BOUNDS_CHECKING (&A68_JOB) = true; + + return false; +} + +#undef LANG_HOOKS_POST_OPTIONS +#define LANG_HOOKS_POST_OPTIONS a68_post_options + +/* LANG_HOOKS_PARSE_FILE is called to parse the input files. + + The input file names are available in the global variables + in_fnames and num_in_fnames, and this function is required to + create a complete parse tree from them in a global var, then + return. */ + +MOIF_T *moif; + +static void +a68_parse_file (void) +{ + if (num_in_fnames != 1) + fatal_error (UNKNOWN_LOCATION, + "exactly one source file must be specified on the command line"); + + /* Run the Mailloux parser. */ + a68_parser (in_fnames[0]); + + if (ERROR_COUNT (&A68_JOB) > 0) + goto had_errors; + + /* Generate dumps if so requested. */ + if (flag_a68_dump_modes) + a68_dump_modes (TOP_MOID (&A68_JOB)); + if (flag_a68_dump_ast) + a68_dump_parse_tree (TOP_NODE (&A68_JOB)); + + /* Lower modes to GENERIC. */ + a68_lower_moids (TOP_MOID (&A68_JOB)); + /* Lower the particular program. */ + a68_lower_top_tree (TOP_NODE (&A68_JOB)); + + if (ERROR_COUNT (&A68_JOB) > 0) + goto had_errors; + + /* Emit exports information for any compiled module in this packet. Note + this must be done after the low pass. */ + a68_do_exports (TOP_NODE (&A68_JOB)); + + /* Process all file scopes in this compilation, and the external_scope, + through wrapup_global_declarations. */ + for (unsigned int i = 0; i < vec_safe_length (A68_GLOBAL_DECLARATIONS); i++) + { + tree decl = vec_safe_address (A68_GLOBAL_DECLARATIONS)[i]; + wrapup_global_declarations (&decl, 1); + } + + had_errors: + errorcount += ERROR_COUNT (&A68_JOB); +} + +#undef LANG_HOOKS_PARSE_FILE +#define LANG_HOOKS_PARSE_FILE a68_parse_file + +/* This hook is called for every GENERIC tree that gets gimplified. + Its purpose is to gimplify language specific trees. + + At the moment we are not supporting any Algol 68 specific tree, so + we just return FALSE. */ + +static int +a68_gimplify_expr (tree *expr_p ATTRIBUTE_UNUSED, + gimple_seq *pre_p ATTRIBUTE_UNUSED, + gimple_seq *post_p ATTRIBUTE_UNUSED) +{ + return false; +} + +#undef LANG_HOOKS_GIMPLIFY_EXPR +#define LANG_HOOKS_GIMPLIFY_EXPR a68_gimplify_expr + +/* This function shall return the printable name of the language. */ + +static const char * +a68_printable_name (tree decl, int kind ATTRIBUTE_UNUSED) +{ + tree decl_name = DECL_NAME (decl); + + if (decl_name == NULL_TREE) + return ""; + else + return IDENTIFIER_POINTER (decl_name); +} + +#undef LANG_HOOKS_DECL_PRINTABLE_NAME +#define LANG_HOOKS_DECL_PRINTABLE_NAME a68_printable_name + + +/* Return true if a warning should be given about option OPTION, which is for + the wrong language, false if it should be quietly ignored. */ + +static bool +a68_complain_wrong_lang_p (const struct cl_option *option ATTRIBUTE_UNUSED) +{ + return false; +} + +#undef LANG_HOOKS_COMPLAIN_WRONG_LANG_P +#define LANG_HOOKS_COMPLAIN_WRONG_LANG_P a68_complain_wrong_lang_p + +/* Create an expression whose value is that of EXPR, + converted to type TYPE. The TREE_TYPE of the value + is always TYPE. This function implements all reasonable + conversions; callers should filter out those that are + not permitted by the language being compiled. + + Note that this function is not used outside the front-end. This front-end + doesn't currently use it at all. */ + +tree convert (tree type ATTRIBUTE_UNUSED, + tree expr ATTRIBUTE_UNUSED) +{ + gcc_unreachable (); +} + +/* Implements the lang_hooks.types_compatible_p routine for Algol 68. + Compares two types for equivalence in Algol 68. + This routine should only return 1 if it is sure, even though the frontend + should have already ensured that all types are compatible before handing + over the parsed ASTs to the code generator. */ + +static int +a68_types_compatible_p (tree x, tree y) +{ + MOID_T *mode_x = a68_type_moid (x); + MOID_T *mode_y = a68_type_moid (y); + + if (mode_x != NO_MOID && mode_y != NO_MOID) + return a68_is_equal_modes (mode_x, mode_y, SAFE_DEFLEXING); + + return false; +} + +#undef LANG_HOOKS_TYPES_COMPATIBLE_P +#define LANG_HOOKS_TYPES_COMPATIBLE_P a68_types_compatible_p + +/* Get a value for the SARIF v2.1.0 "artifact.sourceLanguage" property. Algol + 68 is not yet listed in SARIF v2.1.0 Appendix J, but if/when it does, it + will likely use this string. */ + +const char * +a68_get_sarif_source_language (const char *) +{ + return "algol68"; +} + +#undef LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE +#define LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE a68_get_sarif_source_language + +/* Expands all LANG_HOOKS_x o GCC. */ +struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; + +#include "gt-algol68-a68-lang.h" +#include "gtype-algol68.h" diff --git a/gcc/algol68/a68-low-bits.cc b/gcc/algol68/a68-low-bits.cc new file mode 100644 index 000000000000..465969f9ade1 --- /dev/null +++ b/gcc/algol68/a68-low-bits.cc @@ -0,0 +1,297 @@ +/* Lowering routines for all things related to BITS values. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Return a tree with the yielind of SKIP for the given BITS mode. */ + +tree +a68_get_bits_skip_tree (MOID_T *m) +{ + tree type; + + if (m == M_BITS) + type = a68_bits_type; + else if (m == M_LONG_BITS) + type = a68_long_bits_type; + else if (m == M_LONG_LONG_BITS) + type = a68_long_long_bits_type; + else if (m == M_SHORT_BITS) + type = a68_short_bits_type; + else if (m == M_SHORT_SHORT_BITS) + type = a68_short_short_bits_type; + else + gcc_unreachable (); + + return build_int_cst (type, 0); +} + +/* Given a BITS type, compute the number of bits that fit in a value of that + type. The result is an INT. */ + +tree +a68_bits_width (tree type) +{ + return fold_convert (a68_int_type, TYPE_SIZE (type)); +} + +/* Given a BITS type, compute the maximum value that can be expressed with that + type. */ + +tree +a68_bits_maxbits (tree type) +{ + return fold_convert (type, TYPE_MAX_VALUE (type)); +} + +/* Given a SIZETY INT value VAL, compute and return a SIZETY BITS reflecting + its constituent bits. + + In strict Algol 68 the BIN of a negative value is BITS (SKIP). + + In GNU 68 the BIN of a negative value is the constituent bits of the two's + complement of the value. */ + +tree +a68_bits_bin (MOID_T *m, tree val) +{ + tree type = CTYPE (m); + + if (OPTION_STRICT (&A68_JOB)) + return a68_get_bits_skip_tree (m); + else + return fold_convert (type, val); +} + +/* Given a SIZETY BITS value BITS, compute and return the corresponding SIZETY + INT. + + In strict Algol 68 the ABS of a BITS value reflecting a bit pattern that + would correspond a negative integral value is INT (SKIP). + + In GNU 68 the ABS of a BITS value reflecting a bit pattern that would + correspond a negative integral value is that negative integral value. */ + +tree +a68_bits_abs (MOID_T *m, tree bits) +{ + tree type = CTYPE (m); + + if (OPTION_STRICT (&A68_JOB)) + { + tree integral_val = save_expr (fold_convert (type, bits)); + return fold_build3 (COND_EXPR, + type, + fold_build2 (LT_EXPR, type, integral_val, + build_int_cst (type, 0)), + a68_get_int_skip_tree (m), + integral_val); + } + else + return fold_convert (type, bits); +} + +/* Given a SIZETY BITS value BITS, shorten it into a SIZETY BITS whose tree + type is TYPE. */ + +tree +a68_bits_shorten (tree type, tree bits) +{ + /* This will truncate at the left, which is what is intended. */ + return fold_convert (type, bits); +} + +/* Given a SIZETY BITS value BITS, length it into a SIZETY BITS whose tree type + is TYPE. */ + +tree +a68_bits_leng (tree type, tree bits) +{ + /* This will add zeroes to the left, which is what is intended. */ + return fold_convert (type, bits); +} + +/* Given a SIZETY BITS value BITS, compute and return a new SIZETY BITS whose + bits are the logical negation of the bits of BITS. */ + +tree +a68_bits_not (tree bits) +{ + return fold_build1 (BIT_NOT_EXPR, TREE_TYPE (bits), bits); +} + +/* Given two SIZETY BITS values BITS1 and BITS2, compute and return a new + SIZETY BITS whose bits are the `and' of the bits of BITS1 and + BITS2. */ + +tree +a68_bits_and (tree bits1, tree bits2) +{ + return fold_build2 (BIT_AND_EXPR, TREE_TYPE (bits1), bits1, bits2); +} + +/* Given two SIZETY BITS values BITS1 and BITS2, compute and return a new + SIZETY BITS whose bits are the inclusive-or of the bits of BITS1 and + BITS2. */ + +tree +a68_bits_ior (tree bits1, tree bits2) +{ + return fold_build2 (BIT_IOR_EXPR, TREE_TYPE (bits1), bits1, bits2); +} + +/* Given two SIZETY BITS values BITS1 and BITS2, compute and return a new + SIZETY BITS whose bits are the exclusive-or of the bits of BITS1 and + BITS2. */ + +tree +a68_bits_xor (tree bits1, tree bits2) +{ + return fold_build2 (BIT_XOR_EXPR, TREE_TYPE (bits1), bits1, bits2); +} + +/* Given a position POS of mode INT and a BITS of mode SIZETY BITS, return a + BOOL reflecting the state of the bit occupying the position POS in BITS. + + If POS is out of range a run-time error is emitted. */ + +tree +a68_bits_elem (NODE_T *p, tree pos, tree bits) +{ + pos = save_expr (pos); + tree one = build_int_cst (TREE_TYPE (bits), 1); + + tree shift = fold_build2 (MINUS_EXPR, bitsizetype, + TYPE_SIZE (TREE_TYPE (bits)), + fold_convert (bitsizetype, pos)); + tree elem = fold_build2 (EQ_EXPR, + a68_bool_type, + fold_build2 (BIT_AND_EXPR, + TREE_TYPE (bits), + fold_build2 (RSHIFT_EXPR, + TREE_TYPE (bits), + bits, shift), + one), + one); + + /* Do bounds checking if requested. */ + if (OPTION_BOUNDS_CHECKING (&A68_JOB)) + { + unsigned int lineno = NUMBER (LINE (INFO (p))); + const char *filename_str = FILENAME (LINE (INFO (p))); + tree filename = build_string_literal (strlen (filename_str) + 1, + filename_str); + tree call = a68_build_libcall (A68_LIBCALL_BITSBOUNDSERROR, + void_type_node, 3, + filename, + build_int_cst (unsigned_type_node, lineno), + fold_convert (ssizetype, pos)); + tree check = fold_build2 (TRUTH_AND_EXPR, integer_type_node, + fold_build2 (GT_EXPR, integer_type_node, + pos, fold_convert (TREE_TYPE (pos), integer_zero_node)), + fold_build2 (LE_EXPR, integer_type_node, + fold_convert (bitsizetype, pos), + TYPE_SIZE (TREE_TYPE (bits)))); + + check = fold_build2_loc (a68_get_node_location (p), + TRUTH_ORIF_EXPR, + ssizetype, + check, + fold_build2 (COMPOUND_EXPR, a68_bool_type, + call, boolean_false_node)); + elem = fold_build2 (COMPOUND_EXPR, a68_bool_type, + check, elem); + } + + return elem; +} + +/* Given two SIZETY BITS values BITS1 and BITS2, return a BOOL value indicating + whether all the bits set in BITS1 are also set in BITS2. */ + +tree +a68_bits_subset (tree bits1, tree bits2) +{ + /* We compute this operation with `A | B == B' as specified by the Report */ + bits2 = save_expr (bits2); + return fold_build2 (EQ_EXPR, a68_bool_type, + fold_build2 (BIT_IOR_EXPR, TREE_TYPE (bits1), bits1, bits2), + bits2); +} + +/* Rotate the bits in BITS SHIFT bits to the left if SHIFT is positive, or ABS + (SHIFT) bits to the right if SHIFT is negative. + + A run-time error is raised if the count overflows the BITS value. */ + +tree +a68_bits_shift (tree shift, tree bits) +{ + shift = save_expr (shift); + bits = save_expr (bits); + return fold_build3 (COND_EXPR, + TREE_TYPE (bits), + fold_build2 (GE_EXPR, TREE_TYPE (shift), + shift, build_int_cst (TREE_TYPE (shift), 0)), + fold_build2 (LSHIFT_EXPR, TREE_TYPE (bits), + bits, shift), + fold_build2 (RSHIFT_EXPR, TREE_TYPE (bits), + bits, + fold_build1 (ABS_EXPR, TREE_TYPE (shift), shift))); +} + +/* Given two bits values, build an expression that calculates whether A = B. */ + +tree +a68_bits_eq (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, EQ_EXPR, boolean_type_node, a, b); +} + +/* Given two bits values, build an expression that calculates whether A /= + B. */ + +tree +a68_bits_ne (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b); +} diff --git a/gcc/algol68/a68-low-bools.cc b/gcc/algol68/a68-low-bools.cc new file mode 100644 index 000000000000..000e919407d9 --- /dev/null +++ b/gcc/algol68/a68-low-bools.cc @@ -0,0 +1,77 @@ +/* Lowering routines for all things related to BOOL values. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Return a tree with the yielind of SKIP of a BOOL mode. */ + +tree +a68_get_bool_skip_tree (void) +{ + return build_int_cst (a68_bool_type, 0); +} + +/* The absolute value of a BOOL is a non-zero INT for TRUE and zero for + FALSE. */ + +tree +a68_bool_abs (tree val) +{ + return fold_convert (a68_int_type, val); +} + +/* Given two boolean values, build an expression that calculates whether A = B. */ + +tree +a68_bool_eq (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, EQ_EXPR, boolean_type_node, a, b); +} + +/* Given two boolean values, build an expression that calculates whether A /= + B. */ + +tree +a68_bool_ne (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b); +} diff --git a/gcc/algol68/a68-low-builtins.cc b/gcc/algol68/a68-low-builtins.cc new file mode 100644 index 000000000000..eabf7b348359 --- /dev/null +++ b/gcc/algol68/a68-low-builtins.cc @@ -0,0 +1,533 @@ +/* GCC built-ins support for Algol 68. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Define a built-in function. */ + +static void +local_define_builtin (const char *name, tree type, enum built_in_function code, + const char *library_name, int ecf_flags) +{ + tree decl; + + decl = add_builtin_function (name, type, code, BUILT_IN_NORMAL, + library_name, NULL_TREE); + set_call_expr_flags (decl, ecf_flags); + set_builtin_decl (code, decl, true); +} + +/* Install the GCC built-ins so the front-end can use them. */ + +void +a68_install_builtins (void) +{ + if (!builtin_decl_explicit_p (BUILT_IN_IROUNDF)) + { + tree ftype = build_function_type_list (integer_type_node, + float_type_node, + NULL_TREE); + local_define_builtin ("__builtin_iroundf", ftype, BUILT_IN_IROUNDF, + "iroundf", ECF_CONST | ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LROUNDF)) + { + tree ftype = build_function_type_list (long_integer_type_node, + float_type_node, + NULL_TREE); + local_define_builtin ("__builtin_lroundf", ftype, BUILT_IN_LROUNDF, + "lroundf", ECF_CONST | ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LLROUNDF)) + { + tree ftype = build_function_type_list (long_long_integer_type_node, + float_type_node, + NULL_TREE); + local_define_builtin ("__builtin_llroundf", ftype, BUILT_IN_LLROUNDF, + "llroundf", ECF_CONST | ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_IROUND)) + { + tree ftype = build_function_type_list (integer_type_node, + double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_iround", ftype, BUILT_IN_IROUND, + "iround", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LROUND)) + { + tree ftype = build_function_type_list (long_integer_type_node, + double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_lround", ftype, BUILT_IN_LROUND, + "lround", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LLROUND)) + { + tree ftype = build_function_type_list (long_long_integer_type_node, + double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_llround", ftype, BUILT_IN_LLROUND, + "llround", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_IROUNDL)) + { + tree ftype = build_function_type_list (integer_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_iroundl", ftype, BUILT_IN_IROUNDL, + "iroundl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LROUNDL)) + { + tree ftype = build_function_type_list (long_integer_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_lroundl", ftype, BUILT_IN_LROUNDL, + "lroundl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LLROUNDL)) + { + tree ftype = build_function_type_list (long_long_integer_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_llroundl", ftype, BUILT_IN_LLROUNDL, + "llroundl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_IFLOORF)) + { + tree ftype = build_function_type_list (integer_type_node, + float_type_node, + NULL_TREE); + local_define_builtin ("__builtin_ifloorf", ftype, BUILT_IN_IFLOORF, + "ifloorf", ECF_CONST | ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LFLOORF)) + { + tree ftype = build_function_type_list (long_integer_type_node, + float_type_node, + NULL_TREE); + local_define_builtin ("__builtin_lfloorf", ftype, BUILT_IN_LFLOORF, + "lfloorf", ECF_CONST | ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LLFLOORF)) + { + tree ftype = build_function_type_list (long_long_integer_type_node, + float_type_node, + NULL_TREE); + local_define_builtin ("__builtin_llfloorf", ftype, BUILT_IN_LLFLOORF, + "llfloorf", ECF_CONST | ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_IFLOOR)) + { + tree ftype = build_function_type_list (integer_type_node, + double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_ifloor", ftype, BUILT_IN_IFLOOR, + "ifloor", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LFLOOR)) + { + tree ftype = build_function_type_list (long_integer_type_node, + double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_lfloor", ftype, BUILT_IN_LFLOOR, + "lfloor", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LLFLOOR)) + { + tree ftype = build_function_type_list (long_long_integer_type_node, + double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_llfloor", ftype, BUILT_IN_LLFLOOR, + "llfloor", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_IFLOORL)) + { + tree ftype = build_function_type_list (integer_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_ifloorl", ftype, BUILT_IN_IFLOORL, + "ifloorl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LFLOORL)) + { + tree ftype = build_function_type_list (long_integer_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_lfloorl", ftype, BUILT_IN_LFLOORL, + "lfloorl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LLFLOORL)) + { + tree ftype = build_function_type_list (long_long_integer_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_llfloorl", ftype, BUILT_IN_LLFLOORL, + "llfloorl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_POWF)) + { + tree ftype = build_function_type_list (float_type_node, + float_type_node, float_type_node, + NULL_TREE); + local_define_builtin ("__builtin_powf", ftype, BUILT_IN_POWF, + "powf", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_POWIF)) + { + tree ftype = build_function_type_list (float_type_node, + float_type_node, integer_type_node, + NULL_TREE); + local_define_builtin ("__builtin_powif", ftype, BUILT_IN_POWIF, + "powif", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_POW)) + { + tree ftype = build_function_type_list (double_type_node, + double_type_node, double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_pow", ftype, BUILT_IN_POW, + "pow", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_POWI)) + { + tree ftype = build_function_type_list (double_type_node, + double_type_node, integer_type_node, + NULL_TREE); + local_define_builtin ("__builtin_powi", ftype, BUILT_IN_POWI, + "powi", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_POWL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_powl", ftype, BUILT_IN_POWL, + "powl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_POWIL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, integer_type_node, + NULL_TREE); + local_define_builtin ("__builtin_powil", ftype, BUILT_IN_POWIL, + "powil", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_CALLOC)) + { + tree ftype = build_function_type_list (ptr_type_node, + size_type_node, size_type_node, NULL_TREE); + local_define_builtin ("__builtin_calloc", ftype, BUILT_IN_CALLOC, + "calloc", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_MEMCPY)) + { + tree ftype = build_function_type_list (ptr_type_node, + ptr_type_node, const_ptr_type_node, size_type_node, + NULL_TREE); + local_define_builtin ("__builtin_memcpy", ftype, BUILT_IN_MEMSET, + "memcpy", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_MEMSET)) + { + tree ftype = build_function_type_list (ptr_type_node, + ptr_type_node, integer_type_node, size_type_node, + NULL_TREE); + local_define_builtin ("__builtin_memset", ftype, BUILT_IN_MEMSET, + "memset", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_SQRTF)) + { + tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE); + local_define_builtin ("__builtin_sqrtf", ftype, BUILT_IN_SQRTF, + "sqrtf", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_SQRT)) + { + tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE); + local_define_builtin ("__builtin_sqrt", ftype, BUILT_IN_SQRT, + "sqrt", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_SQRTL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_sqrtl", ftype, BUILT_IN_SQRTL, + "sqrtl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_TANF)) + { + tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE); + local_define_builtin ("__builtin_tanf", ftype, BUILT_IN_TANF, + "tanf", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_TAN)) + { + tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE); + local_define_builtin ("__builtin_tan", ftype, BUILT_IN_TAN, + "tan", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_TANL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_tanl", ftype, BUILT_IN_TANL, + "tanl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_SINF)) + { + tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE); + local_define_builtin ("__builtin_sinf", ftype, BUILT_IN_SINF, + "sinf", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_SIN)) + { + tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE); + local_define_builtin ("__builtin_sin", ftype, BUILT_IN_SIN, + "sin", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_SINL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_sinl", ftype, BUILT_IN_SINL, + "sinl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_COSF)) + { + tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE); + local_define_builtin ("__builtin_cosf", ftype, BUILT_IN_COSF, + "cosf", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_COS)) + { + tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE); + local_define_builtin ("__builtin_cos", ftype, BUILT_IN_COS, + "cos", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_COSL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_cosl", ftype, BUILT_IN_COSL, + "cosl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_ACOSF)) + { + tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE); + local_define_builtin ("__builtin_acosf", ftype, BUILT_IN_ACOSF, + "acosf", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_ACOS)) + { + tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE); + local_define_builtin ("__builtin_acos", ftype, BUILT_IN_ACOS, + "acos", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_ACOSL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_acosl", ftype, BUILT_IN_ACOSL, + "acosl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_ASINF)) + { + tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE); + local_define_builtin ("__builtin_asinf", ftype, BUILT_IN_ASINF, + "asinf", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_ASIN)) + { + tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE); + local_define_builtin ("__builtin_asin", ftype, BUILT_IN_ASIN, + "asin", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_ASINL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_asinl", ftype, BUILT_IN_ASINL, + "asinl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_ATANF)) + { + tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE); + local_define_builtin ("__builtin_atanf", ftype, BUILT_IN_ATANF, + "atanf", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_ATAN)) + { + tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE); + local_define_builtin ("__builtin_atan", ftype, BUILT_IN_ATAN, + "atan", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_ATANL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_atanl", ftype, BUILT_IN_ATANL, + "atanl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LOGF)) + { + tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE); + local_define_builtin ("__builtin_logf", ftype, BUILT_IN_LOGF, + "logf", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LOG)) + { + tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE); + local_define_builtin ("__builtin_log", ftype, BUILT_IN_LOG, + "log", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LOGL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_logl", ftype, BUILT_IN_LOGL, + "logl", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LOG10F)) + { + tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE); + local_define_builtin ("__builtin_log10f", ftype, BUILT_IN_LOG10F, + "log10f", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LOG10)) + { + tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE); + local_define_builtin ("__builtin_log10", ftype, BUILT_IN_LOG10, + "log10", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_LOG10L)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_log10l", ftype, BUILT_IN_LOG10L, + "log10l", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_EXPF)) + { + tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE); + local_define_builtin ("__builtin_expf", ftype, BUILT_IN_EXPF, + "expf", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_EXP)) + { + tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE); + local_define_builtin ("__builtin_exp", ftype, BUILT_IN_EXP, + "exp", ECF_NOTHROW | ECF_LEAF); + } + + if (!builtin_decl_explicit_p (BUILT_IN_EXPL)) + { + tree ftype = build_function_type_list (long_double_type_node, + long_double_type_node, + NULL_TREE); + local_define_builtin ("__builtin_expl", ftype, BUILT_IN_EXPL, + "expl", ECF_NOTHROW | ECF_LEAF); + } +} diff --git a/gcc/algol68/a68-low-chars.cc b/gcc/algol68/a68-low-chars.cc new file mode 100644 index 000000000000..244493475558 --- /dev/null +++ b/gcc/algol68/a68-low-chars.cc @@ -0,0 +1,170 @@ +/* Lowering routines for all things related to STRINGs. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Return a tree with the yielind of SKIP of a CHAR mode. */ + +tree +a68_get_char_skip_tree (void) +{ + return build_int_cst (a68_char_type, ' '); +} + +/* Return the maximum valid character code that can be stored in a CHAR. */ +tree +a68_char_max (void) +{ + /* 0x10FFFF is the maximum valid code point in Unicode. */ + return build_int_cst (a68_char_type, 0x10FFFF); +} + +/* Given an integral value, if it denotes a char code build the corresponding + CHAR. Otherwise raise a run-time error. */ + +tree +a68_char_repr (NODE_T *p, tree val) +{ + /* UCS-4 (UTF-32) encodes the Unicode code points using the identity + function. Valid code points are in the ranges [U+0000,U+D7FF] and + [U+E000,U+10FFFF]. */ + + tree c = save_expr (val); + tree val_type = TREE_TYPE (val); + + /* (c >= 0 && c < 0xd800) */ + tree range1 = fold_build2 (TRUTH_AND_EXPR, integer_type_node, + fold_build2 (GE_EXPR, integer_type_node, + c, fold_convert (val_type, integer_zero_node)), + fold_build2 (LT_EXPR, integer_type_node, + c, build_int_cst (val_type, 0xd800))); + /* (c >= 0xe000 && c < 0x110000) */ + tree range2 = fold_build2 (TRUTH_AND_EXPR, integer_type_node, + fold_build2 (GE_EXPR, integer_type_node, + c, build_int_cst (val_type, 0xe000)), + fold_build2 (LT_EXPR, integer_type_node, + c, build_int_cst (val_type, 0x110000))); + tree notvalid = fold_build1 (TRUTH_NOT_EXPR, + integer_type_node, + fold_build2 (TRUTH_OR_EXPR, integer_type_node, + range1, range2)); + + /* Call to the runtime run-time error handler. */ + unsigned int lineno = NUMBER (LINE (INFO (p))); + const char *filename_str = FILENAME (LINE (INFO (p))); + tree filename = build_string_literal (strlen (filename_str) + 1, + filename_str); + tree call = a68_build_libcall (A68_LIBCALL_INVALIDCHARERROR, + void_type_node, 3, + filename, + build_int_cst (unsigned_type_node, lineno), + fold_convert (a68_int_type, c)); + + /* Return the REPR of the given integer value, or raise run-time error. */ + return fold_build2 (COMPOUND_EXPR, a68_char_type, + fold_build3 (COND_EXPR, integer_type_node, + notvalid, + call, integer_zero_node), + fold_convert (a68_char_type, c)); +} + +/* the ABS of a CHAR is an INT containing an unique value for each permissable + char value. */ + +tree +a68_char_abs (tree val) +{ + return fold_convert (a68_int_type, val); +} + +/* Given two characters, build an expression that calculates whether A = B. */ + +tree +a68_char_eq (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, EQ_EXPR, boolean_type_node, a, b); +} + +/* Given two characters, build an expression that calculates whether A /= + B. */ + +tree +a68_char_ne (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b); +} + +/* Given two characters, build an expression that calculates + whether A < B. */ + +tree +a68_char_lt (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, LT_EXPR, boolean_type_node, a, b); +} + +/* Given two characters, build an expression that calculates + whether A <= B. */ + +tree +a68_char_le (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, LE_EXPR, boolean_type_node, a, b); +} + +/* Given two characters, build an expression that calculates + whether A > B. */ + +tree +a68_char_gt (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, GT_EXPR, boolean_type_node, a, b); +} + +/* Given two characters, build an expression that calculates + whether A >= B. */ + +tree +a68_char_ge (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, GE_EXPR, boolean_type_node, a, b); +} diff --git a/gcc/algol68/a68-low-clauses.cc b/gcc/algol68/a68-low-clauses.cc new file mode 100644 index 000000000000..77e07b1121b1 --- /dev/null +++ b/gcc/algol68/a68-low-clauses.cc @@ -0,0 +1,1480 @@ +/* Lower clauses to GENERIC. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Given a serial_clause node P, return whether it performs dynamic stack + allocations. + + This function allocates for the fact that the bottom-up parser generates + successively nested serial clauses like + + SERIAL_CLAUSE + SERIAL_CLAUSE + ... + + the outer of which corresponds to a single serial clause in the source code, + but it is the inner ones annotated by the dsa pass. */ + +static bool +serial_clause_dsa (NODE_T *p) +{ + NODE_T *s = NEXT (SUB (p)); + + for (s = p; SUB (s) && IS (s, SERIAL_CLAUSE); s = SUB (s)) + { + if (DYNAMIC_STACK_ALLOCS (s)) + return true; + } + + return false; +} + +/* Lower one or more labels. + + label : defining identifier, colon symbol; + label, defining identifier, colon symbol; + + A label lowers into a LABEL_EXPR and the declaration of a LABEL_DECL in the + current block and bind. Lists of labels get returned in nested compound + expressions. */ + +tree +a68_lower_label (NODE_T *p, LOW_CTX_T ctx) +{ + tree expr = NULL_TREE; + + if (IS (SUB (p), LABEL)) + expr = a68_lower_tree (SUB (p), ctx); + + NODE_T *defining_identifier; + + if (IS (SUB (p), DEFINING_IDENTIFIER)) + defining_identifier = SUB (p); + else + { + gcc_assert (IS (NEXT (SUB (p)), DEFINING_IDENTIFIER)); + defining_identifier = NEXT (SUB (p)); + } + + /* Create LABEL_DECL if necessary. */ + tree label_decl = TAX_TREE_DECL (TAX (defining_identifier)); + if (label_decl == NULL_TREE) + { + label_decl = build_decl (a68_get_node_location (defining_identifier), + LABEL_DECL, + a68_get_mangled_identifier (NSYMBOL (defining_identifier)), + void_type_node); + TAX_TREE_DECL (TAX (defining_identifier)) = label_decl; + } + + a68_add_decl (label_decl); + + /* Return the accummulated LABEL_EXPRs. */ + tree label_expr = build1 (LABEL_EXPR, void_type_node, label_decl); + if (expr) + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + void_type_node, + expr, label_expr); + else + return label_expr; +} + +/* Lower a labeled unit. + + labeled unit : label, unit. + + Lower the label, then the unit. Return them in a compound expression. */ + +tree +a68_lower_labeled_unit (NODE_T *p, LOW_CTX_T ctx) +{ + tree label_expr = a68_lower_tree (SUB (p), ctx); + tree unit_expr = a68_lower_tree (NEXT (SUB (p)), ctx); + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (unit_expr), + label_expr, unit_expr); +} + +/* Lower a completer. + + exit_symbol + + This handler replaces the last expression in stmt_list with a statement + assigning it to the clause result of the current serial clause, then jump to + the exit label of the current serial clause. Note that a completer is a + separator so stmt_list contains at least one expression at this point. Note + that a completer can only appear inside a serial clause. + + This function always returns NULL_TREE, so the traversing code shall always + be careful to travese on these nodes explicitly and ignore the returned + value. */ + +tree +a68_lower_completer (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + a68_add_completer (); + return NULL_TREE; +} + +/* Lower an initialiser series. + + Parse tree: + + initialiser series : serial clause, semi symbol, declaration list; + initialiser series, declaration list; + initialiser series, semi symbol, unit; + initialiser series, semi symbol, labeled unit; + initialiser series, semi symbol, declaration list. + + GENERIC: + + Traverse subtree adding units and labels to STMT_LIST, and declarations to + BLOCK. + + This function always returns NULL_TREE, so the traversing code shall always + be careful to travese on these nodes explicitly and ignore the returned + value. */ + +tree +a68_lower_initialiser_series (NODE_T *p, LOW_CTX_T ctx) +{ + for (NODE_T *s = SUB (p); s != NO_NODE; FORWARD (s)) + { + if (!IS (s, SEMI_SYMBOL)) + a68_add_stmt (a68_lower_tree (s, ctx)); + } + return NULL_TREE; +} + +/* Lower a serial clause. + + serial clause : labeled unit; + unit; + serial clause, semi symbol, unit; + serial clause, exit symbol, labeled unit; + serial clause, semi_symbol, declaration list; + initialiser series, semi symbol, unit; + initialiser series, semi symbol, labeled unit. + + Ranges: + + serial-clause + ------------- R1 + + See the function body to see the lowering actions. + + This function always returns NULL_TREE, so the traversing code shall always + be careful to travese on these nodes explicitly and ignore the returned + value. */ + +tree +a68_lower_serial_clause (NODE_T *p, LOW_CTX_T ctx) +{ + if (IS (SUB (p), SERIAL_CLAUSE)) + { + /* Traverse down for side-effects. */ + (void) a68_lower_tree (SUB (p), ctx); + + if (IS (NEXT (SUB (p)), EXIT_SYMBOL)) + { + /* Traverse the completer for side-effects. This turns the last + expression in the current statements list into an assignment. */ + (void) a68_lower_tree (NEXT (SUB (p)), ctx); + /* Now append the result of the labeled unit to the current + statements list. */ + a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); + } + else + { + /* Append the result of either the unit or the declarations list in + the current statements list. */ + a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); + } + } + else if (IS (SUB (p), INITIALISER_SERIES)) + { + /* Traverse down for side-effects. */ + (void) a68_lower_tree (SUB (p), ctx); + + /* Append the result of either the unit or the declarations list in the + current statements list. */ + a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); + } + else + { + /* Append the result of either the unit or labeled unit in the current + statements list. */ + a68_add_stmt (a68_lower_tree (SUB (p), ctx)); + } + + return NULL_TREE; +} + +/* Lower a loop clause. + + loop clause : for part, from part, by part, to part, while part, alt do part; + for part, from part, by part, while part, alt do part; + for part, from part, while part, alt do part; + for part, by part, to part, while part, alt do part; + for part, by part, to part, while part, alt do part; + for part, by part, while part, alt do part; + for part, while part, alt do part; + for part, from part, by part, to part, alt do part; + for part, from part, by part, alt do part; + for part, from part, alt do part; + for part, by part, to part, alt do part; + for part, by part, alt do part; + for part, to part, alt do part, + for part, alt do part; + from part, by part, to part, while part, alt do part; + from part, by part, while aprt, alt do part; + from part, to part, while aprt, alt do part; + from part, while part, alt do part; + from part, by part, to part, alt do part; + from part, by part, alt do part; + from part, to part, alt do part; + from part, alt do part; + by part, to part, while part, alt do part; + by part, while part, alt do part; + by part, to part, alt do part; + by part, alt do part; + to part, while part, alt do part; + to part, alt do part; + while part, alt do part; + do part. +*/ + +tree +a68_lower_loop_clause (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + NODE_T *s = SUB (p); + bool while_part = false; + bool has_iterator = false; + tree iterator = NULL_TREE; + tree while_condition = NULL_TREE; + tree do_part = NULL_TREE; + tree from_part = NULL_TREE; + tree by_part = NULL_TREE; + tree to_part = NULL_TREE; + tree overflow = NULL_TREE; + NODE_T *iterator_defining_identifier = NO_NODE; + + if (IS (s, FOR_PART)) + { + /* Get the defining identifier. */ + iterator_defining_identifier = NEXT (SUB (s)); + has_iterator = true; + FORWARD (s); + } + + if (IS (s, FROM_PART)) + { + /* Lower the unit. */ + from_part = a68_lower_tree (NEXT (SUB (s)), ctx); + has_iterator = true; + FORWARD (s); + } + + if (IS (s, BY_PART)) + { + /* Lower the unit. */ + by_part = a68_lower_tree (NEXT (SUB (s)), ctx); + has_iterator = true; + FORWARD (s); + } + + if (IS (s, TO_PART)) + { + /* Lower the unit. */ + to_part = a68_lower_tree (NEXT (SUB (s)), ctx); + has_iterator = true; + FORWARD (s); + } + + if (has_iterator) + { + /* Introduce a range that spans until the end of the loop clause. */ + a68_push_range (M_VOID); + + /* Compute some defaults for not specified loop parts. Note that to_part + defaults to max_int or min_int depending on the signedness of + by_part. */ + if (from_part == NULL_TREE) + from_part = integer_one_node; + if (by_part == NULL_TREE) + by_part = integer_one_node; + if (to_part == NULL_TREE) + { + to_part = fold_build3 (COND_EXPR, + a68_bool_type, + fold_build2 (LT_EXPR, a68_int_type, by_part, + build_int_cst (a68_int_type, 0)), + a68_int_minval (a68_int_type), + a68_int_maxval (a68_int_type)); + } + + /* If the user has specified an explicit iterator in the form of a + defining-identifier in a for-part, use it as the name in the iterator + declaration and install the resulting declaration in the taxes table + in order for applied identifiers in the rest of the loop to find it. + Otherwise, the iterator is not directly accessible by the + programmer. */ + const char *iterator_name = (iterator_defining_identifier == NO_NODE + ? "iterator%" + : NSYMBOL (iterator_defining_identifier)); + iterator = a68_lower_tmpvar (iterator_name, a68_int_type, from_part); + if (iterator_defining_identifier != NO_NODE) + TAX_TREE_DECL (TAX (iterator_defining_identifier)) = iterator; + + /* The from_part and to_part expressions shall be evaluated once and once + only. The expression for from_part is evaluated only once in the + initialization expression for iterator% above, but we need to put + to_part in a temporary since it is used in the loop body. */ + to_part = a68_lower_tmpvar ("to_part%", TREE_TYPE (to_part), to_part); + + /* We need to detect overflow/underflow of the iterator. */ + overflow = a68_lower_tmpvar ("overflow%", boolean_type_node, + boolean_false_node); + } + + if (IS (s, WHILE_PART)) + { + while_part = true; + /* Introduce a range that spans until the end of the loop clause. */ + a68_push_range (M_VOID); + /* Process the enquiry clause, which yields a BOOL. */ + a68_push_stmt_list (M_BOOL); + (void) a68_lower_tree (NEXT (SUB (s)), ctx); + while_condition = a68_pop_stmt_list (); + FORWARD (s); + } + + /* DO part. */ + gcc_assert (IS (s, ALT_DO_PART) || IS (s, DO_PART)); + + /* Build the loop's body. */ + a68_push_range (NULL); + { + /* First lower the loop exit condition. */ + if (has_iterator || while_part) + { + tree exit_condition = NULL_TREE; + /* IF overflow OREL (by_part < 0 THEN iterator < to_part ELSE iterator > to_part) FI */ + if (has_iterator) + exit_condition = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, + overflow, + fold_build3 (COND_EXPR, + a68_bool_type, + fold_build2 (LT_EXPR, a68_int_type, by_part, + build_int_cst (a68_int_type, 0)), + fold_build2 (LT_EXPR, a68_int_type, + iterator, to_part), + fold_build2 (GT_EXPR, a68_int_type, + iterator, to_part))); + /* NOT while_condition */ + if (while_part) + { + tree while_exit_condition = fold_build1 (TRUTH_NOT_EXPR, + a68_bool_type, + while_condition); + if (has_iterator) + exit_condition = fold_build2 (TRUTH_ORIF_EXPR, a68_bool_type, + exit_condition, while_exit_condition); + else + exit_condition = while_exit_condition; + } + + if (exit_condition != NULL_TREE) + a68_add_stmt (fold_build1 (EXIT_EXPR, void_type_node, exit_condition)); + } + + /* Serial clauses in DO .. OD do not yield any value. */ + bool dsa = serial_clause_dsa (NEXT (SUB (s))); + bool local = NON_LOCAL (NEXT (SUB (s))) == NO_TABLE; + a68_push_serial_clause_range (M_VOID, dsa && local); + (void) a68_lower_tree (NEXT (SUB (s)), ctx); + do_part = a68_pop_serial_clause_range (); + a68_add_stmt (do_part); + + if (has_iterator) + { + /* Increment the iterator by BY_PART. Detect overflow. + Given a + b = sum, overflows = ((~((a) ^ (b)) & ((a) ^ (sum))) < 0) + See OVERFLOW_SUM_SIGN in double-int.cc for an explanation + of this formula. + */ + tree type = TREE_TYPE (iterator); + tree a = iterator; + tree b = save_expr (by_part); + tree sum = fold_build2 (PLUS_EXPR, type, a, b); + a68_add_stmt (fold_build2 (MODIFY_EXPR, boolean_type_node, + overflow, + fold_build2 (LT_EXPR, boolean_type_node, + fold_build2 (BIT_AND_EXPR, type, + fold_build1 (BIT_NOT_EXPR, type, + fold_build2 (BIT_XOR_EXPR, type, + a, b)), + fold_build2 (BIT_XOR_EXPR, type, + a, sum)), + build_int_cst (a68_int_type, 0)))); + a68_add_stmt (fold_build2 (MODIFY_EXPR, type, iterator, sum)); + } + } + tree loop_body = a68_pop_range (); + + /* Finally build the LOOP_EXPR and exit the introduced ranges. */ + tree loop_clause = fold_build1_loc (a68_get_node_location (p), + LOOP_EXPR, a68_void_type, loop_body); + if (while_part) + { + a68_add_stmt (loop_clause); + loop_clause = a68_pop_range (); + } + if (has_iterator) + { + a68_add_stmt (loop_clause); + loop_clause = a68_pop_range (); + } + + return loop_clause; +} + +/* Lower a conformity clause. + + conformity clause : case part, conformity in part, out part, esac symbol; + case part, conformity in part, esac symbol; + case part, conformity in part, conformity ouse part; + open part, conformity choice, choice, close symbol; + open part, conformity choice, close symbol; + open part, conformity choice, brief conformity ouse part. + + conformity choice : then bar symbol, specified unit list; + then bar symbol, specified unit. + + specified unit list : specified unit list, comma symbol, specified unit; + specified unit list, specified unit. + + specified unit : specifier, colon symbol, unit. + + specifier : open symbol, declarer, identifier, close symbol; + open symbol, declarer, close symbol; + open symbol, void symbol, close symbol. +*/ + +static void +lower_unite_case_unit (NODE_T *p, + tree enquiry, MOID_T *enquiry_mode, + tree result, tree exit_label, LOW_CTX_T ctx) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, SPECIFIER)) + { + MOID_T *spec_moid = MOID (NEXT (SUB (p))); + NODE_T *spec_identifier = NEXT (NEXT (SUB (p))); + NODE_T *spec_unit = NEXT (NEXT (p)); + const char *specifier_identifier_name = NULL; + if (IS (spec_identifier, IDENTIFIER)) + specifier_identifier_name = NSYMBOL (spec_identifier); + + tree overhead = a68_union_overhead (enquiry); + tree spec_value = NULL_TREE; + tree entry_selected = NULL_TREE; + if (IS_UNION (spec_moid)) + { + /* The spec_moid is an united mode, which must be unitable to the + enquiry_mode. */ + gcc_assert (a68_is_unitable (spec_moid, enquiry_mode, + SAFE_DEFLEXING)); + + /* Build the entry_selected expression. + + For each mode in spec_moid, determine the corresponding index + in enquiry_mode and add a check for it to the expression. */ + for (PACK_T *pack = PACK (spec_moid); pack != NO_PACK; FORWARD (pack)) + { + int index = a68_united_mode_index (enquiry_mode, MOID (pack)); + tree expr = fold_build2 (EQ_EXPR, + boolean_type_node, + overhead, + build_int_cst (TREE_TYPE (overhead), index)); + if (entry_selected == NULL_TREE) + entry_selected = expr; + else + entry_selected = fold_build2 (TRUTH_OR_EXPR, + boolean_type_node, + entry_selected, + expr); + } + + /* The spec_value is an union of mode spec_moid, with the + overhead translated from enquiry_mode. */ + tree spec_overhead + = a68_union_translate_overhead (enquiry_mode, overhead, spec_moid); + a68_push_range (spec_moid); + spec_value = a68_lower_tmpvar ("spec_value%", + CTYPE (spec_moid), + a68_get_skip_tree (spec_moid)); + a68_add_stmt (a68_union_set_overhead (spec_value, spec_overhead)); + tree from_cunion = a68_union_cunion (enquiry); + tree to_cunion = a68_union_cunion (spec_value); + a68_add_stmt (a68_lower_memcpy (fold_build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (to_cunion)), + to_cunion), + fold_build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (from_cunion)), + from_cunion), + size_in_bytes (TREE_TYPE (to_cunion)))); + a68_add_stmt (spec_value); + spec_value = a68_pop_range (); + } + else + { + int index = a68_united_mode_index (enquiry_mode, spec_moid); + spec_value = a68_union_alternative (enquiry, index); + entry_selected = fold_build2 (EQ_EXPR, + TREE_TYPE (overhead), + overhead, + build_int_cst (TREE_TYPE (overhead), index)); + } + + a68_push_range (M_VOID); + { + /* If the enquiry value is ascribed to an identifier in the case + entry then create a suitable declaration and turn the identifier + into a defining identifier. */ + if (specifier_identifier_name) + { + tree united_value = a68_lower_tmpvar (specifier_identifier_name, + CTYPE (spec_moid), spec_value); + TAX_TREE_DECL (TAX (spec_identifier)) = united_value; + } + + /* Set result% to the lowering of the unit and jump to the end of + the enquiry clause. */ + a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (result), + result, a68_lower_tree (spec_unit, ctx))); + a68_add_stmt (fold_build1 (GOTO_EXPR, + void_type_node, + exit_label)); + a68_add_stmt (a68_get_skip_tree (M_VOID)); + } + tree process_entry = a68_pop_range (); + + /* IF index = overhead THEN process entry FI */ + a68_add_stmt (fold_build3 (COND_EXPR, + a68_void_type, + entry_selected, + process_entry, + a68_get_skip_tree (M_VOID))); + + FORWARD (p); /* Skip specifier. */ + FORWARD (p); /* Skip unit. */ + /* The unit is skipped in the for loop post-action. */ + } + else + lower_unite_case_unit (SUB (p), + enquiry, enquiry_mode, + result, exit_label, ctx); + } +} + +tree +a68_lower_conformity_clause (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *conformity_clause_mode = MOID (p); + + /* CASE or OUSE. */ + NODE_T *s = SUB (p); + NODE_T *enquiry_node = NEXT (SUB (s)); + MOID_T *enquiry_mode = MOID (SUB (s)); + + /* Push a binding environment for the enquiry clause. */ + a68_push_range (conformity_clause_mode); + + /* Process the enquiry clause and put the resulting value in enquiry%. */ + a68_push_stmt_list (enquiry_mode); + (void) a68_lower_tree (enquiry_node, ctx); + tree enquiry = a68_lower_tmpvar ("enquiry%", + CTYPE (enquiry_mode), + a68_pop_stmt_list ()); + + /* Create a decl for result%. */ + tree result = a68_lower_tmpvar ("result%", + CTYPE (conformity_clause_mode), + a68_get_skip_tree (conformity_clause_mode)); + + /* Create an exit label. */ + tree exit_label = build_decl (UNKNOWN_LOCATION, + LABEL_DECL, + get_identifier ("exit_label%"), + void_type_node); + DECL_CONTEXT (exit_label) = a68_range_context (); + a68_add_decl (exit_label); + a68_add_decl_expr (fold_build1 (DECL_EXPR, TREE_TYPE (exit_label), exit_label)); + + /* IN. */ + FORWARD (s); + lower_unite_case_unit (NEXT (SUB (s)), + enquiry, enquiry_mode, + result, exit_label, ctx); + + /* OUT. */ + FORWARD (s); + switch (ATTRIBUTE (s)) + { + case CHOICE: + case OUT_PART: + { + bool dsa = serial_clause_dsa (NEXT (SUB (s))); + bool local = NON_LOCAL (NEXT (SUB (s))) == NO_TABLE; + a68_push_serial_clause_range (conformity_clause_mode, dsa && local); + + (void) a68_lower_tree (NEXT (SUB (s)), ctx); + a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (result), + result, a68_pop_serial_clause_range ())); + a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label)); + break; + } + case CLOSE_SYMBOL: + case ESAC_SYMBOL: + a68_add_stmt (fold_build2 (MODIFY_EXPR, + TREE_TYPE (result), + result, + a68_get_skip_tree (conformity_clause_mode))); + a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label)); + break; + default: + /* Recurse. + + Note that the parser guarantees that the embedded CASE clause is a + conformity clause, and that its mode is the same than the containing + clause, but it doesn't annotate the mode in the tree node so we have + to do it here. */ + MOID (s) = conformity_clause_mode; + a68_add_stmt (fold_build2 (MODIFY_EXPR, + TREE_TYPE (result), + result, + a68_lower_conformity_clause (s, ctx))); + a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label)); + break; + } + + /* ESAC */ + a68_add_stmt (build1 (LABEL_EXPR, void_type_node, exit_label)); + a68_add_stmt (result); + return a68_pop_range (); +} + +/* Lower a case clause. + + case clause : open part, case choice clause, choice, close symbol; + open part, case choice clause, close symbol; + open part, case shoice clause, brief ouse part; + case part, case in part, out part, esac symbol; + case part, case in part, esac symbol; + case part, case in part, case ouse part; +*/ + +static void +lower_int_case_unit (NODE_T *p, + tree enquiry, MOID_T *enquiry_mode, + tree result, tree exit_label, int *count, + LOW_CTX_T ctx) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + { + a68_push_range (M_VOID); + { + /* Set result% to the lowering of the unit and jump to the end of + the enquiry clause. */ + a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (result), + result, a68_lower_tree (p, ctx))); + a68_add_stmt (fold_build1 (GOTO_EXPR, + void_type_node, + exit_label)); + a68_add_stmt (a68_get_skip_tree (M_VOID)); + } + tree process_entry = a68_pop_range (); + + /* IF count = enquiry THEN process entry FI */ + a68_add_stmt (fold_build3 (COND_EXPR, + a68_void_type, + fold_build2 (EQ_EXPR, + TREE_TYPE (enquiry), + enquiry, + build_int_cst (TREE_TYPE (enquiry), *count)), + process_entry, + a68_get_skip_tree (M_VOID))); + *count += 1; + } + else + lower_int_case_unit (SUB (p), + enquiry, enquiry_mode, + result, exit_label, count, ctx); + } +} + +tree +a68_lower_case_clause (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + MOID_T *case_clause_mode = MOID (p); + + /* CASE or OUSE */ + NODE_T *s = SUB (p); + NODE_T *enquiry_node = NEXT (SUB (s)); + MOID_T *enquiry_mode = M_INT; + + /* Push a bingding environment fo the case clause. */ + a68_push_range (case_clause_mode); + + /* Process the enquiry clause and put the result value in enquiry%. */ + a68_push_stmt_list (enquiry_mode); + (void) a68_lower_tree (enquiry_node, ctx); + tree enquiry = a68_lower_tmpvar ("enquiry%", + CTYPE (enquiry_mode), + a68_pop_stmt_list ()); + /* Create a decl for result%. */ + tree result = a68_lower_tmpvar ("result%", + CTYPE (case_clause_mode), + a68_get_skip_tree (case_clause_mode)); + + /* Create an exit label. */ + tree exit_label = build_decl (UNKNOWN_LOCATION, + LABEL_DECL, + get_identifier ("exit_label%"), + void_type_node); + DECL_CONTEXT (exit_label) = a68_range_context (); + a68_add_decl (exit_label); + a68_add_decl_expr (fold_build1 (DECL_EXPR, TREE_TYPE (exit_label), exit_label)); + + /* IN. */ + FORWARD (s); + int count = 1; + lower_int_case_unit (NEXT (SUB (s)), + enquiry, enquiry_mode, + result, exit_label, &count, ctx); + + /* OUT. */ + FORWARD (s); + switch (ATTRIBUTE (s)) + { + case CHOICE: + case OUT_PART: + { + bool dsa = serial_clause_dsa (NEXT (SUB (s))); + bool local = NON_LOCAL (NEXT (SUB (s))) == NO_TABLE; + a68_push_serial_clause_range (case_clause_mode, dsa && local); + + (void) a68_lower_tree (NEXT (SUB (s)), ctx); + a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (result), + result, a68_pop_serial_clause_range ())); + a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label)); + break; + } + case CLOSE_SYMBOL: + case ESAC_SYMBOL: + a68_add_stmt (fold_build2 (MODIFY_EXPR, + TREE_TYPE (result), + result, + a68_get_skip_tree (case_clause_mode))); + a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label)); + break; + default: + /* Recurse. + + Note that the parser guarantees that the embedded CASE clause has the + same mode than the containing clause, but it doesn't annotate the OUSE + node with its mode so we have to do it here. */ + MOID (s) = case_clause_mode; + a68_add_stmt (fold_build2 (MODIFY_EXPR, + TREE_TYPE (result), + result, + a68_lower_case_clause (s, ctx))); + a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label)); + break; + } + + /* ESAC */ + a68_add_stmt (build1 (LABEL_EXPR, void_type_node, exit_label)); + a68_add_stmt (result); + return a68_pop_range (); +} + +/* Lower an enquiry clause. + + enquiry clause : unit; + enquiry clause, semi symbol, unit; + enquiry clause, comma symbol, unit; + initialiser series, semi symbol, unit. + + The units and declarations in the enquiry clause get lowered into + expressions and declaration nodes which are added to the current serial + clause. + + This function always returns NULL_TREE, so the traversing code shall always + be careful to travese on these nodes explicitly and ignore the returned + value. */ + +tree +a68_lower_enquiry_clause (NODE_T *p, LOW_CTX_T ctx) +{ + if (IS (SUB (p), UNIT)) + { + a68_add_stmt (a68_lower_tree (SUB (p), ctx)); + } + else if (IS (SUB (p), ENQUIRY_CLAUSE)) + { + (void) a68_lower_tree (SUB (p), ctx); + gcc_assert (IS (NEXT (NEXT (SUB (p))), UNIT)); + a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); + } + else + { + gcc_assert (IS (SUB (p), INITIALISER_SERIES)); + gcc_assert (IS (NEXT (NEXT (SUB (p))), UNIT)); + (void) a68_lower_tree (SUB (p), ctx); + a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); + } + + return NULL_TREE; +} + +/* Lower a conditional clause. + + conditional clause : open part, choice, choice, close symbol; + open part, choice, close symbol; + open part, choice, brief elif part; + if part, then part, else part, fi symbol; + if part, then part, elif part; + if part, then part, fi symbol. + + if part : if symbol, enquiry clause; + if symbol, initialiser series. + + then part : then symbol, serial clause; + then symbol, initialiser series. + + elif part : elif if part, then part, else part, fi symbol; + elif if part, then part, fi symbol; + elif if part, then part, elif part. + + else part : else symbol, serial clause; + else symbol, initialiser series. + + elif if part : elif symbol, enquiry clause. + + open part : open symbol, enquiry clause. + + choice : then bar symbol, serial clause; + then bar symbol initialiser series. + + brief elif part : else open part, choice, choice, close symbol; + else open part, choice, close symbol; + else open part, choice, bief elif part. + + else open part : else bar symbol, enquiry clause; + else bar symbol, initialiser series. + + Ranges: + + IF enquiry-clause THEN expr ELSE expr FI + --- R2 ---- R3 + ---------------------------------------- R1 + + The conditional clause lowers into: + + BIND_EXPR + BIND_EXPR_VARS -> delcls in enquiry clause. + BIND_EXPR_BODY + STMT_LIST + enquiry% = ...; + COND_EXPR (enquiry%, then_expr, else_expr) */ + +tree +a68_lower_conditional_clause (NODE_T *p, LOW_CTX_T ctx) +{ + tree then_expr = NULL_TREE; + tree else_expr = NULL_TREE; + + MOID_T *conditional_clause_mode = MOID (p); + MOID_T *effective_rows_mode = NO_MOID; + bool is_rows = false; + + /* Push a binding environment for the conditional. */ + a68_push_range (is_rows ? effective_rows_mode : conditional_clause_mode); + + /* Create a decl for %enquiry and add it to the bind's declaration chain. */ + tree enquiry_decl = build_decl (UNKNOWN_LOCATION, + VAR_DECL, + NULL, /* Set below. */ + a68_bool_type); + char *enquiry_name = xasprintf ("enquiry%d%%", DECL_UID(enquiry_decl)); + DECL_NAME (enquiry_decl) = get_identifier (enquiry_name); + free (enquiry_name); + DECL_INITIAL (enquiry_decl) = a68_get_skip_tree (M_BOOL); + a68_add_decl (enquiry_decl); + + /* Add a DECL_EXPR for enquiry_decl% */ + a68_add_stmt (fold_build1 (DECL_EXPR, a68_bool_type, enquiry_decl)); + + /* IF or ELIF part. */ + NODE_T *s = SUB (p); + + /* Process the enquiry clause. */ + (void) a68_lower_tree (NEXT (SUB (s)), ctx); + + /* Assignation enquiry% = .. expr .. + Note that since no completers are allowed in enquiry clauses, + the last statement in the statement list has to be the unit + yielding the boolean value. */ + tree_stmt_iterator si = tsi_last (a68_range_stmt_list ()); + gcc_assert (TREE_TYPE (tsi_stmt (si)) != void_type_node); + a68_add_stmt (fold_build2 (MODIFY_EXPR, a68_bool_type, enquiry_decl, tsi_stmt (si))); + tsi_delink (&si); + + /* THEN part. */ + FORWARD (s); + bool dsa = serial_clause_dsa (NEXT (SUB (s))); + bool local = NON_LOCAL (NEXT (SUB (s))) == NO_TABLE; + a68_push_serial_clause_range (is_rows ? effective_rows_mode : conditional_clause_mode, + dsa && local); + (void) a68_lower_tree (NEXT (SUB (s)), ctx); + then_expr = a68_pop_serial_clause_range (); + + /* ELSE part */ + FORWARD (s); + switch (ATTRIBUTE (s)) + { + case CHOICE: + case ELSE_PART: + { + bool dsa = serial_clause_dsa (NEXT (SUB (s))); + bool local = NON_LOCAL (NEXT (SUB (s))) == NO_TABLE; + a68_push_serial_clause_range (is_rows ? effective_rows_mode : conditional_clause_mode, + dsa && local); + (void) a68_lower_tree (NEXT (SUB (s)), ctx); + else_expr = a68_pop_serial_clause_range (); + break; + } + case CLOSE_SYMBOL: + case FI_SYMBOL: + { + else_expr = a68_get_skip_tree (is_rows ? effective_rows_mode : conditional_clause_mode); + break; + } + default: + { + /* ELIF part. Recurse. */ + MOID (s) = conditional_clause_mode; + else_expr = a68_lower_conditional_clause (s, ctx); + } + } + + /* Build the conditional clause's COND_EXPR. */ + a68_add_stmt (fold_build3_loc (a68_get_node_location (p), + COND_EXPR, + CTYPE (is_rows ? effective_rows_mode : conditional_clause_mode), + enquiry_decl, + then_expr, else_expr)); + + return a68_pop_range (); +} + +/* Lower a comma separated list of zero, two, or more units + + unit list : unit list, comma symbol, unit; + unit list, unit. + + The list of units lowers into appending the units into the current + statements list. + + This function always returns NULL_TREE, so the traversing code shall always + be careful to traverse on these nodes explicitly and ignore the returned + value. */ + +tree +a68_lower_unit_list (NODE_T *p, LOW_CTX_T ctx) +{ + if (IS (SUB (p), UNIT_LIST)) + (void) a68_lower_tree (SUB (p), ctx); + + for (NODE_T *s = SUB (p); s != NO_NODE; FORWARD (s)) + { + if (IS (s, UNIT)) + a68_add_stmt (a68_lower_tree (s, ctx)); + } + + return NULL_TREE; +} + +/* Lower a collateral clause. + + collateral clause : open symbol, unit list, close symbol; + open symbol, close symbol; + begin symbol, unit list, end symbol; + begin symbol, end symbol. + + An empty collateral clause lowers into EMPTY. */ + +tree +a68_lower_collateral_clause (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + bool clause_is_empty = (ATTRIBUTE (NEXT (SUB (p))) != UNIT_LIST); + MOID_T *mode = MOID (p); + + /* Lower the constituent units into a statements list. */ + a68_push_stmt_list (mode); + if (!clause_is_empty) + (void) a68_lower_tree (NEXT (SUB (p)), ctx); + tree units = a68_pop_stmt_list (); + + /* The collateral clause lowers to different constructions depending on its + nature. */ + if (mode == M_VOID) + { + /* A VOID-collateral-clause lowers into a STMT_LIST containing all + the units. Since there cannot be declarations in a collateral + clause, there is no need to introduce a new binding scope. Note + that for now we are not really elaborating collaterally, but + sequentially. */ + return units; + } + else if (IS_FLEXETY_ROW (mode) || mode == M_STRING) + { + if (mode == M_STRING) + mode = M_FLEX_ROW_CHAR; + + /* This is a row display. It lowers to a multiple. */ + tree row_type = CTYPE (mode); + size_t dim = DIM (DEFLEX (mode)); + + if (clause_is_empty) + { + /* The clause is empty. This lowers into a multiple with DIM + dimension, each dimension having bounds of 1:0, and no + elements. */ + tree element_pointer_type = a68_row_elements_pointer_type (row_type); + tree multiple_elements = build_int_cst (element_pointer_type, 0); + tree multiple_elements_size = size_zero_node; + + tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim); + tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim); + tree ssize_one_node = fold_convert (ssizetype, size_one_node); + tree ssize_zero_node = fold_convert (ssizetype, size_zero_node); + for (size_t d = 0; d < dim; ++d) + { + lower_bounds[d] = ssize_one_node; + upper_bounds[d] = ssize_zero_node; + } + + tree row = a68_row_value (row_type, dim, + multiple_elements, + multiple_elements_size, + lower_bounds, upper_bounds); + TREE_CONSTANT (row) = 1; + free (lower_bounds); + free (upper_bounds); + return row; + } + + if (dim == 1) + { + /* Create a constructor with the multiple's elements. */ + vec *ve = NULL; + int num_units = 0; + for (tree_stmt_iterator si = tsi_start (units); !tsi_end_p (si); tsi_next (&si)) + { + tree unit = tsi_stmt (si); + if (A68_TYPE_HAS_ROWS_P (TREE_TYPE (unit))) + unit = a68_low_dup (unit); + CONSTRUCTOR_APPEND_ELT (ve, size_int (num_units), unit); + num_units += 1; + } + + tree element_pointer_type = a68_row_elements_pointer_type (row_type); + tree array_constructor_type = build_array_type (TREE_TYPE (element_pointer_type), + build_index_type (size_int (num_units - 1))); + tree array_constructor = build_constructor (array_constructor_type, ve); + tree multiple_elements = fold_build1 (ADDR_EXPR, + element_pointer_type, + array_constructor); + tree elements_type = TREE_TYPE (element_pointer_type); + tree multiple_elements_size = fold_build2 (MULT_EXPR, sizetype, + size_int (num_units), + size_in_bytes (elements_type)); + tree lower_bound = fold_convert (ssizetype, size_one_node); + tree upper_bound = ssize_int (num_units); + tree row = a68_row_value (row_type, dim, + multiple_elements, + multiple_elements_size, + &lower_bound, &upper_bound); + return row; + } + else + { + gcc_assert (dim > 1); + + /* The units in the collateral clause are multiples, whose elements + are to be copied consecutively in a new multiple. The descriptor + of this multiple is constructed as follows: + + The first dimension is: + + - The lower bound is 1. + - The upper bound is the number of sub-multiples processed + here. + - The stride is the number of elements in each sub-multiple + multiplied by the element size. + + Subsequent dimensions are taken from the first inner multiple. + All descriptors of the inner multiples shall be equal. This is + checked at run-time, and in case of discrepancy a run-time error + is emitted. + + Let's see an example. Suppose in the stmt-list we have: + + (1, 2, 3) + {triplets: {lb: 1 ub: 3 stride: 1S} elements: {1, 2, 3}} + (4, 5, 6) + {triplets: {lb: 1 ub: 3 stride: 1S} elements: {4, 5, 6}} + + The resulting multiple would be: + + ((1, 2, 3), (4, 5, 6)) + {triplets: {{lb: 1 ub: 2 stride: 3S}, {lb: 1 ub: 3 stride: 1S}} + elements: {1, 2, 3, 4, 5, 6}} */ + + tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim); + tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim); + size_t num_units = 0; + + for (tree_stmt_iterator si = tsi_start (units); !tsi_end_p (si); tsi_next (&si)) + num_units++; + + a68_push_range (mode); + + /* Process each sub-multiple. The first sub-multiple establishes the + bounds that all subsequent sub-multiples shall match. */ + tree multiple_elements = NULL_TREE; + tree multiple_elements_size = NULL_TREE; + tree sub_multiple = NULL_TREE; + // tree sub_multiple_lb = NULL_TREE; + // tree sub_multiple_ub = NULL_TREE; + // tree sub_multiple_stride = NULL_TREE; + tree index = a68_lower_tmpvar ("index%", sizetype, size_zero_node); + for (tree_stmt_iterator si = tsi_start (units); !tsi_end_p (si); tsi_next (&si)) + { + if (sub_multiple == NULL) + sub_multiple = a68_lower_tmpvar ("sub_multiple%", + TREE_TYPE (tsi_stmt (si)), + tsi_stmt (si)); + else + a68_add_stmt (fold_build2 (MODIFY_EXPR, + TREE_TYPE (tsi_stmt (si)), + sub_multiple, + tsi_stmt (si))); + + if (si == tsi_start (units)) + { +#if 0 + tree ssize_zero_node = fold_convert (ssizetype, size_zero_node); + /* The first sub-multiple establishes the bounds that all + subsequent sub-multiples shall match. */ + sub_multiple_lb = a68_lower_tmpvar ("sub_multiple_lb%", + ssizetype, + a68_multiple_lower_bound (sub_multiple, + ssize_zero_node)); + sub_multiple_ub = a68_lower_tmpvar ("sub_multiple_ub%", + ssizetype, + a68_multiple_upper_bound (sub_multiple, + ssize_zero_node)); + sub_multiple_stride = a68_lower_tmpvar ("sub_multiple_stride%", + sizetype, + a68_multiple_stride (sub_multiple, + size_zero_node)); +#endif + /* Now we have enough information to calculate the size of + the elements of the new multiple and allocate + multiple_elements. */ + tree sub_multiple_elements = a68_multiple_elements (sub_multiple); + tree elements_pointer_type = TREE_TYPE (sub_multiple_elements); + tree elements_type = TREE_TYPE (elements_pointer_type); + multiple_elements_size = fold_build2 (MULT_EXPR, sizetype, + size_int (num_units), + size_in_bytes (elements_type)); + multiple_elements_size = fold_build2 (MULT_EXPR, sizetype, + multiple_elements_size, + a68_multiple_num_elems (sub_multiple)); + multiple_elements = a68_lower_tmpvar ("multiple_elements%", + elements_pointer_type, + a68_lower_alloca (elements_type, + multiple_elements_size)); + + /* We can also now calculate the bounds of the new multiple. + The top-level triplet has lower bound 1, upper bound is + num_units, and stride is the number of elements in each + sub-multiple multiplied by the element size. Bounds for + the subsequent DIM-1 dimensions are copied from the + sub-multiple's descriptor. */ + lower_bounds[0] = fold_convert (ssizetype, size_one_node); + upper_bounds[0] = ssize_int (num_units); + for (size_t d = 1; d < dim; ++d) + { + lower_bounds[d] = a68_multiple_lower_bound (sub_multiple, + ssize_int (d - 1)); + upper_bounds[d] = a68_multiple_upper_bound (sub_multiple, + ssize_int (d - 1)); + } + } + else + { + /* Check bounds of this sub-multiple. Note that this is + always done at run-time, since the interpretation of a row + display depens on the target type, whether it is a row row + or a row of rows, for example. */ + // XXX use sub_multiple_lb, sub_multiple_ub and sub_multiple_stride + } + + /* Copy the elements of a copy of the sub-multiple in the + elements of the multiple. */ + tree sub_multiple_elements = a68_multiple_elements (sub_multiple); + // XXX should we make a copy of the sub_multiple_elements here? + // We DO need to iterate slicing, because of strides: if + // the sub_multiple is a trimmer. + sub_multiple_elements = sub_multiple_elements; + tree sub_multiple_elements_type = TREE_TYPE (sub_multiple_elements); + tree sub_multiple_num_elems = a68_multiple_num_elems (sub_multiple); + tree sub_multiple_element_type = TREE_TYPE (sub_multiple_elements_type); + tree sub_multiple_elements_size = fold_build2 (MULT_EXPR, sizetype, + sub_multiple_num_elems, + size_in_bytes (sub_multiple_element_type)); + + /* memcpy (multiple_elements[index], sub_multiple_elements) */ + a68_add_stmt (a68_lower_memcpy (fold_build2 (POINTER_PLUS_EXPR, + sub_multiple_elements_type, + multiple_elements, + index), + sub_multiple_elements, + sub_multiple_elements_size)); + /* index += sub_multiple_elements_size */ + a68_add_stmt (fold_build2 (MODIFY_EXPR, sizetype, + index, + fold_build2 (PLUS_EXPR, sizetype, + index, sub_multiple_elements_size))); + } + + tree multiple = a68_lower_tmpvar ("multiple%", + row_type, + a68_row_value (row_type, dim, + multiple_elements, + multiple_elements_size, + lower_bounds, upper_bounds)); + free (lower_bounds); + free (upper_bounds); + + /* Yield the multiple. */ + a68_add_stmt (multiple); + return a68_pop_range (); + } + } + else if (IS_STRUCT (mode)) + { + /* This is a struct display. There are as many units in the clause as + fields in the struct type. Build a constructor with the values for + the fields. */ + vec *ve = NULL; + tree_stmt_iterator si = tsi_start (units); + for (tree f = TYPE_FIELDS (CTYPE (mode)); f; f = DECL_CHAIN (f)) + { + tree v = tsi_stmt (si); + gcc_assert (v != NULL_TREE); + v = a68_consolidate_ref (a68_type_moid (TREE_TYPE (f)) ,v); + CONSTRUCTOR_APPEND_ELT (ve, f, v); + tsi_next (&si); + } + tree ctor = build_constructor (CTYPE (mode), ve); + return ctor; + } + else + gcc_unreachable (); +} + +/* Lower a parallel clause. + + parallel clause : par symbol, collateral clause. +*/ + +tree +a68_lower_parallel_clause (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + /* XXX For now treat like a VOID collateral clause. */ + return a68_lower_tree (NEXT (SUB (p)), ctx); +} + +/* Lower a closed clause. + + closed clause : open symbol, serial clause, close symbol; + open symbol, initialiser series, close symbol; + begin symbol, serial clause, end symbol; + begin symbol, initialiser series, end symbol; + + This function returns a BIND_EXPR. */ + +tree +a68_lower_closed_clause (NODE_T *p, LOW_CTX_T ctx) +{ + /* Determine the mode of the closed clause. */ + MOID_T *clause_mode = MOID (p); + gcc_assert (clause_mode != NO_MOID); + gcc_assert (CTYPE (clause_mode) != NULL_TREE); + + /* Lower the enclosed serial clause. + + Note that a serial clause can be nested right inside another, and in that + case the range we are pushing corresponds to all of them, so we have to + keep this into account when determining whether using a DSA serial + range. */ + + bool dsa = serial_clause_dsa (NEXT (SUB (p))); + bool local = NON_LOCAL (NEXT (SUB (p))) == NO_TABLE; + a68_push_serial_clause_range (clause_mode, dsa && local); + (void) a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_pop_serial_clause_range (); +} + +/* Lower an access clause. + + access clause : access symbol, joined module indication sequence, + enclosed clause. +*/ + +tree +a68_lower_access_clause (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *controlled_clause = NEXT (NEXT_SUB (p)); + + a68_push_range (MOID (p)); + + /* Call preludes of all ACCESSed modules. */ + for (NODE_T *q = SUB (p); q != NO_NODE; FORWARD (q)) + { + if (IS (q, MODULE_INDICANT)) + { + TAG_T *tag = a68_find_tag_global (TABLE (q), MODULE_SYMBOL, NSYMBOL (q)); + gcc_assert (tag != NO_TAG); + MOIF_T *moif = MOIF (tag); + gcc_assert (moif != NO_MOIF); + const char *prelude = PRELUDE (moif); + + tree prelude_decl = build_decl (UNKNOWN_LOCATION, FUNCTION_DECL, + get_identifier (prelude), + build_function_type_list (void_type_node, + void_type_node, + NULL_TREE)); + DECL_EXTERNAL (prelude_decl) = 1; + TREE_PUBLIC (prelude_decl) = 1; + a68_add_decl (prelude_decl); + a68_add_stmt (build_call_expr_loc (a68_get_node_location (q), + prelude_decl, 0)); + } + } + + /* Now the controlled clause. */ + tree controlled_clause_tree = a68_lower_tree (controlled_clause, ctx); + tree tmp = a68_lower_tmpvar ("accessed_clause_result%", + TREE_TYPE (controlled_clause_tree), + controlled_clause_tree); + + /* Call postludes of all ACCESSed modules. */ + for (NODE_T *q = SUB (p); q != NO_NODE; FORWARD (q)) + { + if (IS (q, MODULE_INDICANT)) + { + TAG_T *tag = a68_find_tag_global (TABLE (q), MODULE_SYMBOL, NSYMBOL (q)); + gcc_assert (tag != NO_TAG); + MOIF_T *moif = MOIF (tag); + gcc_assert (moif != NO_MOIF); + const char *postlude = POSTLUDE (moif); + + tree postlude_decl = build_decl (UNKNOWN_LOCATION, FUNCTION_DECL, + get_identifier (postlude), + build_function_type_list (void_type_node, + void_type_node, + NULL_TREE)); + DECL_EXTERNAL (postlude_decl) = 1; + TREE_PUBLIC (postlude_decl) = 1; + a68_add_decl (postlude_decl); + a68_add_stmt (build_call_expr_loc (a68_get_node_location (q), + postlude_decl, 0)); + } + } + + a68_add_stmt (tmp); + return a68_pop_range (); +} + +tree a68_lower_access_clauses (NODE_T *p, LOW_CTX_T ctx); + +/* Lower an enclosed clause. + + enclosed clause : parallel clause; closed clause; + collateral clause; conditional clause; + case clause; conformity clause; + loop clause ; access clause. +*/ + +tree +a68_lower_enclosed_clause (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_lower_tree (SUB (p), ctx); +} diff --git a/gcc/algol68/a68-low-coercions.cc b/gcc/algol68/a68-low-coercions.cc new file mode 100644 index 000000000000..b9e1acee9ce8 --- /dev/null +++ b/gcc/algol68/a68-low-coercions.cc @@ -0,0 +1,471 @@ +/* Lower Algol 68 coercions to GENERIC. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Lower a dereferencing coercion. */ +tree +a68_lower_dereferencing (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_low_deref (a68_lower_tree (SUB (p), ctx), SUB (p)); +} + +/* Lower an uniting coercion. */ + +tree +a68_lower_uniting (NODE_T *p, LOW_CTX_T ctx) +{ + tree coercend_tree = a68_lower_tree (SUB (p), ctx); + + if (MOID (p) == M_ROWS) + { + /* ROWS is a mode to which any ROW mode can be strongly coerced. It is + used as the mode of the second operand of the ELEMS, LWB and UPB + operators. The coercion is expressed in the parse tree via uniting. + This results in replacing the multiple with a "rows" value that + contains dimension and bounds information. */ + if (A68_ROW_TYPE_P (TREE_TYPE (coercend_tree))) + return a68_rows_value (coercend_tree); + else if (A68_UNION_TYPE_P (TREE_TYPE (coercend_tree))) + { + /* coercend_tree is expanded more than once below. */ + coercend_tree = save_expr (coercend_tree); + + /* Union of row modes. We should create a rows value for the currently + selected value. */ + a68_push_range (M_ROWS); + tree done_label = build_decl (UNKNOWN_LOCATION, + LABEL_DECL, + get_identifier ("done_label%"), + void_type_node); + DECL_CONTEXT (done_label) = a68_range_context (); + a68_add_decl (done_label); + a68_add_decl_expr (fold_build1 (DECL_EXPR, TREE_TYPE (done_label), done_label)); + tree rows = a68_lower_tmpvar ("rows%", CTYPE (M_ROWS), + a68_get_skip_tree (M_ROWS)); + tree coercend_overhead = a68_union_overhead (coercend_tree); + tree overhead = a68_lower_tmpvar ("overhead%", TREE_TYPE (coercend_overhead), + coercend_overhead); + int field_index = 0; + for (tree field = TYPE_FIELDS (TREE_TYPE (a68_union_cunion (coercend_tree))); + field; + field = DECL_CHAIN (field)) + { + a68_push_range (M_VOID); + { + /* Set rows% to the rows value computed from coercend_tree.FIELD, + which is of some multiple type. */ + a68_add_stmt (fold_build2 (MODIFY_EXPR, CTYPE (M_ROWS), + rows, + a68_rows_value (a68_union_alternative (coercend_tree, + field_index)))); + a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, done_label)); + a68_add_stmt (a68_get_skip_tree (M_VOID)); + } + tree process_entry = a68_pop_range (); + + /* IF overhead = field_index THEN rows% = rows_from_multiple FI */ + a68_add_stmt (fold_build3 (COND_EXPR, + a68_void_type, + fold_build2 (EQ_EXPR, + TREE_TYPE (overhead), + overhead, + build_int_cst (TREE_TYPE (overhead), field_index)), + process_entry, + a68_get_skip_tree (M_VOID))); + field_index += 1; + } + + /* This should not be reached. Emit run-time error. */ + { + unsigned int lineno = NUMBER (LINE (INFO (p))); + const char *filename_str = FILENAME (LINE (INFO (p))); + tree filename = build_string_literal (strlen (filename_str) + 1, + filename_str); + tree call = a68_build_libcall (A68_LIBCALL_UNREACHABLE, + void_type_node, 2, + filename, + build_int_cst (unsigned_type_node, lineno)); + a68_add_stmt (call); + } + + a68_add_stmt (build1 (LABEL_EXPR, void_type_node, done_label)); + a68_add_stmt (rows); + return a68_pop_range (); + } + else + { + debug_tree (TREE_TYPE (coercend_tree)); + gcc_assert (A68_ROWS_TYPE_P (TREE_TYPE (coercend_tree))); + return coercend_tree; + } + } + else if (IS_UNION (MOID (SUB (p)))) + { + /* We have to extract the value of the coercend union. */ + a68_push_range (MOID (p)); + { + MOID_T *coercend_mode = MOID (SUB (p)); + MOID_T *coercee_mode = MOID (p); + + /* Temporaries for the coercend's components. */ + tree coercend = a68_lower_tmpvar ("coercend%", TREE_TYPE (coercend_tree), coercend_tree); + tree cval = a68_union_cunion (coercend); + tree coverhead = a68_union_overhead (coercend); + tree coercend_value = a68_lower_tmpvar ("coercend_value%", TREE_TYPE (cval), cval); + tree coercend_overhead = a68_lower_tmpvar ("coercend_overhead%", sizetype, coverhead); + + /* Create the coercee. */ + tree coercee = a68_lower_tmpvar ("coercee%", + CTYPE (MOID (p)), + a68_get_skip_tree (MOID (p))); + tree coercee_value = a68_union_cunion (coercee); + + /* First translate overhead. This is crude, but it works. */ + int idx = 0; + tree coercee_overhead = size_zero_node; + while (EQUIVALENT (coercend_mode) != NO_MOID) + coercend_mode = EQUIVALENT (coercend_mode); + for (PACK_T *pack = PACK (coercend_mode); pack != NO_PACK; FORWARD (pack)) + { + coercee_overhead = fold_build3 (COND_EXPR, + sizetype, + fold_build2 (EQ_EXPR, + sizetype, + coercend_overhead, + size_int (idx)), + size_int (a68_united_mode_index (coercee_mode, MOID (pack))), + coercee_overhead); + idx++; + } + a68_add_stmt (a68_union_set_overhead (coercee, coercee_overhead)); + + /* Now copy over the value. This of course relies on the fact the + value of the coercend is smaller or of the same size than the value + of the built union. */ + a68_add_stmt (a68_lower_memcpy (fold_build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (coercee_value)), + coercee_value), + fold_build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (coercend_value)), + coercend_value), + size_in_bytes (TREE_TYPE (coercend_value)))); + a68_add_stmt (coercee); + } + return a68_pop_range (); + } + else + { + /* Produce a united mode one of whose component modes is the mode of the + coercend. */ + return a68_union_value (MOID (p), coercend_tree, MOID (SUB (p))); + } +} + +/* Lower a rowing coercion. */ + +tree +a68_lower_rowing (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *mode = MOID (p); + bool did_deref = false; + + /* If the primary is a REF, we need to dereference it to get the referred + value. */ + tree primary = NULL_TREE; + tree orig_primary = NULL_TREE; + MOID_T *target_mode = NO_MOID; + if (IS_REF (mode)) + { + gcc_assert (IS_REF (MOID (SUB (p)))); + did_deref = true; + target_mode = SUB (mode); + + a68_push_range (mode); + /* Note that we have to consolidate because we need a pointer to compare + to NIL below. */ + orig_primary = a68_lower_tmpvar ("orig_primary%", + CTYPE (MOID (SUB (p))), + a68_consolidate_ref (MOID (SUB (p)), + a68_lower_tree (SUB (p), ctx))); + primary = a68_low_deref (orig_primary, SUB (p)); + } + else + { + target_mode = mode; + primary = a68_lower_tree (SUB (p), ctx); + /* The primary gets expanded more than once below. */ + primary = save_expr (primary); + } + + /* Perform the rowing in the primary. */ + tree ssize_one_node = fold_convert (ssizetype, size_one_node); + tree rowed_primary = NULL_TREE; + if (DIM (DEFLEX (target_mode)) >= 2) + { + /* []A -> [,]A */ + + /* First determine the number of dimensions of the resulting + multiple. */ + tree primary_dimensions = a68_multiple_dimensions (primary); + gcc_assert (TREE_CODE (primary_dimensions) == INTEGER_CST); + int dim = tree_to_shwi (primary_dimensions) + 1; + + /* Compute bounds. */ + tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim); + tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim); + + lower_bounds[0] = ssize_one_node; + upper_bounds[0] = ssize_one_node; + for (int d = 1; d < dim; ++d) + { + lower_bounds[d] = a68_multiple_lower_bound (primary, ssize_int (d - 1)); + upper_bounds[d] = a68_multiple_upper_bound (primary, ssize_int (d - 1)); + } + + rowed_primary = a68_row_value (CTYPE (target_mode), dim, + a68_multiple_elements (primary), + a68_multiple_elements_size (primary), + lower_bounds, upper_bounds); + free (lower_bounds); + free (upper_bounds); + } + else + { + /* A -> []A */ + tree row_type = CTYPE (target_mode); + tree lower_bound = ssize_one_node; + tree upper_bound = ssize_one_node; + tree elements = (did_deref + ? orig_primary + : fold_build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (primary)), + build_constructor_va (build_array_type (TREE_TYPE (primary), + build_index_type (size_zero_node)), + 1, size_zero_node, primary))); + tree elements_type = a68_row_elements_type (row_type); + tree elements_size = size_in_bytes (elements_type); + rowed_primary = a68_row_value (row_type, 1, + elements, elements_size, + &lower_bound, &upper_bound); + } + + /* Build a ref if we rowed a ref. */ + if (did_deref) + { + tree pointer_type = build_pointer_type (TREE_TYPE (rowed_primary)); + rowed_primary = fold_build1 (ADDR_EXPR, pointer_type, rowed_primary); + /* Rowing NIL yields NIL. */ + rowed_primary = fold_build3_loc (a68_get_node_location (p), + COND_EXPR, + pointer_type, + fold_build2 (EQ_EXPR, + pointer_type, + fold_convert (pointer_type, orig_primary), + build_int_cst (pointer_type, 0)), + build_int_cst (pointer_type, 0), + rowed_primary); + a68_add_stmt (rowed_primary); + rowed_primary = a68_pop_range (); + } + + return rowed_primary; +} + +/* Lower a widening coercion. + + Widening allows the following conversions of mode: + + LONGSETY INT to LONGSETY REAL + LONGSETY REAL to LONGSETY COMPL + LONGSETY BITS to []BOOL + LONGSETY BYTES to []CHAR */ + +tree +a68_lower_widening (NODE_T *p, LOW_CTX_T ctx) +{ + if (MOID (p) == M_REAL + || MOID (p) == M_LONG_REAL + || MOID (p) == M_LONG_LONG_REAL) + { + return convert_to_real (CTYPE (MOID (p)), a68_lower_tree (SUB (p), ctx)); + } + if (MOID (p) == M_COMPLEX + || MOID (p) == M_LONG_COMPLEX + || MOID (p) == M_LONG_LONG_COMPLEX) + { + return a68_complex_widen_from_real (MOID (p), + a68_lower_tree (SUB (p), ctx)); + } + else if (MOID (p) == M_ROW_BOOL) + { + /* Widen a LONGSETY BITS to a row of BOOLs. */ + tree coercend = a68_lower_tree (SUB (p), ctx); + tree coercend_type = TREE_TYPE (coercend); + HOST_WIDE_INT bits_size = int_size_in_bytes (coercend_type); + gcc_assert (bits_size != -1); + bits_size = bits_size * 8; + + tree pointer_to_bool_type = build_pointer_type (a68_bool_type); + a68_push_range (M_ROW_BOOL); + /* First allocate space for the elements. */ + tree elements = a68_lower_tmpvar ("elements%", + pointer_to_bool_type, + a68_lower_alloca (a68_bool_type, + fold_build2 (MULT_EXPR, + sizetype, + size_int (bits_size), + size_in_bytes (a68_bool_type)))); + + /* Set the elements, each element is a BOOL which is TRUE if the + corresponding bit in the coercend is set, FALSE otherwise. */ + tree coercend_one_node = build_int_cst (coercend_type, 1); + coercend = save_expr (coercend); + for (HOST_WIDE_INT bit = 0; bit < bits_size; ++bit) + { + tree offset = fold_build2 (MULT_EXPR, sizetype, + size_int (bit), size_in_bytes (a68_bool_type)); + tree bit_set = fold_convert (a68_bool_type, + fold_build2 (BIT_AND_EXPR, coercend_type, + fold_build2 (RSHIFT_EXPR, coercend_type, + coercend, + build_int_cst (coercend_type, + bits_size - 1 - bit)), + coercend_one_node)); + + a68_add_stmt (fold_build2 (MODIFY_EXPR, + a68_bool_type, + fold_build2 (MEM_REF, + a68_bool_type, + fold_build2 (POINTER_PLUS_EXPR, + pointer_to_bool_type, + elements, + offset), + fold_convert (pointer_to_bool_type, + integer_zero_node)), + bit_set)); + } + + /* Create multiple. */ + tree lower_bound = ssize_int (1); + tree upper_bound = ssize_int (bits_size); + tree elements_size = fold_build2 (MULT_EXPR, sizetype, + size_int (bits_size), + size_in_bytes (a68_bool_type)); + tree multiple = a68_row_value (CTYPE (M_ROW_BOOL), 1 /* dim */, + elements, elements_size, + &lower_bound, &upper_bound); + a68_add_stmt (multiple); + return a68_pop_range (); + } + else + { + fatal_error (a68_get_node_location (p), + "cannot do widening from %s to %s", + a68_moid_to_string (MOID (SUB (p)), MOID_ERROR_WIDTH, SUB (p)), + a68_moid_to_string (MOID (p), MOID_ERROR_WIDTH, p)); + gcc_unreachable (); + } +} + +/* Lower a voiding coercion. + + The voiding lowers into a compound expression with the voided expression + (for side-effects) and returns EMPTY. */ + +tree +a68_lower_voiding (NODE_T *p, LOW_CTX_T ctx) +{ + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + a68_void_type, + a68_lower_tree (SUB (p), ctx), + a68_get_empty ()); +} + +/* Lower a proceduring coercion. + + proceduring : jump. + + In the Revised language only jump statements can be procedured. The + coercion results in a new function whose body is the jump instruction. */ + +tree +a68_lower_proceduring (NODE_T *p, LOW_CTX_T ctx) +{ + tree jump = a68_lower_tree (SUB (p), ctx); + + tree procedured_goto = a68_make_anonymous_routine_decl (MOID (p)); + a68_add_decl (procedured_goto); + a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p), + DECL_EXPR, + TREE_TYPE (procedured_goto), + procedured_goto)); + announce_function (procedured_goto); + + a68_push_function_range (procedured_goto, CTYPE (SUB (MOID (p)))); + a68_pop_function_range (jump); + return fold_build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (procedured_goto)), + procedured_goto); +} + +/* Lower a deproceduring coercion. + The deproceduring lowers into a call expression. */ + +tree +a68_lower_deproceduring (NODE_T *p, LOW_CTX_T ctx) +{ + tree func = a68_lower_tree (SUB (p), ctx); + + if (POINTER_TYPE_P (TREE_TYPE (func))) + { + if (TREE_CODE (func) == ADDR_EXPR) + func = TREE_OPERAND (func, 0); + else + func = fold_build1 (INDIRECT_REF, + TREE_TYPE (TREE_TYPE (func)), + func); + } + + return build_call_expr_loc (a68_get_node_location (p), func, 0); +} diff --git a/gcc/algol68/a68-low-complex.cc b/gcc/algol68/a68-low-complex.cc new file mode 100644 index 000000000000..aed1c3c3dab6 --- /dev/null +++ b/gcc/algol68/a68-low-complex.cc @@ -0,0 +1,141 @@ +/* Lowering routines for all things related to COMPL values. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Build a new COMPL value with real part RE and imaginary part IM, of mode + MODE. */ + +tree +a68_complex_i (MOID_T *mode, tree re, tree im) +{ + tree compl_type = CTYPE (mode); + + tree re_field = TYPE_FIELDS (compl_type); + tree im_field = TREE_CHAIN (re_field); + return build_constructor_va (CTYPE (mode), 2, + re_field, re, + im_field, im); +} + +/* Given a COMPL value Z, get its real part. */ + +tree +a68_complex_re (tree z) +{ + tree re_field = TYPE_FIELDS (TREE_TYPE (z)); + return fold_build3 (COMPONENT_REF, TREE_TYPE (re_field), + z, re_field, NULL_TREE); +} + +tree +a68_complex_im (tree z) +{ + tree im_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (z))); + return fold_build3 (COMPONENT_REF, TREE_TYPE (im_field), + z, im_field, NULL_TREE); +} + +/* Return the conjugate of the given complex Z of mode MODE. */ + +tree +a68_complex_conj (MOID_T *mode, tree z) +{ + tree re_field = TYPE_FIELDS (TREE_TYPE (z)); + tree complex_type = build_complex_type (TREE_TYPE (re_field), false /* named */); + + z = save_expr (z); + tree complex = fold_build2 (COMPLEX_EXPR, complex_type, + a68_complex_re (z), a68_complex_im (z)); + tree conj = fold_build1 (CONJ_EXPR, TREE_TYPE (complex), complex); + + return a68_complex_i (mode, + fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (z)), conj), + fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (z)), conj)); +} + +/* Widen a real R to a complex of mode MODE. */ + +tree +a68_complex_widen_from_real (MOID_T *mode, tree r) +{ + tree compl_type = CTYPE (mode); + gcc_assert (compl_type != NULL_TREE); + + /* Sanity check. */ + if (mode == M_COMPLEX) + gcc_assert (TREE_TYPE (r) == a68_real_type); + else if (mode == M_LONG_COMPLEX) + gcc_assert (TREE_TYPE (r) == a68_long_real_type); + else if (mode == M_LONG_LONG_COMPLEX) + gcc_assert (TREE_TYPE (r) == a68_long_long_real_type); + else + gcc_unreachable (); + + a68_push_range (mode); + tree res = a68_lower_tmpvar ("compl%", compl_type, + a68_get_skip_tree (mode)); + + /* Look for the "re" field. */ + tree field_id = a68_get_mangled_identifier ("re"); + tree field = NULL_TREE; + for (tree f = TYPE_FIELDS (compl_type); f; f = DECL_CHAIN (f)) + { + if (field_id == DECL_NAME (f)) + { + field = f; + break; + } + } + gcc_assert (field != NULL_TREE); + + /* Set it to the given real value. */ + a68_add_stmt (fold_build2 (MODIFY_EXPR, + TREE_TYPE (r), + fold_build3 (COMPONENT_REF, + TREE_TYPE (field), + res, field, + NULL_TREE), + r)); + a68_add_stmt (res); + return a68_pop_range (); +} diff --git a/gcc/algol68/a68-low-decls.cc b/gcc/algol68/a68-low-decls.cc new file mode 100644 index 000000000000..74a93f71dde8 --- /dev/null +++ b/gcc/algol68/a68-low-decls.cc @@ -0,0 +1,696 @@ +/* Lower mode, identity and variable declarations to GENERIC. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Lower one or more mode declarations. + + mode declaration : mode symbol, defining indicant, + equals symbol, declarer; + mode symbol, defining indicant, + equals symbol, void symbol; + mode declaration, comma symbol, + defining indicant, equals symbol, declarer; + mode declaration, comma symbol, + defining indicant, equals symbol, void symbol. + + Each mode declaration lowers into a TYPE_DECL, which are chained in the + current block. This function returns void_node. + + Note that the defining indicant is already annotated with the declared mode + so there is no need to go hunting for the declarer in the subtree. */ + +tree +a68_lower_mode_declaration (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *defining_indicant = NO_NODE; + + if (IS (SUB (p), MODE_DECLARATION)) + { + a68_lower_tree (SUB (p), ctx); + defining_indicant = NEXT (NEXT (SUB (p))); + } + else + { + gcc_assert (IS (SUB (p), MODE_SYMBOL)); + defining_indicant = NEXT (SUB (p)); + } + + /* Create a TYPE_DECL declaration for the defined mode and chain it in the + current block. */ + tree ctype = CTYPE (MOID (defining_indicant)); + tree decl_name = a68_get_mangled_indicant (NSYMBOL (defining_indicant), + ctx.module_definition_name); + tree decl = build_decl (a68_get_node_location (p), + TYPE_DECL, decl_name, ctype); + SET_DECL_ASSEMBLER_NAME (decl, decl_name); + TREE_PUBLIC (decl) = 1; + TYPE_CONTEXT (ctype) = DECL_CONTEXT (decl); + TYPE_NAME (ctype) = decl; + TYPE_STUB_DECL (ctype) = decl; + a68_add_decl (decl); + + return void_node; +} + +/* Lower one or more variable declarations. + + variable declaration : qualifier, declarer, defining identifier, + assign symbol, unit; + qualifier, declarer, defining identiifer; + qualifier, declarer, defining identifier; + declarer, defining identifier, assign symbol, unit; + declarer, defining identifier; + variable declaration, comma symbol, + defining identifier, assign symbol, unit; + variable declaration, comma symbol, + defining identifier; + + Each variable declaration lowers into a VAR_DECL, which are chained in the + current block. This function also returns an expression with code to + initialize the variable in case there is an initializer. + + If the variable declaration implies a LOC generator then the VAR_DECL for REF + AMODE declares a value of type CTYPE (AMODE). This is an optimization in + order to avoid indirect addressing. If the variable declaration implies a + HEAP generator, however, then the VAR_DECL declares a value of type pointer + to CTYPE (AMODE0. In this later case no optimization is possible and it has + exactly the same effect than an identity declaration `REF AMODE + defining_identifier = HEAP AMODE'. + + Note that the defining identifier is annotated with its mode, so there is no + need to go hunting for the declarer in the subtree. */ + +tree +a68_lower_variable_declaration (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *defining_identifier, *unit; + NODE_T *declarer = NO_NODE; + + tree sub_expr = NULL_TREE; + + if (IS (SUB (p), VARIABLE_DECLARATION)) + { + LOW_CTX_T new_ctx = ctx; + new_ctx.declarer = &declarer; + sub_expr = a68_lower_tree (SUB (p), new_ctx); + defining_identifier = NEXT (NEXT (SUB (p))); + } + else if (IS (SUB (p), QUALIFIER)) + { + /* The qualifier determines what kind of generator is used in the + variable declaration. This is already annotated in the tax entry for + the definining identifier. */ + declarer = NEXT (SUB (p)); + defining_identifier = NEXT (NEXT (SUB (p))); + } + else if (IS (SUB (p), DECLARER)) + { + declarer = SUB (p); + defining_identifier = NEXT (SUB (p)); + } + else + gcc_unreachable (); + + /* Communicate declarer upward. */ + if (ctx.declarer != NULL) + *ctx.declarer = declarer; + + /* See if this variable declaration features an initializing unit. */ + if (NEXT (defining_identifier) != NO_NODE) + { + gcc_assert (NEXT (defining_identifier) + && IS (NEXT (defining_identifier), ASSIGN_SYMBOL) + && NEXT (NEXT (defining_identifier))); + unit = NEXT (NEXT (defining_identifier)); + } + else + unit = NO_NODE; + + /* If not done already by an applied identifier in lower_identifier, create a + declaration for the defined entity and chain it in the current block. The + declaration has an initial value of SKIP. */ + tree var_decl = TAX_TREE_DECL (TAX (defining_identifier)); + if (var_decl == NULL_TREE) + { + var_decl = a68_make_variable_declaration_decl (defining_identifier, + ctx.module_definition_name); + TAX_TREE_DECL (TAX (defining_identifier)) = var_decl; + } + + /* If the variable declaration is in a public range then add the declaration + to the publicized declarations list. Otherwise chain the declaration in + the proper block and bind it. */ + if (PUBLIC_RANGE (TABLE (TAX (defining_identifier)))) + vec_safe_push (A68_MODULE_DEFINITION_DECLS, var_decl); + else + a68_add_decl (var_decl); + + /* Add a decl_expr in the current range. */ + a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p), + DECL_EXPR, + TREE_TYPE (var_decl), + var_decl)); + + tree expr = NULL_TREE; + + /* Allocate memory for the declared variables. + + This is done differently depending on the sample generator used in the + variable declaration, be it explicit or the default LOC. + + If the LOC generator is used and the value has no rows, it means it + doesnt' need a dynamic part and the var_decl created above is not a + pointer. So the memory has been allocated already and there is nothing + else to do at this point. + + If the HEAP generator is used, or if the generated value has rows, it + means the var_decl created above is a pointer. We need to run a generator + to get the memory with descriptors filled in. Note that we cannot set the + pointer as the initial of the var_decl because the bouns in the actual + declarer shall be elaborated at the point of the code where the + declaration appears, not at the beginning of its reach. Note that the + mode of the declarer will be always a REF, since this is a varaible + declaration: the referred mode is what we pass to the a68_low_generator. + + If the STATIC generator is used, the var_decl created above is not a + pointer. The static part of the value has been already allocated, and if + the value needs a dynamic part (i.e. if it has rows) then it is allocated + using the heap. Note how we allocate the whole value (including the + static part) and then we copy if over the var_decl. */ + + if (HEAP (TAX (defining_identifier)) == STATIC_SYMBOL) + { + if (HAS_ROWS (SUB (MOID (defining_identifier)))) + { + expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (var_decl), + var_decl, + fold_build1 (INDIRECT_REF, + TREE_TYPE (var_decl), + a68_low_generator (declarer, + SUB (MOID (declarer)), + true /* heap */, + ctx))); + } + } + else + { + bool heap = HEAP (TAX (defining_identifier)) == HEAP_SYMBOL; + if (heap || HAS_ROWS (SUB (MOID (defining_identifier)))) + { + gcc_assert(IS_REF (MOID (declarer))); + expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (var_decl), + var_decl, + a68_low_generator (declarer, + SUB (MOID (declarer)), + heap, ctx)); + } + } + + if (unit != NO_NODE) + { + tree rhs = a68_lower_tree (unit, ctx); + tree assignation = a68_low_assignation (p, + var_decl, MOID (defining_identifier), + rhs, MOID (unit)); + if (expr != NULL_TREE) + expr = fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (assignation), + expr, assignation); + else + expr = assignation; + } + + /* Tail in a compound expression with sub declarations, if any. */ + if (sub_expr != NULL_TREE) + { + if (expr != NULL_TREE) + expr = fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (var_decl), + sub_expr, + expr); + else + expr = sub_expr; + } + + return expr; +} + +/* Lower one or more identity declarations. + + identity declaration : declarer, defining identifier, + equals symbol, unit; + identity declaration, comma symbol, + defining identifier, equals symbol, unit; + + Each identity declaration lowers into a declaration. + + VAR_DECL with both TREE_CONSTANT and TREE_READONLY set. Note that we cannot + use CONST_DECL because of two reasons. First, CONST_DECL only works for + scalar modes. Second, since Algol 68 allows usage of identifiers before + they get declared, each declaration adds a declaration with a SKIP initial + value, and also an assignation of the value at the declaration point. This + function also returns an expression with code to initialize the declared + constant. */ + +tree +a68_lower_identity_declaration (NODE_T *p, LOW_CTX_T ctx) +{ + tree unit_tree = NULL_TREE; + tree sub_expr = NULL_TREE; + + /* Note that the formal declarer in the construct is not used. This is + because it is already reflected in the mode of the identity + declaration. */ + + NODE_T *defining_identifier; + if (IS (SUB (p), IDENTITY_DECLARATION)) + { + sub_expr = a68_lower_tree (SUB (p), ctx); + defining_identifier = NEXT (NEXT (SUB (p))); + } + else if (IS (SUB (p), DECLARER)) + { + defining_identifier = NEXT (SUB (p)); + } + else + gcc_unreachable (); + + NODE_T *unit = NEXT (NEXT (defining_identifier)); + + /* If not done already by an applied identifier in lower_identifier, create a + declaration for the defined entity and chain it in the current block. The + declaration has an initial value of SKIP. */ + tree id_decl = TAX_TREE_DECL (TAX (defining_identifier)); + if (id_decl == NULL_TREE) + { + id_decl = a68_make_identity_declaration_decl (defining_identifier, + ctx.module_definition_name); + TAX_TREE_DECL (TAX (defining_identifier)) = id_decl; + } + + /* If the identity declaration is in a public range then add the declaration + to the publicized declarations list. Otherwise chain the declaration in + the proper block and bind it. */ + if (PUBLIC_RANGE (TABLE (TAX (defining_identifier)))) + vec_safe_push (A68_MODULE_DEFINITION_DECLS, id_decl); + else + a68_add_decl (id_decl); + + /* Prepare the DECL_EXPR. */ + a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p), + DECL_EXPR, + TREE_TYPE (id_decl), + id_decl)); + + unit_tree = a68_lower_tree (unit, ctx); + unit_tree = a68_consolidate_ref (MOID (unit), unit_tree); + tree expr = a68_low_ascription (MOID (defining_identifier), + id_decl, unit_tree); + + /* If the ascribed value is constant, mark the declaration as constant. */ + TREE_CONSTANT (id_decl) = TREE_CONSTANT (unit_tree); + + /* Tail in a compound expression with sub declarations, if any. */ + if (sub_expr != NULL_TREE) + { + if (expr != NULL_TREE) + expr = fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (id_decl), + sub_expr, + expr); + else + expr = sub_expr; + } + + return expr; +} + +/* Lower a declarer. + + declarer : indicant; + longety, indicant; + shortety, indicant; + flex symbol, declarer; + flex symbol, bounds, declarer; + flex symbol, formal bounds, declarer; + bounds, declarer; + formal bounds, declarer; + ref symbol, declarer; + struct symbol, structure pack; + union symbol, union pack; + proc symbol, declarer; + proc symbol, formal declarers, declarer; + proc symbol, formal declarers, void symbol; + + + This handler lowes a DECLARER tree into an expression that evaluates to the + size of the actual declarer. Note that this is a self-contained handler and + it does traverse the sub-tree on its own. */ + +tree +a68_lower_declarer (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + gcc_unreachable (); +} + +/* Lower a declaration list. + + declaration list : mode declaration; + priority declaration; + brief operator declaration; + operator declaration; + identity declaration; + procedure declaration; + procedure variable declaration; + variable declaration; + environ name; + declaration list, comma symbol, declaration list; + + Process the subtree, which produces declarations associated with the current + context and which get added to the current block. The list of declarations + gets returned in nested compound expressions. */ + +tree +a68_lower_declaration_list (NODE_T *p, LOW_CTX_T ctx) +{ + if (IS (SUB (p), DECLARATION_LIST)) + { + tree left = a68_lower_tree (SUB (p), ctx); + tree right = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + /* The trees `left' and `right' may be NULL_TREE if the declarations + under them didn't have an initializing expression. In that case, + replace them by nops which are removed at fold time. This is ugly, + but works. */ + if (left == NULL_TREE) + left = integer_zero_node; + if (right == NULL_TREE) + right = integer_zero_node; + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + void_type_node, + left, right); + } + else + return a68_lower_tree (SUB (p), ctx); +} + +/* Lower a procedure declaration. + + procedure declaration : proc symbol, defining identifier, assign symbol, routine text; + procedure declaration, comma symbol, + defining identifier, equals symbol, routine text. + + Each procedure declaration lowers into a declaration. */ + +tree +a68_lower_procedure_declaration (NODE_T *p, LOW_CTX_T ctx) +{ + tree sub_func_decl = NULL_TREE; + NODE_T *defining_identifier; + if (IS (SUB (p), PROCEDURE_DECLARATION)) + { + sub_func_decl = a68_lower_tree (SUB (p), ctx); + defining_identifier = NEXT (NEXT (SUB (p))); + } + else if (IS (SUB (p), PROC_SYMBOL)) + { + defining_identifier = NEXT (SUB (p)); + } + else + gcc_unreachable (); + + NODE_T *routine_text = NEXT (NEXT (defining_identifier)); + + /* Lower the routine text to get a function decl. */ + ctx.proc_decl_identifier = defining_identifier; + ctx.proc_decl_operator = false; + tree func_decl = a68_lower_tree (routine_text, ctx); + + /* Tail in a compound expression with sub declarations, if any. */ + if (sub_func_decl != NULL_TREE) + { + if (func_decl != NULL_TREE) + func_decl = fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (func_decl), + sub_func_decl, + func_decl); + else + func_decl = sub_func_decl; + } + + return func_decl; +} + +/* Lower a procedure variable declaration. + + procedure variable declaration + : proc symbol, defining identifier, assign symbol, routine text; + qualifier, proc symbol, defining identifier, assign symbol, routine text; + procedure variable declaration, comma symbol, defining identiier, assign symbol, routine text. + + This lowers into the declaration of a VAR_DECL which is a pointer to the + free standing routine yielded by the routine text. */ + +tree +a68_lower_procedure_variable_declaration (NODE_T *p, LOW_CTX_T ctx) +{ + tree sub_decl = NULL_TREE; + NODE_T *defining_identifier; + if (IS (SUB (p), PROCEDURE_VARIABLE_DECLARATION)) + { + sub_decl = a68_lower_tree (SUB (p), ctx); + defining_identifier = NEXT (NEXT (SUB (p))); + } + else if (IS (SUB (p), PROC_SYMBOL)) + defining_identifier = NEXT (SUB (p)); + else if (IS (SUB (p), QUALIFIER)) + /* The qualifier determines what kind of generator is used in the variable + declaration. This is already annotated in the tax entry for the + definining identifier. */ + defining_identifier = NEXT (NEXT (SUB (p))); + else + gcc_unreachable (); + NODE_T *routine_text = NEXT (NEXT (defining_identifier)); + + /* The routine text lowers into a pointer to function. */ + ctx.proc_decl_identifier = NO_NODE; + ctx.proc_decl_operator = false; + tree routine = a68_lower_tree (routine_text, ctx); + + /* Create a declaration for the proc variable, if that hasn't been done + already. */ + tree decl = TAX_TREE_DECL (TAX (defining_identifier)); + if (decl == NULL_TREE) + { + decl = a68_make_variable_declaration_decl (defining_identifier, + ctx.module_definition_name); + TAX_TREE_DECL (TAX (defining_identifier)) = decl; + } + + /* If the variable declaration is in a public range then add the declaration + to the publicized declarations list. Otherwise chain the declaration in + the proper block and bind it. */ + if (PUBLIC_RANGE (TABLE (TAX (defining_identifier)))) + vec_safe_push (A68_MODULE_DEFINITION_DECLS, decl); + else + a68_add_decl (decl); + + /* Add a decl_expr in the current range. */ + a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p), + DECL_EXPR, + TREE_TYPE (decl), + decl)); + /* Initialize. + + If the variable is heap allocated then the var_decl created above is a + pointer. We don't allocate the actual function on the heap, because the + scope of procedures is not global. */ + bool heap = HEAP (TAX (defining_identifier)) == HEAP_SYMBOL; + a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (decl), decl, + heap ? fold_build1 (ADDR_EXPR, TREE_TYPE (decl), + routine) : routine)); + + /* Tail in a compound expression with sub declarations, if any. */ + if (sub_decl != NULL_TREE) + { + if (decl != NULL_TREE) + decl = fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (decl), + sub_decl, + decl); + else + decl = sub_decl; + } + + return decl; +} + +/* Lower a priority declaration. + + This lowers to nothing. Operator priority is fully handled by the parser in + order to decide which operator declaration corresponds to each applied + operator. */ + +tree +a68_lower_priority_declaration (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return NULL_TREE; +} + +/* Lower a brief operator declaration. + + brief operator declaration + : op symbol, defining operator, equals symbol, routine text; + brief operator declaration, comma symbol, defining operator, equals symbol, routine text. + + The declarations low in a series of FUNCTION_DECLs, one per declared + operator. */ + +tree +a68_lower_brief_operator_declaration (NODE_T *p, LOW_CTX_T ctx) +{ + tree sub_func_decl = NULL_TREE; + NODE_T *defining_operator; + + if (IS (SUB (p), BRIEF_OPERATOR_DECLARATION)) + { + sub_func_decl = a68_lower_tree (SUB (p), ctx); + defining_operator = NEXT (NEXT (SUB (p))); + } + else + defining_operator = NEXT (SUB (p)); + NODE_T *routine_text = NEXT (NEXT (defining_operator)); + + /* Lower the routine text to get a function decl. */ + ctx.proc_decl_identifier = defining_operator; + ctx.proc_decl_operator = true; + tree func_decl = a68_lower_tree (routine_text, ctx); + + /* Tail in a compound expression with sub declarations, if any. */ + if (sub_func_decl != NULL_TREE) + { + if (func_decl != NULL_TREE) + func_decl = fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (func_decl), + sub_func_decl, + func_decl); + else + func_decl = sub_func_decl; + } + + return func_decl; +} + +/* Lower an operator declaration. + + operator declaration : operator plan, defining operator, equals symbol, unit; + operator declaration, comma symbol, defining operator, equals symbol, unit. + + Each operator declaration lowers into a declaration. */ + +tree +a68_lower_operator_declaration (NODE_T *p, LOW_CTX_T ctx) +{ + tree sub_op_decl = NULL_TREE; + NODE_T *defining_operator; + + if (IS (SUB (p), OPERATOR_DECLARATION)) + { + sub_op_decl = a68_lower_tree (SUB (p), ctx); + defining_operator = NEXT (NEXT (SUB (p))); + } + else + defining_operator = NEXT (SUB (p)); + NODE_T *unit = NEXT (NEXT (defining_operator)); + + tree op_decl = TAX_TREE_DECL (TAX (defining_operator)); + if (op_decl == NULL_TREE) + { + op_decl = a68_make_identity_declaration_decl (defining_operator, + ctx.module_definition_name, + true /* indicant */); + TAX_TREE_DECL (TAX (defining_operator)) = op_decl; + } + + /* If the identity declaration is in a public range then add the declaration + to the publicized declarations list. Otherwise chain the declaration in + the proper block and bind it. */ + if (PUBLIC_RANGE (TABLE (TAX (defining_operator)))) + vec_safe_push (A68_MODULE_DEFINITION_DECLS, op_decl); + else + a68_add_decl (op_decl); + + /* Prepare the DECL_EXPR. */ + a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p), + DECL_EXPR, + TREE_TYPE (op_decl), + op_decl)); + /* Initialize. */ + a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (op_decl), op_decl, + a68_lower_tree (unit, ctx))); + + /* Tail in a compound expression with sub declarations, if any. */ + if (sub_op_decl != NULL_TREE) + { + if (op_decl != NULL_TREE) + op_decl = fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (op_decl), + sub_op_decl, + op_decl); + else + op_decl = sub_op_decl; + } + + return op_decl; +} diff --git a/gcc/algol68/a68-low-generator.cc b/gcc/algol68/a68-low-generator.cc new file mode 100644 index 000000000000..5c4d65569b37 --- /dev/null +++ b/gcc/algol68/a68-low-generator.cc @@ -0,0 +1,533 @@ +/* Lower generators. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + + +typedef tree (*allocator_t) (tree, tree); + +/* Lower to code that fill in BOUNDS and elements pointers in the given buffer + pointed by BUFFER at offset OFFSET according to the mode MODE, and evals to + BUFFER. */ + +static tree +fill_in_buffer (tree buffer, tree offset, tree_stmt_iterator *bounds, MOID_T *m, + allocator_t allocator) +{ + tree filler = NULL_TREE; + tree type = CTYPE (m); + tree pointer_type = build_pointer_type (type); + + a68_push_stmt_list (M_VOID); + + if (m == M_INT || m == M_BOOL || m == M_CHAR || m == M_REAL || IS_REF (m)) + { + tree val_address = fold_build2 (POINTER_PLUS_EXPR, pointer_type, buffer, offset); + tree init_val = a68_get_skip_tree (m); + tree modify = fold_build2 (MODIFY_EXPR, + type, + fold_build1 (INDIRECT_REF, type, val_address), + init_val); + a68_add_stmt (modify); + } + else if (!HAS_ROWS (m)) + { + /* This mode has no rows. We can just fill in with zeroes, which + translates into SKIP values for all possibly contained types. */ + tree call = builtin_decl_explicit (BUILT_IN_MEMSET); + call = build_call_expr_loc (UNKNOWN_LOCATION, call, 3, + buffer, + integer_zero_node, + fold_convert (sizetype, size_in_bytes (CTYPE (m)))); + a68_add_stmt (call); + } + else if (m == M_STRING) + { + /* Strings are rows but handled especially as they are created empty and + don't feature bounds in the formal declarer. */ + + /* First the descriptor. */ + tree pointer_byte_size = size_int (POINTER_SIZE / BITS_PER_UNIT); + tree lb_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node, + fold_build1 (INDIRECT_REF, ssizetype, lb_address), + ssize_int (1))); + offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size); + tree ub_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node, + fold_build1 (INDIRECT_REF, ssizetype, ub_address), + ssize_int (0))); + offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size); + tree stride_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node, + fold_build1 (INDIRECT_REF, sizetype, stride_address), + size_in_bytes (a68_char_type))); + + /* The data is an empty string, i.e NULL. */ + offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size); + tree elems_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node, + fold_build1 (INDIRECT_REF, build_pointer_type (a68_char_type), + elems_address), + build_int_cst (build_pointer_type (a68_char_type), 0))); + + /* The size of the elements is zero. */ + offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size); + tree elems_size_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node, + fold_build1 (INDIRECT_REF, build_pointer_type (a68_char_type), + elems_size_address), + size_zero_node)); + } + else if (A68_ROW_TYPE_P (type)) + { + /* If the row mode is flexible we can deflex it now: these also must have + bounds specified for them, with the only exception of strings/flexible + rows of chars, which are handled above. Note we cannot use DEFLEXED + here because that contains the fully deflexed mode. For example, + DEFLEXED returns [][]INT for FLEX[]FLEX[]INT, and we want []FLEX[]INT + instead. */ + if (IS_FLEX (m)) + m = SUB (m); + + /* Consume two bounds from BOUNDS for each dimension and patch them at + their right offsets. Note that we have to process from upper + dimension to lower dimension so we can calculate the stride as we + go. */ + size_t dim = DIM (m); + + /* Collect lower and upper bounds and calculate the number of elements of + the multiple. */ + tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim); + tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim); + tree num_elems = NULL_TREE; + for (size_t i = 0; i < dim; ++i) + { + /* Note we have to convert the bounds from CTYPE(M_INT) to + ssizetype. */ + lower_bounds[i] = fold_convert (ssizetype, save_expr (tsi_stmt (*bounds))); + tsi_next (bounds); + upper_bounds[i] = fold_convert (ssizetype, save_expr (tsi_stmt (*bounds))); + tsi_next (bounds); + + tree dim_num_elems + = fold_build2 (PLUS_EXPR, sizetype, + fold_convert (sizetype, + fold_build2 (MINUS_EXPR, ssizetype, + upper_bounds[i], lower_bounds[i])), + size_one_node); + dim_num_elems = fold_build3 (COND_EXPR, + sizetype, + fold_build2 (LT_EXPR, ssizetype, + upper_bounds[i], lower_bounds[i]), + size_zero_node, + dim_num_elems); + if (num_elems == NULL_TREE) + num_elems = dim_num_elems; + else + num_elems = fold_build2 (MULT_EXPR, sizetype, num_elems, dim_num_elems); + } + + /* Calculate strides. */ + tree *strides = (tree *) xmalloc (sizeof (tree) * dim); + a68_multiple_compute_strides (type, dim, lower_bounds, upper_bounds, strides); + + /* Now emit instructions to patch the bounds and strides. */ + tree pointer_byte_size = size_int (POINTER_SIZE / BITS_PER_UNIT); + for (size_t i = 0; i < dim; ++i) + { + /* Lower bound. */ + tree lb_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + a68_add_stmt (fold_build2 (MODIFY_EXPR, + void_type_node, + fold_build1 (INDIRECT_REF, ssizetype, lb_address), + lower_bounds[i])); + /* Upper bound. */ + offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size); + tree ub_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + a68_add_stmt (fold_build2 (MODIFY_EXPR, + void_type_node, + fold_build1 (INDIRECT_REF, ssizetype, ub_address), + upper_bounds[i])); + /* Stride. */ + offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size); + tree stride_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + a68_add_stmt (fold_build2 (MODIFY_EXPR, + void_type_node, + fold_build1 (INDIRECT_REF, sizetype, stride_address), + strides[i])); + offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size); + } + free (lower_bounds); + free (upper_bounds); + free (strides); + + /* Now allocate space for the elements. */ + MOID_T *elem_mode = SUB (m); + tree elem_size = fold_convert (sizetype, size_in_bytes (CTYPE (elem_mode))); + tree elems_size = save_expr (fold_build2 (MULT_EXPR, sizetype, elem_size, num_elems)); + tree elemsptr = (*allocator) (CTYPE (elem_mode), elems_size); + elemsptr = save_expr (elemsptr); + + /* And initialize them. */ + if (elem_mode == M_INT || elem_mode == M_BOOL || elem_mode == M_CHAR + || elem_mode == M_REAL || IS_REF (elem_mode)) + { + /* Memsetting the buffer with either zeroes or ones satisfies the + SKIP value for these modes. */ + tree call = builtin_decl_explicit (BUILT_IN_MEMSET); + call = build_call_expr_loc (UNKNOWN_LOCATION, call, 3, + elemsptr, + integer_zero_node, + elems_size); + a68_add_stmt (call); + } + else + { + /* Recurse in a loop to fill in elements. */ + a68_push_range (NULL); + tree num_elems_var = a68_lower_tmpvar ("numelems%", size_type_node, + num_elems); + tree index = a68_lower_tmpvar ("index%", size_type_node, size_zero_node); + tree elems_var = a68_lower_tmpvar ("elems%", TREE_TYPE (elemsptr), + elemsptr); + tree elem_offset = a68_lower_tmpvar ("elem_offset%", size_type_node, + size_zero_node); + + /* Begin of loop body. */ + a68_push_range (NULL); + a68_add_stmt (fold_build1 (EXIT_EXPR, + void_type_node, + fold_build2 (EQ_EXPR, + size_type_node, + index, num_elems_var))); + a68_add_stmt (fill_in_buffer (elems_var, elem_offset, bounds, elem_mode, + allocator)); + /* Increase elem_offset */ + a68_add_stmt (fold_build2 (MODIFY_EXPR, sizetype, + elem_offset, + fold_build2 (PLUS_EXPR, sizetype, + elem_offset, elem_size))); + /* index++ */ + a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, + size_type_node, + index, size_one_node)); + tree loop_body = a68_pop_range (); + /* End of loop body. */ + a68_add_stmt (fold_build1 (LOOP_EXPR, + void_type_node, + loop_body)); + a68_add_stmt (a68_pop_range ()); + } + + /* Patch the elements% field. */ + tree elems_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + a68_add_stmt (fold_build2 (MODIFY_EXPR, + void_type_node, + fold_build1 (INDIRECT_REF, + build_pointer_type (CTYPE (elem_mode)), elems_address), + elemsptr)); + /* Patch the elements_size% field. */ + offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size); + tree elems_size_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + a68_add_stmt (fold_build2 (MODIFY_EXPR, + void_type_node, + fold_build1 (INDIRECT_REF, + sizetype, + elems_size_address), + elems_size)); + } + else if (A68_STRUCT_TYPE_P (type)) + { + /* Initialize the struct's fields in the allocated buffer. */ + tree base = a68_lower_tmpvar ("base%", TREE_TYPE (buffer), + fold_build2 (POINTER_PLUS_EXPR, + TREE_TYPE (buffer), + buffer, offset)); + PACK_T *field_pack = PACK (m); + for (tree field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) + { + gcc_assert (COMPLETE_TYPE_P (TREE_TYPE (field))); + // printf ("BYTE_POSITION\n"); + // debug_tree (byte_position (field)); + a68_add_stmt (fill_in_buffer (base, byte_position (field), + bounds, MOID (field_pack), allocator)); + FORWARD (field_pack); + } + } + else if (A68_UNION_TYPE_P (type)) + { + /* Union values are initialized with an overhead of (sizetype) -1, which + means it is not initialized. Note that row declarers in united modes + are formal declarers, so they never contribute bounds. */ + tree overhead_address + = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset); + tree uninitialized = fold_convert (sizetype, build_minus_one_cst (ssizetype)); + a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node, + fold_build1 (INDIRECT_REF, sizetype, overhead_address), + uninitialized)); +#if 0 + /* Set the rest of the union with zeroes. */ + tree value_address + = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), + buffer, + fold_build2 (PLUS_EXPR, sizetype, offset, size_in_bytes (sizetype))); + + tree value_field = TREE_CHAIN (TYPE_FIELDS (type)); + tree call = builtin_decl_explicit (BUILT_IN_MEMSET); + call = build_call_expr_loc (UNKNOWN_LOCATION, call, 3, + value_address, + integer_zero_node, + size_in_bytes (TREE_TYPE (value_field))); + a68_add_stmt (call); +#endif + } + else + gcc_unreachable (); + + a68_add_stmt (buffer); + filler = a68_pop_stmt_list (); + TREE_TYPE (filler) = pointer_type; + return filler; +} + +/* Lower to code that generates storage for a value of mode M, using bounds + from BOUNDS. */ + +static tree +gen_mode (MOID_T *m, tree_stmt_iterator *bounds, allocator_t allocator) +{ + /* Allocate space for the value and fill it. */ + tree buffer = (*allocator) (CTYPE (m), size_in_bytes (CTYPE (m))); + buffer = save_expr (buffer); + return fill_in_buffer (buffer, size_zero_node, bounds, m, allocator); +} + +/* Collect row bounds from BOUNDS. + Lower bounds are optional, and if not found they default to 1. */ + +static void +collect_bounds (NODE_T *p, LOW_CTX_T ctx) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, BOUNDS_LIST)) + collect_bounds (SUB (p), ctx); + else if (IS (p, BOUND)) + collect_bounds (SUB (p), ctx); + else if (IS (p, UNIT)) + { + /* First the lower bound. */ + tree lower_bound; + if (NEXT (p) != NO_NODE && IS (NEXT (p), COLON_SYMBOL)) + { + lower_bound = a68_lower_tree (p, ctx); + p = NEXT_NEXT (p); + } + else + /* Default lower bound. */ + lower_bound = integer_one_node; + + /* Now the upper bound. */ + tree upper_bound = a68_lower_tree (p, ctx); + + /* See the comment for collect_declarer_bounds for an explanation for + the usage of save_expr here. */ + a68_add_stmt (save_expr (lower_bound)); + a68_add_stmt (save_expr (upper_bound)); + } + } +} + +/* Append all the bounds found in the given declarer in the current statements + list. */ + +static void +collect_declarer_bounds_1 (NODE_T *p, LOW_CTX_T ctx) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, BOUNDS)) + collect_bounds (SUB (p), ctx); + else if (IS (p, INDICANT) && IS_LITERALLY (p, "STRING")) + return; + else if (IS (p, INDICANT)) + { + if (TAX (p) != NO_TAG && HAS_ROWS (MOID (TAX (p)))) + /* Continue from definition at MODE A = .... */ + collect_declarer_bounds_1 (NEXT_NEXT (NODE (TAX (p))), ctx); + } + else if (IS (p, DECLARER) + && (IS_UNION (MOID (p)) || !HAS_ROWS (MOID (p)))) + return; + else + collect_declarer_bounds_1 (SUB (p), ctx); + } +} + +/* Given a declarer node, return a statements list with all the expressions of + the bounds within it. + + Note that the language rules mandates that the bounds expression shall be + evaluated just once even when they are used by several generators, such as + in + + [n +:= 1]real a, b; + + Therefore the expressions are saved in save_exprs and the statements list + is cached in the CDECL field of the parse tree node. */ + +static tree +collect_declarer_bounds (NODE_T *p, LOW_CTX_T ctx) +{ + if (CDECL (p) == NULL_TREE) + { + a68_push_stmt_list (M_VOID); + collect_declarer_bounds_1 (SUB (p), ctx); + CDECL (p) = a68_pop_stmt_list (); + } + + return CDECL (p); +} + +/* Low the elaboration of a generator. + + The lowered code evaluates to a pointer. + + DECLARER is the actual declarer passed to the generator. + + MODE is the mode of the value to generate. + + HEAP is true if we are lowering a heap generator, false if we are lowering a + LOC generator. */ + +tree +a68_low_generator (NODE_T *declarer, + MOID_T *mode, + bool heap, LOW_CTX_T ctx) +{ + /* If the declarer is a mode indicant which has a recursive definition then + we need to lower to a function which gets immediately called rather than + an expression, to handle the recursivity. In that case, though, we need + to always heap allocated memory for obvious reasons, which sucks, but such + is life. */ + + if (IS (SUB (declarer), INDICANT) && TAX (SUB (declarer)) != NO_TAG + && IS_RECURSIVE (TAX (SUB (declarer)))) + { + if (TAX_TREE_DECL (TAX (SUB (declarer))) != NULL_TREE) + { + /* This is a recursive mode indicant. Just call the function. */ + return save_expr (build_call_expr_loc (a68_get_node_location (SUB (declarer)), + TAX_TREE_DECL (TAX (SUB (declarer))), + 0)); + } + + tree ret_type = build_pointer_type (CTYPE (mode)); + tree func_decl = build_decl (a68_get_node_location (declarer), + FUNCTION_DECL, + NULL_TREE /* name, set below */, + build_function_type (ret_type, void_list_node)); + char *name = xasprintf ("genroutine%d", DECL_UID (func_decl)); + DECL_NAME (func_decl) = a68_get_mangled_identifier (name); + free (name); + DECL_EXTERNAL (func_decl) = 0; + DECL_STATIC_CHAIN (func_decl) = !a68_in_global_range (); + TREE_ADDRESSABLE (func_decl) = 1; + TREE_PUBLIC (func_decl) = a68_in_global_range (); + TREE_STATIC (func_decl) = 1; + TAX_TREE_DECL (TAX (SUB (declarer))) = func_decl; + + a68_add_decl (func_decl); + a68_add_decl_expr (fold_build1_loc (a68_get_node_location (declarer), + DECL_EXPR, + TREE_TYPE (func_decl), + func_decl)); + announce_function (func_decl); + a68_push_function_range (func_decl, ret_type); + + /* Collect bounds from declarer. */ + tree bounds = collect_declarer_bounds (declarer, ctx); + + /* Allocate and initialize a memory buffer for a value of mode MODE with + bounds in BOUNDS. */ + tree_stmt_iterator bounds_iter = tsi_start (bounds); + tree gen = gen_mode (mode, &bounds_iter, a68_lower_malloc); + a68_pop_function_range (gen); + /* Avoid this generator function, which uses the global lexical + environment, to be reused in other contexts. */ + TAX_TREE_DECL (TAX (SUB (declarer))) = NULL_TREE; + return save_expr (build_call_expr_loc (a68_get_node_location (declarer), + func_decl, 0)); + } + else + { + /* Collect bounds from declarer. */ + tree bounds = collect_declarer_bounds (declarer, ctx); + + /* Allocate and initialize a memory buffer for a value of mode MODE with + bounds in BOUNDS. */ + tree_stmt_iterator bounds_iter = tsi_start (bounds); + tree gen = gen_mode (mode, &bounds_iter, + heap ? a68_lower_malloc : a68_lower_alloca); + return gen; + } +} + +/* Allocate storage for a value of mode M. + NBOUNDS is the number of bounds in BOUNDS. */ + +tree +a68_low_gen (MOID_T *m, size_t nbounds, tree *bounds, bool use_heap) +{ + /* First collect bounds from BOUNDS into a statements list, which is what + gen_mode expects. */ + tree bounds_list = alloc_stmt_list (); + for (size_t i = 0; i < nbounds; ++i) + append_to_statement_list_force (bounds[i], &bounds_list); + allocator_t allocator = use_heap ? a68_lower_malloc : a68_lower_alloca; + + tree_stmt_iterator q = tsi_start (bounds_list); + tree ret = gen_mode (m, &q, allocator); + free_stmt_list (bounds_list); + return ret; +} diff --git a/gcc/algol68/a68-low-ints.cc b/gcc/algol68/a68-low-ints.cc new file mode 100644 index 000000000000..d119de9a56bc --- /dev/null +++ b/gcc/algol68/a68-low-ints.cc @@ -0,0 +1,327 @@ +/* Lowering routines for all things related to INT values. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Return a tree with the yielind of SKIP for the given integral mode. */ + +tree +a68_get_int_skip_tree (MOID_T *m) +{ + tree type; + + if (m == M_INT) + type = a68_int_type; + else if (m == M_LONG_INT) + type = a68_long_int_type; + else if (m == M_LONG_LONG_INT) + type = a68_long_long_int_type; + else if (m == M_SHORT_INT) + type = a68_short_int_type; + else if (m == M_SHORT_SHORT_INT) + type = a68_short_short_int_type; + else + gcc_unreachable (); + + return build_int_cst (type, 0); +} + +/* Given an integral type, build the maximum value expressable in that + type. */ + +tree +a68_int_maxval (tree type) +{ + return fold_convert (type, TYPE_MAX_VALUE (type)); +} + +/* Given an integral type, build the minimum value expressable in that + type. */ + +tree +a68_int_minval (tree type) +{ + return fold_convert (type, TYPE_MIN_VALUE (type)); +} + +/* Given an integral type, build an INT with the number of decimal digits + required to represent a value of that typ, not including sign. */ + +tree +a68_int_width (tree type) +{ + /* Note that log10 (2) is ~ 0.3. + Thanks to Andrew Pinski for suggesting using this expression. */ + return fold_build2 (PLUS_EXPR, a68_int_type, + build_int_cst (a68_int_type, 1), + fold_build2 (TRUNC_DIV_EXPR, + a68_int_type, + fold_build2 (MULT_EXPR, a68_int_type, + build_int_cst (a68_int_type, TYPE_PRECISION (type)), + build_int_cst (a68_int_type, 3)), + build_int_cst (a68_int_type, 10))); +} + +/* Given an integer value VAL, return -1 if it is less than zero, 0 if it is + zero and +1 if it is bigger than zero. The built value is always of mode + M_INT. */ + +tree +a68_int_sign (tree val) +{ + tree zero = build_int_cst (TREE_TYPE (val), 0); + return fold_build3 (COND_EXPR, + a68_int_type, + fold_build2 (EQ_EXPR, integer_type_node, val, zero), + build_int_cst (a68_int_type, 0), + fold_build3 (COND_EXPR, + a68_int_type, + fold_build2 (GT_EXPR, integer_type_node, val, zero), + build_int_cst (a68_int_type, 1), + build_int_cst (a68_int_type, -1))); +} + +/* Absolute value of an integer. */ + +tree +a68_int_abs (tree val) +{ + return fold_build1 (ABS_EXPR, TREE_TYPE (val), val); +} + +/* Build the integral value lengthened from the value of VAL, from mode + FROM_MODE to mode TO_MODE. */ + +tree +a68_int_leng (MOID_T *to_mode, MOID_T *from_mode ATTRIBUTE_UNUSED, tree val) +{ + /* Lengthening can be done by just a cast. */ + return fold_convert (CTYPE (to_mode), val); +} + +/* Build the integral value that can be lengthened to the value of VAL, from + mode FROM_MODE to mode TO_MODE. + + If VAL cannot be represented in TO_MODE because it is bigger than the most + positive value representable in TO_MODE, then it is truncated to that value. + + Likewise, if VAL cannot be represented in TO_MODE because it is less than + the most negative value representable in TO_MODE, then it is truncated to + that value. */ + +tree +a68_int_shorten (MOID_T *to_mode, MOID_T *from_mode ATTRIBUTE_UNUSED, tree val) +{ + tree most_positive_value = fold_convert (CTYPE (from_mode), + a68_int_maxval (CTYPE (to_mode))); + tree most_negative_value = fold_convert (CTYPE (from_mode), + a68_int_minval (CTYPE (to_mode))); + + val = save_expr (val); + most_positive_value = save_expr (most_positive_value); + most_negative_value = save_expr (most_negative_value); + return fold_build3 (COND_EXPR, CTYPE (to_mode), + fold_build2 (GT_EXPR, a68_bool_type, val, most_positive_value), + fold_convert (CTYPE (to_mode), most_positive_value), + fold_build3 (COND_EXPR, CTYPE (to_mode), + fold_build2 (LT_EXPR, a68_bool_type, val, most_negative_value), + fold_convert (CTYPE (to_mode), most_negative_value), + fold_convert (CTYPE (to_mode), val))); +} + +/* Given two integral values of mode M, build an expression that calculates the + addition of A and B. */ + +tree +a68_int_plus (MOID_T *m, tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, PLUS_EXPR, CTYPE (m), a, b); +} + +/* Given two integral values of mode M, build an expression that calculates the + subtraction of A by B. */ + +tree +a68_int_minus (MOID_T *m, tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, MINUS_EXPR, CTYPE (m), a, b); +} + +/* Given two integral values of mode M, build an expression that calculates the + multiplication of A by B. */ + +tree +a68_int_mult (MOID_T *m, tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, MULT_EXPR, CTYPE (m), a, b); +} + +/* Given two integral values of mode M, build an expression that calculates the + division of A by B. */ + +tree +a68_int_div (MOID_T *m, tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, TRUNC_DIV_EXPR, CTYPE (m), a, b); +} + +/* Given two integral values of mode M, build an expression that calculates + whether A = B. */ + +tree +a68_int_eq (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, EQ_EXPR, boolean_type_node, a, b); +} + +/* Given two integral values of mode M, build an expression that calculates + whether A /= B. */ + +tree +a68_int_ne (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b); +} + +/* Given two integral values of mode M, build an expression that calculates + whether A < B. */ + +tree +a68_int_lt (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, LT_EXPR, boolean_type_node, a, b); +} + +/* Given two integral values of mode M, build an expression that calculates + whether A <= B. */ + +tree +a68_int_le (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, LE_EXPR, boolean_type_node, a, b); +} + +/* Given two integral values of mode M, build an expression that calculates + whether A > B. */ + +tree +a68_int_gt (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, GT_EXPR, boolean_type_node, a, b); +} + +/* Given two integral values of mode M, build an expression that calculates + whether A >= B. */ + +tree +a68_int_ge (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, GE_EXPR, boolean_type_node, a, b); +} + +/* Given two integral values of mode M, build and expression that calculates the + modulus as specified by the Revised Report: + + OP MOD = (L INT a, b) L INT: + (INT r = a - a % b * b; r < 0 | r + ABS b | r) +*/ + +tree +a68_int_mod (MOID_T *m, tree a, tree b, location_t loc) +{ + a = save_expr (a); + b = save_expr (b); + tree r = a68_int_minus (m, a, a68_int_mult (m, a68_int_div (m, a, b), b)); + + r = save_expr (r); + return fold_build3_loc (loc, COND_EXPR, CTYPE (m), + a68_int_lt (r, build_int_cst (CTYPE (m), 0)), + a68_int_plus (m, r, a68_int_abs (b)), + r); +} + +/* Given two integral values values, the first of mode M an the second of mode + INT, build an expression that calculates the exponentiation of A by B, as + specified by the Revised Report: + + OP ** = (L INT a, INT b) L INT: + (b >= 0 | L INT p := L 1; TO b DO p := p * a OD; p) +*/ + +tree +a68_int_pow (MOID_T *m, tree a, tree b, location_t loc) +{ + tree zero = build_int_cst (CTYPE (m), 0); + tree one = build_int_cst (CTYPE (m), 1); + + a = save_expr (a); + b = save_expr (fold_convert (CTYPE (m), b)); + + a68_push_range (m); + tree index = a68_lower_tmpvar ("index%", CTYPE (m), zero); + tree p = a68_lower_tmpvar ("p%", CTYPE (m), one); + + /* Begin of loop body. */ + a68_push_range (NULL); + { + /* if (index == b) break; */ + a68_add_stmt (fold_build1 (EXIT_EXPR, + void_type_node, + fold_build2 (EQ_EXPR, CTYPE (m), + index, b))); + a68_add_stmt (fold_build2 (MODIFY_EXPR, CTYPE (m), + p, a68_int_mult (m, p, a))); + + /* index++ */ + a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, CTYPE (m), + index, one)); + } + tree loop_body = a68_pop_range (); + a68_add_stmt (fold_build1 (LOOP_EXPR, + void_type_node, + loop_body)); + a68_add_stmt (p); + tree calculate_p = a68_pop_range (); + return fold_build3_loc (loc, COND_EXPR, CTYPE (m), + a68_int_ge (b, zero), + calculate_p, zero); +} diff --git a/gcc/algol68/a68-low-misc.cc b/gcc/algol68/a68-low-misc.cc new file mode 100644 index 000000000000..b1048b6b8ca8 --- /dev/null +++ b/gcc/algol68/a68-low-misc.cc @@ -0,0 +1,234 @@ +/* Lower miscellaneous tree nodes to GENERIC. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Lower an assertion. + + assertion : assert symbol, enclosed clause. +*/ + +tree +a68_lower_assertion (NODE_T *p, LOW_CTX_T ctx) +{ + if (!OPTION_ASSERT (&A68_JOB)) + return a68_get_empty(); + + /* Build the call to the assert run-time function. */ + unsigned int lineno = NUMBER (LINE (INFO (p))); + const char *filename_str = FILENAME (LINE (INFO (p))); + tree filename = build_string_literal (strlen (filename_str) + 1, + filename_str); + tree call = a68_build_libcall (A68_LIBCALL_ASSERT, + void_type_node, 2, + filename, + build_int_cst (unsigned_type_node, lineno)); + /* Check condition and call assert if required. */ + tree assertion = fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + a68_void_type, + build2_loc (a68_get_node_location (p), + TRUTH_ORIF_EXPR, + a68_int_type, + a68_lower_tree (NEXT (SUB (p)), ctx), + fold_build2 (COMPOUND_EXPR, + a68_int_type, + call, + build_int_cst (a68_int_type, 0))), + a68_get_empty ()); + TREE_SIDE_EFFECTS (assertion) = 1; + return assertion; +} + +/* Lower a jump to a label. + + jump : goto symbol, identifier; + identifier. + + A jump lowers into a ({ GOTO_EXPR; EMPTY }). */ + +tree +a68_lower_jump (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *label_identifier = SUB (p); + MOID_T *jump_mode = MOID (p); + if (!IS (label_identifier, IDENTIFIER)) + FORWARD (label_identifier); + + /* Create LABEL_DECL if necessary and chain it in both current block and bind + expression. */ + if (TAX_TREE_DECL (TAX (label_identifier)) == NULL_TREE) + { + tree label_decl = build_decl (a68_get_node_location (label_identifier), + LABEL_DECL, + a68_get_mangled_identifier (NSYMBOL (label_identifier)), + void_type_node); + TAX_TREE_DECL (TAX (label_identifier)) = label_decl; + } + + MOID (label_identifier) = M_VOID; + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + CTYPE (jump_mode), + fold_build1_loc (a68_get_node_location (p), + GOTO_EXPR, + void_type_node, + a68_lower_tree (label_identifier, ctx)), + a68_get_skip_tree (jump_mode)); +} + +/* Lower a parameter into a chain of PARAM_DECLs. + + parameter : declarer, identifier; + parameter, comma symbol, identifier. +*/ + +tree +a68_lower_parameter (NODE_T *p, LOW_CTX_T ctx) +{ + tree prev_parm_decls = NULL_TREE; + NODE_T *identifier = NO_NODE; + if (IS (SUB (p), PARAMETER)) + { + prev_parm_decls = a68_lower_tree (SUB (p), ctx); + identifier = NEXT (NEXT (SUB (p))); + } + else + identifier = NEXT (SUB (p)); + + /* Create the PARM_DECL. */ + tree parm_decl = build_decl (a68_get_node_location (p), + PARM_DECL, + a68_get_mangled_identifier (NSYMBOL (identifier)), + CTYPE (MOID (identifier))); + DECL_CONTEXT (parm_decl) = current_function_decl; + DECL_ARG_TYPE (parm_decl) = TREE_TYPE (parm_decl); + TAX_TREE_DECL (TAX (identifier)) = parm_decl; + + layout_decl (parm_decl, 0); + + if (prev_parm_decls != NULL) + return chainon (prev_parm_decls, parm_decl); + else + return parm_decl; +} + +/* Lower a list of parameters into a chain of PARAM_DECLs. + + parameter list : parameter; + parameter list; comma symbol; parameter. +*/ + +tree +a68_lower_parameter_list (NODE_T *p, LOW_CTX_T ctx) +{ + tree parm_decl = NULL_TREE; + tree prev_parm_decls = NULL_TREE; + if (IS (SUB (p), PARAMETER_LIST)) + { + prev_parm_decls = a68_lower_tree (SUB (p), ctx); + parm_decl = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + } + else + parm_decl = a68_lower_tree (SUB (p), ctx); + + gcc_assert (parm_decl != NULL_TREE); + if (prev_parm_decls != NULL) + return chainon (prev_parm_decls, parm_decl); + else + return parm_decl; +} + +/* Lower a parameter pack into a chain of PARAM_DECLs. + + parameter pack : open symbol, parameter list, close symbol. +*/ + +tree +a68_lower_parameter_pack (NODE_T *p, LOW_CTX_T ctx) +{ + /* Lower the contained PARAMETER_LIST. */ + return a68_lower_tree (NEXT (SUB (p)), ctx); +} + +/* Lower an applied operator. + + Applied operators lower into a function object that gets one argument in + case of monadic operators, or two arguments in case of dyadic operators. */ + +tree +a68_lower_operator (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + /* This is an user defined operator. Handle it in a similar way than applied + identifiers. */ + tree func_decl = TAX_TREE_DECL (TAX (p)); + if (func_decl == NULL_TREE) + { + bool external = (MOIF (TAX (p)) != NO_MOIF); + const char *extern_symbol = EXTERN_SYMBOL (TAX (p)); + if (IN_PROC (TAX (p))) + { + if (external) + func_decl = a68_make_proc_identity_declaration_decl (p, + NAME (MOIF (TAX (p))), + true /* indicant */, + external, + extern_symbol); + else + func_decl = a68_make_proc_identity_declaration_decl (p, + ctx.module_definition_name, + true /* indicant */); + } + else + { + if (external) + func_decl = a68_make_identity_declaration_decl (p, NAME (MOIF (TAX (p))), + true /* indicant */, external, + extern_symbol); + else + func_decl = a68_make_identity_declaration_decl (p, ctx.module_definition_name, + true /* indicant */); + } + TAX_TREE_DECL (TAX (p)) = func_decl; + } + return func_decl; +} diff --git a/gcc/algol68/a68-low-moids.cc b/gcc/algol68/a68-low-moids.cc new file mode 100644 index 000000000000..4dbf11891628 --- /dev/null +++ b/gcc/algol68/a68-low-moids.cc @@ -0,0 +1,729 @@ +/* Lower Algol 68 modes to GCC trees. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "stringpool.h" +#include "tree.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "print-tree.h" + +#include "a68.h" + +static tree a68_lower_mode (MOID_T *m); + +/* + * Support routines and definitions. + */ + +/* Build a stub TYPE_DECL for a given TYPE. + + This is used for TYPE_STUB_DECL so we can generate debug info for all our + modes, so the TYPE_DECL has no name. */ + +static void +build_stub_type_decl (tree type, tree context) +{ + if (TYPE_STUB_DECL (type)) + return; + + tree decl = build_decl (UNKNOWN_LOCATION, + TYPE_DECL, + NULL_TREE /* name */, + type); + TREE_PUBLIC (decl) = 1; + DECL_CONTEXT (decl) = context; + TYPE_CONTEXT (type) = DECL_CONTEXT (decl); + TYPE_NAME (type) = decl; /* Weird. This is for typedefs! */ + TYPE_STUB_DECL (type) = decl; +} + +/* Builds a record type whose name is NAME. NFIELDS is the number of fields, + provided as field ident/type pairs. + + This code is copied from the D front end. */ + +static tree +make_struct_type (tree type, const char *name, int nfields, ...) +{ + tree fields = NULL_TREE; + va_list ap; + + va_start (ap, nfields); + + for (int i = 0; i < nfields; i++) + { + tree ident = va_arg (ap, tree); + tree type = va_arg (ap, tree); + tree field = build_decl (BUILTINS_LOCATION, FIELD_DECL, ident, type); + DECL_CHAIN (field) = fields; + fields = field; + } + + va_end (ap); + + if (type == NULL_TREE) + type = make_node (RECORD_TYPE); + finish_builtin_struct (type, name, fields, NULL_TREE); + + return type; +} + +/* Iterate over all the field selectors FIELDS of a structure type and add them + as fields to CONTEXT. Returns the number of field selectors found. */ + +static size_t +chain_struct_fields (PACK_T *fields, tree context) +{ + PACK_T *elem; + size_t num_fields; + + for (num_fields = 0, elem = fields; + elem != NO_PACK; + FORWARD (elem), ++num_fields) + { + const char *field_name = TEXT (elem); + MOID_T *field_mode = MOID (elem); + tree field_type = a68_lower_mode (field_mode); + + /* Create the field declaration. + The declaration is not a compiler-generated entity. + Do not ignore the declaration for symbolic debug purposes. */ + tree field_decl = build_decl ((NODE (field_mode) + ? a68_get_node_location (NODE (field_mode)) + : UNKNOWN_LOCATION), + FIELD_DECL, + field_name ? get_identifier (field_name) : NULL_TREE, + field_type); + DECL_ARTIFICIAL (field_decl) = 0; + DECL_IGNORED_P (field_decl) = 0; + + /* If the mode of the field is not a ref then references to the field + cannot appear in a LHS of an assignment. */ + TREE_READONLY (field_decl) = IS_REF (field_mode); + + /* Associate the tree field declaration and the front end node. */ + DECL_LANG_SPECIFIC (field_decl) = + (NODE (field_mode) ? a68_build_lang_decl (NODE (field_mode)) : NULL); + + /* Chain the field declaration in its containing context. */ + DECL_FIELD_CONTEXT (field_decl) = context; + TYPE_FIELDS (context) = chainon (TYPE_FIELDS (context), field_decl); + } + + return num_fields; +} + +/* If the union or struct type TYPE completes the type of any previous field + declarations, lay them out now. */ + +static void +finish_incomplete_fields (tree type) +{ + for (tree fwdref = TYPE_FORWARD_REFERENCES (type); fwdref != NULL_TREE; + fwdref = TREE_CHAIN (fwdref)) + { + tree field = TREE_VALUE (fwdref); + tree struct_or_union_type = DECL_FIELD_CONTEXT (field); + + relayout_decl (field); + bool type_complete = true; + for (tree field = TYPE_FIELDS (struct_or_union_type); + field; + field = DECL_CHAIN (field)) + { + if (!COMPLETE_TYPE_P (TREE_TYPE (field))) + { + type_complete = false; + break; + } + } + + if (type_complete) + { + // XXX why this fires + // gcc_assert (!COMPLETE_TYPE_P (struct_or_union_type)); + layout_type (struct_or_union_type); + /* Set the back-end type mode now that all fields have had their size + set. */ + compute_record_mode (struct_or_union_type); + } + }; + + /* No more forward references to process. */ + TYPE_FORWARD_REFERENCES (type) = NULL_TREE; +} + +/* + * Mode lowering routines. + */ + +/* Lower a HIP mode to a GENERIC tree. + HIP is the mode of NIL. */ + +static tree +lower_hip_mode (MOID_T *m) +{ + static tree hip_type; + + if (hip_type == NULL) + { + hip_type = build_pointer_type (a68_void_type); + TYPE_LANG_SPECIFIC (hip_type) = a68_build_lang_type (m); + CTYPE (m) = hip_type; + } + + return hip_type; +} + +/* Lower a standard mode to a GENERIC tree. + + Note that this function only has to handle the standard modes that have not + been resolved to some equivalent. */ + +static tree +lower_standard_mode (MOID_T *m) +{ + tree type = NULL_TREE; + + if (m == M_VOID) + type = a68_void_type; + else if (m == M_BOOL) + type = a68_bool_type; + else if (m == M_CHAR) + type = a68_char_type; + else if (m == M_SHORT_SHORT_INT) + type = a68_short_short_int_type; + else if (m == M_SHORT_INT) + type = a68_short_int_type; + else if (m == M_INT) + type = a68_int_type; + else if (m == M_LONG_INT) + type = a68_long_int_type; + else if (m == M_LONG_LONG_INT) + type = a68_long_long_int_type; + else if (m == M_REAL) + type = a68_real_type; + else if (m == M_LONG_REAL) + type = a68_long_real_type; + else if (m == M_LONG_LONG_REAL) + type = a68_long_long_real_type; + else if (m == M_SHORT_SHORT_BITS) + type = a68_short_short_bits_type; + else if (m == M_SHORT_BITS) + type = a68_short_bits_type; + else if (m == M_BITS) + type = a68_bits_type; + else if (m == M_LONG_BITS) + type = a68_long_bits_type; + else if (m == M_LONG_LONG_BITS) + type = a68_long_long_bits_type; + else if (m == M_BYTES) + type = a68_bytes_type; + else if (m == M_LONG_BYTES) + type = a68_long_bytes_type; + else if (m == M_FILE) + /* XXX for now this is a file descriptor. */ + type = integer_type_node; + else if (m == M_CHANNEL) + /* XXX for now this is a channel descriptor. */ + type = integer_type_node; + else + gcc_unreachable (); + + TYPE_LANG_SPECIFIC (type) = a68_build_lang_type (m); + return type; +} + +/* Lower a struct mode to a GENERIC tree. */ + +static tree +lower_struct_mode (MOID_T *m) +{ + /* First make the GENERIC struct. This is needed in case of + self-references. */ + tree struct_type = make_node (RECORD_TYPE); + TYPE_NAME (struct_type) = get_identifier ("lalastruct%"); + TYPE_FIELDS (struct_type) = NULL_TREE; + TYPE_CXX_ODR_P (struct_type) = 0; + CTYPE (m) = struct_type; + TYPE_LANG_SPECIFIC (struct_type) = a68_build_lang_type (m); /* XXX this will get overrided. */ + + /* Add field declarations. */ + chain_struct_fields (PACK (m), struct_type); + + /* Layout all fields. */ + bool struct_type_complete = true; + for (tree field = TYPE_FIELDS (struct_type); field; field = DECL_CHAIN (field)) + { + tree basetype = TREE_TYPE (field); + + if (!COMPLETE_TYPE_P (basetype)) + { + tree field_type = TREE_TYPE (field); + tree forward_refs = tree_cons (NULL_TREE, field, + TYPE_FORWARD_REFERENCES (field_type)); + TYPE_FORWARD_REFERENCES (struct_type) = forward_refs; + + struct_type_complete = false; + continue; + } + + layout_decl (field, 0); + gcc_assert (DECL_SIZE (field) != NULL_TREE); + } + + /* If all fields have complete types then we can layout the struct type now. + Otherwise it will be done in finish_incomplete_types. */ + if (struct_type_complete) + { + layout_type (struct_type); + /* Set the back-end type mode now that all fields have had their size + set. */ + compute_record_mode (struct_type); + } + + /* Finish debugging output for this type. */ + build_stub_type_decl (struct_type, NULL_TREE /* context */); + rest_of_type_compilation (struct_type, TYPE_FILE_SCOPE_P (struct_type)); + rest_of_decl_compilation (TYPE_NAME (struct_type), 1 /* file scope p */, 0); + A68_STRUCT_TYPE_P (struct_type) = 1; + return struct_type; +} + +/* Lower a ref mode to a GENERIC tree. + REF AMODE lowers to a pointer. */ + +static tree +lower_ref_mode (MOID_T *m) +{ + return build_pointer_type (a68_lower_mode (SUB (m))); +} + +/* Lower a flex mode to a GENERIC tree. */ + +static tree +lower_flex_mode (MOID_T *m) +{ + /* This is basically a qualifier of the parent REF. */ + return a68_lower_mode (SUB (m)); +} + +/* Lower a proc mode to a GENERIC tree. */ + +static tree +lower_proc_mode (MOID_T *m) +{ + tree fnargs = NULL_TREE; + tree ret_type; + + /* We have to create the function type in advance because it can appear + recursively as the type of arguments and/or of the return value. We + cannot use build_function_type, as it doesn't support recursive types. */ + tree function_type = make_node (FUNCTION_TYPE); + tree ptr_function_type = build_pointer_type (function_type); + CTYPE (m) = ptr_function_type; + + /* Now add arguments and return value types. */ + for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) + { + tree arg_type = a68_lower_mode (MOID (p)); + fnargs = chainon (fnargs, build_tree_list (0, arg_type)); + } + ret_type = a68_lower_mode (SUB (m)); + + /* Complete the function type. Note that there is some code duplication with + build_function_type, which we cannot use, but such is life. */ + TREE_TYPE (function_type) = ret_type; /* THIS */ + TYPE_ARG_TYPES (function_type) = fnargs; + SET_TYPE_STRUCTURAL_EQUALITY (function_type); + + if (!COMPLETE_TYPE_P (function_type)) + layout_type (function_type); + + return ptr_function_type; +} + +/* Lower an union mode to a GENERIC tree. + + overhead% Characterizes the actual mode of the value. + value% GENERIC union. */ + +static tree +lower_union_mode (MOID_T *m) +{ + // XXX make the union type QUAL_UNION_TYPE and relate the fields with the + // overhead%. This is necessary for DWARF. + tree union_type = make_node (RECORD_TYPE); + TYPE_NAME (union_type) = NULL_TREE; + TYPE_FIELDS (union_type) = NULL_TREE; + TYPE_CXX_ODR_P (union_type) = 0; + CTYPE (m) = union_type; + + /* Then the GENERIC union. */ + tree c_union_type = make_node (UNION_TYPE); + TYPE_NAME (c_union_type) = NULL_TREE; + TYPE_FIELDS (c_union_type) = NULL_TREE; + TYPE_CXX_ODR_P (c_union_type) = 0; // XXX otherwise lto complains. why. + SET_TYPE_STRUCTURAL_EQUALITY (c_union_type); + + /* Add field declarations. */ + chain_struct_fields (PACK (m), c_union_type); + + /* Layout all fields now the type is complete. */ + bool c_union_type_complete = true; + for (tree field = TYPE_FIELDS (c_union_type); field; field = DECL_CHAIN (field)) + { + tree field_type = TREE_TYPE (field); + + if (!COMPLETE_TYPE_P (field_type)) + { + tree field_type = TREE_TYPE (field); + tree forward_refs = tree_cons (NULL_TREE, field, + TYPE_FORWARD_REFERENCES (field_type)); + TYPE_FORWARD_REFERENCES (c_union_type) = forward_refs; + + c_union_type_complete = false; + continue; + } + + layout_decl (field, 0); + gcc_assert (DECL_SIZE (field) != NULL_TREE); + } + + /* If all fields have complete types then we can layout the c-union type now. + Otherwise it will be done in finish_incomplete_types. */ + if (c_union_type_complete) + { + layout_type (c_union_type); + /* Set the back-end type mode now that all fields have had their size + set. */ + compute_record_mode (c_union_type); + } + + /* Finish debugging output for this type. */ + build_stub_type_decl (c_union_type, NULL_TREE /* context */); + rest_of_type_compilation (c_union_type, TYPE_FILE_SCOPE_P (c_union_type)); + rest_of_decl_compilation (TYPE_NAME (c_union_type), 1 /* file scope p */, 0); + + /* Now the type with the overhead. */ + TYPE_NAME (union_type) = get_identifier ("union%"); + tree overhead_field = build_decl (UNKNOWN_LOCATION, FIELD_DECL, + get_identifier ("overhead%"), sizetype); + tree value_field = build_decl (UNKNOWN_LOCATION, FIELD_DECL, + get_identifier ("value%"), c_union_type); + DECL_FIELD_CONTEXT (overhead_field) = union_type; + DECL_FIELD_CONTEXT (value_field) = union_type; + DECL_CHAIN (value_field) = NULL_TREE; + DECL_CHAIN (overhead_field) = value_field; + TYPE_FIELDS (union_type) = overhead_field; + + if (c_union_type_complete) + { + layout_type (union_type); + /* Set the back-end type mode now that all fields have had their size + set. */ + compute_record_mode (union_type); + } + else + { + tree forward_refs = tree_cons (NULL_TREE, value_field, + TYPE_FORWARD_REFERENCES (union_type)); + TYPE_FORWARD_REFERENCES (union_type) = forward_refs; + } + + SET_TYPE_STRUCTURAL_EQUALITY (union_type); + A68_UNION_TYPE_P (union_type) = 1; + return union_type; +} + +/* Return the type for an array descriptor triplet. */ + +tree +a68_triplet_type (void) +{ + static tree triplet_type = NULL_TREE; + if (triplet_type == NULL_TREE) + { + triplet_type = make_struct_type (NULL_TREE, "triplet%", 3, + get_identifier ("lb%"), + ssizetype, + get_identifier ("ub%"), + ssizetype, + get_identifier ("stride%"), + sizetype); + } + + return triplet_type; +} + +/* Return the lower bound field in an array descriptor triplet. */ + +tree +a68_triplet_type_lower_bound (tree triplet) +{ + tree lb_field = TYPE_FIELDS (triplet); + return lb_field; +} + +/* Lower a row mode to a GENERIC tree. + + descriptor% + triplets% Value of ARRAY_TYPE with an entry per multiple dimension. + { + li% Lower bound of dimension. + ui% Upper bound of dimension. + di% Stride of dimension in bytes. + } + elements% Pointer to the elements. + elements_size% Size of elements% in bytes. +*/ + +static tree +lower_row_mode (MOID_T *m) +{ + int num_dimensions = DIM (m); + tree triplet_type = a68_triplet_type (); + tree triplets_type = build_array_type (triplet_type, + build_index_type (size_int (num_dimensions - 1))); + tree element_type = a68_lower_mode (SUB (m)); + tree row_type = make_struct_type (NULL_TREE, "row%", 3, + get_identifier ("triplets%"), + triplets_type, + get_identifier ("elements%"), + build_pointer_type (element_type), + get_identifier ("elements_size%"), + sizetype); + layout_type (row_type); + A68_ROW_TYPE_P (row_type) = 1; + return row_type; +} + +/* Given a row type, return the type of the pointer to its elements. */ + +tree +a68_row_elements_pointer_type (tree type) +{ + gcc_assert (A68_ROW_TYPE_P (type)); + /* elements% is the second field. */ + return TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))); +} + +/* Given a row type, return the type of its elements. */ + +tree +a68_row_elements_type (tree type) +{ + return TREE_TYPE (a68_row_elements_pointer_type (type)); +} + +/* Lower a ROWS mode to a GENERIC tree. + + dim% Number of dimensions. + triplets% Pointer to triplets. + + Values of this mode are passed to the operators UPB, LWB and ELEMS, which + need only descriptor information. There is no need to store any multiple + elements. */ + +static tree +lower_rows_mode (MOID_T *m ATTRIBUTE_UNUSED) +{ + static tree rows_type = NULL_TREE; + + if (rows_type == NULL_TREE) + { + rows_type = make_struct_type (NULL_TREE, "rows%", 2, + get_identifier ("dim%"), + sizetype, + get_identifier ("triplets%"), + build_pointer_type (a68_triplet_type ())); + A68_ROWS_TYPE_P (rows_type) = 1; + } + return rows_type; +} + +/* Lower modes in a series. This is used as the mode of the mode yielded by an + enclosed clause that yields a series of united rows, for M_ROWS. */ + +static tree +lower_series (MOID_T *m) +{ + for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) + { + if (IS (MOID (p), SERIES_MODE) || IS (MOID (p), STOWED_MODE)) + lower_series (MOID (p)); + else + (void) a68_lower_mode (MOID (p)); + } + + return lower_rows_mode (NO_MOID); +} + +/* Lower a mode to a GENERIC tree. */ + +static tree +a68_lower_mode (MOID_T *m) +{ + tree type = NULL_TREE; + + /* If the given mode has already been lowered, return the corresponding + tree. */ + if (CTYPE (m) != NULL) + return CTYPE (m); + + if (EQUIVALENT (m) != NO_MOID && EQUIVALENT (m) != m) + /* This covers INDICANTs and standard MOIDS having an equivalent mode. */ + type = a68_lower_mode (EQUIVALENT (m)); + else if (m == M_VOID) + type = a68_void_type; + else if (m == M_HIP) + type = lower_hip_mode (m); + else if (IS (m, STANDARD)) + type = lower_standard_mode (m); + else if (IS_REF (m)) + type = lower_ref_mode (m); + else if (IS_FLEX (m)) + type = lower_flex_mode (m); + else if (IS (m, PROC_SYMBOL)) + type = lower_proc_mode (m); + else if (IS_STRUCT (m)) + type = lower_struct_mode (m); + else if (IS_ROW (m)) + type = lower_row_mode (m); + else if (IS_UNION (m)) + type = lower_union_mode (m); + else if (m == M_SIMPLOUT || m == M_SIMPLIN) + type = a68_void_type; + else if (IS (m, ROWS_SYMBOL)) + /* ROWS is a mode that means "any row mode". */ + type = lower_rows_mode (m); + else if (m == M_VACUUM) + /* This is a mode that should not survive the parser. */ + type = a68_void_type; + else if (IS (m, SERIES_MODE) || IS (m, STOWED_MODE)) + { + /* When dealing with operators the parser creates some modes that leak + SERIES and STOWED "proto-modes" in them, such as for example: + + UNION ((INT, INT), INT, PROC [] CHAR) + + These are not really real Algol 68 modes and are useless by + themselves, so when we find them, we traverse them (they ultimately + contain valid modes that may show up in other contexts and that + require being lowered) and just report them as VOID. */ + type = lower_series (m); + } + else + { + fatal_error (NODE (m) ? a68_get_node_location (NODE (m)) : UNKNOWN_LOCATION, + "Cannot lower mode %s", + a68_moid_to_string (m, MOID_ERROR_WIDTH, NODE (m))); + } + + /* Associate the created tree node with the mode, and vice-versa. */ + gcc_assert (type != NULL_TREE); + TYPE_LANG_SPECIFIC (type) = a68_build_lang_type (m); + A68_TYPE_HAS_ROWS_P (type) = HAS_ROWS (m); + if (CTYPE (m) == NULL_TREE) + CTYPE (m) = type; + // printf ("DONE LOWERING %s\n", a68_moid_to_string (m, MOID_ERROR_WIDTH, NODE (m))); + return type; +} + +/* Lower MOIDs to GENERIC trees. */ + +void +a68_lower_moids (MOID_T *mode) +{ + /* First pass: all modes but refs. */ + for (MOID_T *m = mode; m != NO_MOID; FORWARD (m)) + (void) a68_lower_mode (m); + + /* Try to layout all incomplete types. This is a two-passes process. */ + + for (MOID_T *m = mode; m != NO_MOID; FORWARD (m)) + { + if (IS_STRUCT (m)) + { + tree struct_type = CTYPE (m); + finish_incomplete_fields (struct_type); + } + else if (IS_UNION (m)) + { + tree union_type = CTYPE (m); + tree c_union_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (union_type))); + finish_incomplete_fields (c_union_type); + finish_incomplete_fields (union_type); + } + } + + for (MOID_T *m = mode; m != NO_MOID; FORWARD (m)) + { + if (!COMPLETE_TYPE_P (CTYPE (m))) + { + if (IS_STRUCT (m)) + { + tree struct_type = CTYPE (m); + layout_type (struct_type); + compute_record_mode (struct_type); + } + else if (IS_UNION (m)) + { + tree union_type = CTYPE (m); + tree c_union_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (union_type))); + + if (!COMPLETE_TYPE_P (c_union_type)) + { + layout_type (c_union_type); + compute_record_mode (c_union_type); + } + + layout_type (union_type); + compute_record_mode (union_type); + } + else + layout_type (CTYPE (m)); + } + } + + /* Sanity check. */ + for (MOID_T *m = mode; m != NO_MOID; FORWARD (m)) + { + gcc_assert (COMPLETE_TYPE_P (CTYPE (m))); + if (IS_UNION (m)) + { + tree union_type = CTYPE (m); + tree c_union_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (union_type))); + gcc_assert (COMPLETE_TYPE_P (c_union_type)); + } + } +} diff --git a/gcc/algol68/a68-low-multiples.cc b/gcc/algol68/a68-low-multiples.cc new file mode 100644 index 000000000000..572162e30aca --- /dev/null +++ b/gcc/algol68/a68-low-multiples.cc @@ -0,0 +1,1097 @@ +/* Lowering routines for all things related to multiples. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Algol 68 multiples are multi-dimensional and dynamically sized. They have a + static part and a dynamic part. The static part is conformed by a + "descriptor", which contains information about each of the dimensions, and a + pointer to the actual elements stored in the multiple. The dynamic part are + the elements, which are stored in column order. Both the descriptor and the + elements may reside on the stack, data section, or the heap. The mode of a + multiple is a "row". + + Schematically, the descriptor contains: + + triplets% + lb% ub% stride% + ... + elements% + elements_size% + + Where elements_size% is the size of the buffer pointed by elements%, in + bytes. + + There is a triplet per dimension in the multiple. The number of dimensions + in a row mode is static and is determined at compile-time. + + The infomation stored for each triplet is: + + lb% is the lower bound of the dimension. + ub% is the upper bound of the dimension. + stride% is the stride of the dimension. + + The stride of each dimension is the number of bytes to skip in order to + access the next element in that dimension. They express the layout of the + multiple in memory. + + Algol 68 multi-dimensional multiples are stored in row-major (generalized, + lexicographical) order: + + [1:3,1:2]AMODE = ((e1, e2, e3), + (e4, e5, e6)) + + is stored as: + + 1 2 3 + 1 e1 e2 e3 | stride 2S -> stride 1S + 2 e4 e5 e6 v + + Where S is the size in bytes of a single element. That means that for two + dimensional multiples, the column stride is always 1S and the row stride is + the column size. + + In general, given a mode with number of elements N1, N2, N3, ...: + + [N1,N2,N3...,Nn]AMODE + + the strides of the dimensions are: + + S1 = N2 * S2 + S2 = N3 * S3 + S3 = N4 * S4 + ... + Si = N1 * N2 * ... * Ni-1 + + Indexing is then performed by a dot-product of an element coordinate and the + strides: + + (i1,i2,i3) . (S1,S2,S3) = offset + i1*S1 + i2*S2 + i3*S3 = index in elements array. + + Note that the number of elements in each dimension can be easily derived + from the bounds and there is no need to store them explicitly, save for + performance reasons. Descriptors are bulky enough and often they they are + stored on the stack, so we prefer to pay in performance and save in + storage. */ + +/* Return a tree with the yielding of SKIP for the given row mode, a + multiple. */ + +tree +a68_get_multiple_skip_tree (MOID_T *m) +{ + tree res = NULL_TREE; + int dim = DIM (m); + tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim); + tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim); + tree ssize_one_node = fold_convert (ssizetype, size_one_node); + tree ssize_zero_node = fold_convert (ssizetype, size_zero_node); + for (int i = 0; i < dim; ++i) + { + lower_bounds[i] = ssize_one_node; + upper_bounds[i] = ssize_zero_node; + } + res = a68_row_value (CTYPE (m), dim, + build_int_cst (build_pointer_type (void_type_node), 0), + size_zero_node, /* elements_size */ + lower_bounds, upper_bounds); + free (lower_bounds); + free (upper_bounds); + return res; +} + +/* Return the number of dimensions of the multiple EXP as an integer + constant. */ + +tree +a68_multiple_dimensions (tree exp) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp))); + + /* triplets% is the first field in the descriptor. */ + tree triplets_field = TYPE_FIELDS (TREE_TYPE (exp)); + return array_type_nelts_top (TREE_TYPE (triplets_field)); +} + +/* Return an expression that evaluates to the total number of elements stored + in a multiple as a sizetype. */ + +tree +a68_multiple_num_elems (tree exp) +{ + /* We have to calculate the number of elements based on the dimension + triplets in the array type. The number of dimensions is known at compile + time, so we don't really need a loop. */ + + tree num_dimensions_tree = a68_multiple_dimensions (exp); + gcc_assert (TREE_CODE (num_dimensions_tree) == INTEGER_CST); + int num_dimensions = tree_to_shwi (num_dimensions_tree); + + tree size = NULL_TREE; + for (int dim = 0; dim < num_dimensions; ++dim) + { + tree size_dim = size_int (dim); + tree lower_bound = a68_multiple_lower_bound (exp, size_dim); + tree upper_bound = a68_multiple_upper_bound (exp, size_dim); + tree dim_size = fold_build2 (PLUS_EXPR, sizetype, + fold_convert (sizetype, fold_build2 (MINUS_EXPR, + ssizetype, + upper_bound, + lower_bound)), + size_one_node); + + if (size == NULL_TREE) + size = dim_size; + else + size = fold_build2 (MULT_EXPR, sizetype, size, dim_size); + } + + return size; +} + +/* Return a size expression that evaluates to the total size, in bytes, of the + elements stored in the multiple. */ + +tree +a68_multiple_elements_size (tree exp) +{ + tree type = TREE_TYPE (exp); + gcc_assert (A68_ROW_TYPE_P (type)); + + /* elements_size% is the third field in the descriptor. */ + tree elements_size_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (type))); + return fold_build3 (COMPONENT_REF, TREE_TYPE (elements_size_field), + exp, elements_size_field, NULL_TREE); +} + +/* Return the triplet for dimension DIM in the multiple EXP. */ + +static tree +multiple_triplet (tree exp, tree dim) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp))); + + /* triplets% is the first field in the descriptor. */ + tree triplets_field = TYPE_FIELDS (TREE_TYPE (exp)); + tree triplets = fold_build3 (COMPONENT_REF, + TREE_TYPE (triplets_field), + exp, + triplets_field, + NULL_TREE); + + /* Get the triplet for the given dimension. */ + return build4 (ARRAY_REF, + TREE_TYPE (TREE_TYPE (triplets)), + triplets, + dim, + NULL_TREE, + NULL_TREE); +} + +/* Return the lower bound of dimension DIM of the multiple EXP. The returned + value is a ssizetype. */ + +tree +a68_multiple_lower_bound (tree exp, tree dim) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp))); + + /* lb% is the first field in the triplet. */ + tree triplet = multiple_triplet (exp, dim); + tree lower_bound_field = TYPE_FIELDS (TREE_TYPE (triplet)); + return fold_build3 (COMPONENT_REF, + TREE_TYPE (lower_bound_field), + triplet, + lower_bound_field, + NULL_TREE); +} + +/* Return an expression that sets the lower bound of dimension DIM of the + multiple EXP to BOUND. */ + +tree +a68_multiple_set_lower_bound (tree exp, tree dim, tree bound) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp))); + return fold_build2 (MODIFY_EXPR, + TREE_TYPE (bound), + a68_multiple_lower_bound (exp, dim), + bound); +} + +/* Return the upper bound of dimension DIM of the multiple EXP. The returned + value is a ssizetype. */ + +tree +a68_multiple_upper_bound (tree exp, tree dim) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp))); + + /* ub% is the second field in the triplet. */ + tree triplet = multiple_triplet (exp, dim); + tree upper_bound_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (triplet))); + return fold_build3 (COMPONENT_REF, + TREE_TYPE (upper_bound_field), + triplet, + upper_bound_field, + NULL_TREE); +} + +/* Return an expression that sets the upper bound of dimension DIM of the + multiple EXP to BOUND. */ + +tree +a68_multiple_set_upper_bound (tree exp, tree dim, tree bound) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp))); + return fold_build2 (MODIFY_EXPR, + TREE_TYPE (bound), + a68_multiple_upper_bound (exp, dim), + bound); +} + +/* Return the stride of dimension DIM of the multiple EXP. */ + +tree +a68_multiple_stride (tree exp, tree dim) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp))); + + /* stride% is the third field in the triplet. */ + tree triplet = multiple_triplet (exp, dim); + tree stride_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (triplet)))); + return fold_build3 (COMPONENT_REF, + TREE_TYPE (stride_field), + triplet, + stride_field, + NULL_TREE); +} + +/* Return an expression that sets the stride of dimension DIM of the multiple + EXP to STRIDE. + + STRIDE must be a sizetype. */ + +tree +a68_multiple_set_stride (tree exp, tree dim, tree stride) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp))); + return fold_build2 (MODIFY_EXPR, + TREE_TYPE (stride), + a68_multiple_stride (exp, dim), + stride); +} + +/* Return the triplets of the multiple EXP. */ + +tree +a68_multiple_triplets (tree exp) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp))); + + /* triplets% is the first field in the descriptor. */ + tree triplets_field = TYPE_FIELDS (TREE_TYPE (exp)); + return fold_build3 (COMPONENT_REF, + TREE_TYPE (triplets_field), + exp, + triplets_field, + NULL_TREE); +} + +/* Return the pointer to the elements of the multiple EXP. */ + +tree +a68_multiple_elements (tree exp) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp))); + + /* elements% is the second field in the descriptor. */ + tree elements_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))); + return fold_build3 (COMPONENT_REF, + TREE_TYPE (elements_field), + exp, + elements_field, + NULL_TREE); +} + +/* Return an expression that sets the elements% field of EXP to ELEMENTS. */ + +tree +a68_multiple_set_elements (tree exp, tree elements) +{ + /* elements% is the second field in the descriptor. */ + tree elements_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))); + return fold_build2 (MODIFY_EXPR, + TREE_TYPE (elements_field), + fold_build3 (COMPONENT_REF, + TREE_TYPE (elements_field), + exp, + elements_field, + NULL_TREE), + elements); +} + +/* Return an expression that sets the elements_size% field of EXP to + ELEMENTS_SIZE, which must be a sizetype. */ + +tree +a68_multiple_set_elements_size (tree exp, tree elements_size) +{ + /* elements_size% is the third field in the descriptor. */ + tree elements_size_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp)))); + return fold_build2 (MODIFY_EXPR, + TREE_TYPE (elements_size_field), + fold_build3 (COMPONENT_REF, + TREE_TYPE (elements_size_field), + exp, + elements_size_field, + NULL_TREE), + elements_size); +} + +/* Given two arrays of LOWER_BOUNDs and UPPER_BOUNDs corresponding to DIM + dimensions of a multiple of type TYPE, fill in the strides in STRIDES, which + is assumed to be a buffer big enough to hold DIM tree nodes. The bounds + shall be of type ssizetype, and the calculated strides are of type sizetype, + i.e. unsigned. */ + +void +a68_multiple_compute_strides (tree type, size_t dim, + tree *lower_bounds, tree *upper_bounds, + tree *strides) +{ + tree stride = size_in_bytes (a68_row_elements_type (type)); + for (ssize_t i = dim - 1; i >= 0; --i) + { + strides[i] = stride; + + /* Calculate the stride for the previous dimension. */ + tree dim_num_elems + = save_expr (fold_build2 (PLUS_EXPR, + sizetype, + fold_convert (sizetype, + fold_build2 (MINUS_EXPR, ssizetype, + upper_bounds[i], lower_bounds[i])), + size_one_node)); + stride = fold_build2 (MULT_EXPR, sizetype, stride, dim_num_elems); + } +} + +/* Return a constructor for a multiple of row type TYPE, using TRIPLETS and + ELEMENTS. ELEMENTS_SIZE is the size in bytes of the memory pointed by + ELEMENTS. */ + +tree +a68_row_value_raw (tree type, tree triplets, + tree elements, tree elements_size) +{ + tree triplets_field; + tree elements_field; + tree elements_size_field; + vec *ce = NULL; + + gcc_assert (A68_ROW_TYPE_P (type)); + triplets_field = TYPE_FIELDS (type); + elements_field = TREE_CHAIN (triplets_field); + elements_size_field = TREE_CHAIN (elements_field); + CONSTRUCTOR_APPEND_ELT (ce, triplets_field, triplets); + CONSTRUCTOR_APPEND_ELT (ce, elements_field, + fold_build1 (CONVERT_EXPR ,TREE_TYPE (elements_field), elements)); + CONSTRUCTOR_APPEND_ELT (ce, elements_size_field, elements_size); + return build_constructor (type, ce); +} + +/* Return a constructor for a multiple of row type TYPE, of DIM dimensions and + pointing to ELEMENTS. + + ELEMENTS_SIZE contains the size in bytes of the memory pointed by ELEMENTS. + + *LOWER_BOUND and *UPPER_BOUND are the bounds for the DIM dimensions. +*/ + +tree +a68_row_value (tree type, size_t dim, + tree elements, tree elements_size, + tree *lower_bound, tree *upper_bound) +{ + tree triplets_field; + tree elements_field; + tree elements_size_field; + vec *ce = NULL; + + gcc_assert (A68_ROW_TYPE_P (type)); + triplets_field = TYPE_FIELDS (type); + elements_field = TREE_CHAIN (triplets_field); + elements_size_field = TREE_CHAIN (elements_field); + + tree triplet_type = TREE_TYPE (TREE_TYPE (triplets_field)); + tree lower_bound_field = TYPE_FIELDS (triplet_type); + tree upper_bound_field = TREE_CHAIN (TYPE_FIELDS (triplet_type)); + tree stride_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (triplet_type))); + + /* Calculate strides. */ + tree *strides = (tree *) xmalloc (sizeof (tree) * dim); + a68_multiple_compute_strides (type, dim, lower_bound, upper_bound, strides); + + vec *triplets_ce = NULL; + for (size_t i = 0; i < dim; ++i) + { + CONSTRUCTOR_APPEND_ELT (triplets_ce, + size_int (i), + build_constructor_va (triplet_type, + 3, + lower_bound_field, lower_bound[i], + upper_bound_field, upper_bound[i], + stride_field, strides[i])); + } + free (strides); + CONSTRUCTOR_APPEND_ELT (ce, triplets_field, + build_constructor (TREE_TYPE (triplets_field), triplets_ce)); + CONSTRUCTOR_APPEND_ELT (ce, elements_field, + fold_build1 (CONVERT_EXPR, TREE_TYPE (elements_field), elements)); + CONSTRUCTOR_APPEND_ELT (ce, elements_size_field, + elements_size ? elements_size : size_zero_node); + tree multiple = build_constructor (type, ce); + return multiple; +} + +/* Build a tree to slice a multiple given a set of indexes. + + P is the tree node corresponding to the slice. It is used as the source of + location information. + + MULTIPLE is the multiple value being sliced. If SLICING_NAME is true, it + means the slicing operation is for a name and therefore it must yield a + name. + + INDEXES is a list of NUM_INDEXES indexes, which are units. + NUM_INDEXES must match the dimension of the multiple. */ + +tree +a68_multiple_slice (NODE_T *p, + tree multiple, bool slicing_name, + int num_indexes, tree *indexes) +{ + tree slice = NULL_TREE; + tree bounds_check = NULL_TREE; + + multiple = save_expr (multiple); + tree index = NULL_TREE; + for (int idx = 0; idx < num_indexes; ++idx) + { + tree lower_bound = a68_multiple_lower_bound (multiple, size_int (idx)); + tree index_expr = save_expr (indexes[idx]); + + /* Do run-time bound checking if requested. */ + if (OPTION_BOUNDS_CHECKING (&A68_JOB)) + { + tree upper_bound = a68_multiple_upper_bound (multiple, size_int (idx)); + unsigned int lineno = NUMBER (LINE (INFO (p))); + const char *filename_str = FILENAME (LINE (INFO (p))); + tree filename = build_string_literal (strlen (filename_str) + 1, + filename_str); + tree call = a68_build_libcall (A68_LIBCALL_ARRAYBOUNDS, + void_type_node, 5, + filename, + build_int_cst (unsigned_type_node, lineno), + fold_convert (ssizetype, index_expr), + fold_convert (ssizetype, lower_bound), + fold_convert (ssizetype, upper_bound)); + call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node); + + /* If LB > UB, the dimension contains no elements. + Otherwise, it must hold IDX >= LB && IDX <= UB */ + tree dim_bounds_check = fold_build2 (TRUTH_AND_EXPR, sizetype, + fold_build2 (LE_EXPR, ssizetype, + lower_bound, upper_bound), + fold_build2 (TRUTH_AND_EXPR, + boolean_type_node, + fold_build2 (GE_EXPR, ssizetype, + fold_convert (ssizetype, + index_expr), + lower_bound), + fold_build2 (LE_EXPR, ssizetype, + fold_convert (ssizetype, + index_expr), + upper_bound))); + dim_bounds_check = fold_build2_loc (a68_get_node_location (p), + TRUTH_ORIF_EXPR, + ssizetype, + dim_bounds_check, call); + + /* bounds_check_ok || call_runtime_error */ + if (bounds_check == NULL_TREE) + bounds_check = dim_bounds_check; + else + bounds_check = fold_build2 (TRUTH_ANDIF_EXPR, + ssizetype, + bounds_check, + dim_bounds_check); + } + + /* Now add the effect of this dimension's subscript in the index. Note + that the stride is expressed in bytes. */ + tree stride = a68_multiple_stride (multiple, size_int (idx)); + tree adjusted_index + = fold_convert (sizetype, fold_build2 (MINUS_EXPR, ssizetype, + fold_convert (ssizetype, index_expr), + lower_bound)); + tree term = fold_build2 (MULT_EXPR, sizetype, + adjusted_index, stride); + if (index == NULL_TREE) + index = term; + else + index = fold_build2 (PLUS_EXPR, sizetype, + index, term); + } + + tree elements = a68_multiple_elements (multiple); + tree element_pointer_type = TREE_TYPE (elements); + tree element_type = TREE_TYPE (element_pointer_type); + + /* Now refer to the indexed element. In case we are slicing a ref to a + multiple, return the address of the element and not the element + itself. */ + tree element_address = fold_build2 (POINTER_PLUS_EXPR, + element_pointer_type, + elements, + index); + if (slicing_name) + slice = element_address; + else + slice = fold_build2 (MEM_REF, + element_type, + fold_build2 (POINTER_PLUS_EXPR, + element_pointer_type, + elements, + index), + fold_convert (element_pointer_type, + integer_zero_node)); + + /* Prepend bounds checking code if necessary. */ + if (bounds_check != NULL_TREE) + { + slice = fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (slice), + bounds_check, + slice); + } + + return slice; +} + +/* Auxiliary routine for a68_multiple_copy_elemens. */ + +static tree +copy_multiple_dimension_elems (size_t dim, size_t num_dimensions, + tree to, tree from, + tree to_elements, tree from_elements, + tree *to_offset, tree *from_offset, + tree *indexes) +{ + tree element_pointer_type = TREE_TYPE (from_elements); + tree element_type = TREE_TYPE (element_pointer_type); + tree upb = a68_multiple_upper_bound (from, size_int (dim)); + + char *name = xasprintf ("r" HOST_SIZE_T_PRINT_DEC "%%", (fmt_size_t) dim); + indexes[dim] = a68_lower_tmpvar (name, ssizetype, + a68_multiple_lower_bound (from, + size_int (dim))); + free (name); + + /* Loop body. */ + a68_push_range (NULL); + { + /* if (indexes[dim] > upb) break; */ + a68_add_stmt (fold_build1 (EXIT_EXPR, void_type_node, + fold_build2 (GT_EXPR, size_type_node, + indexes[dim], upb))); + + /* Add this dimension's contribution to the offsets. */ + tree index = fold_convert (sizetype, + fold_build2 (MINUS_EXPR, ssizetype, + upb, indexes[dim])); + *to_offset = fold_build2 (PLUS_EXPR, sizetype, + *to_offset, + fold_build2 (MULT_EXPR, sizetype, + index, + a68_multiple_stride (to, size_int (dim)))); + *from_offset = fold_build2 (PLUS_EXPR, sizetype, + *from_offset, + fold_build2 (MULT_EXPR, sizetype, + index, + a68_multiple_stride (from, size_int (dim)))); + + if (dim == num_dimensions - 1) + { + /* Most inner loop, copy one element. */ + + tree to_off = a68_lower_tmpvar ("to_offset%", sizetype, *to_offset); + tree from_off = a68_lower_tmpvar ("from_offset%", sizetype, *from_offset); + + tree to_elem = fold_build2 (MEM_REF, + element_type, + fold_build2 (POINTER_PLUS_EXPR, + element_pointer_type, + to_elements, + to_off), + fold_convert (element_pointer_type, + integer_zero_node)); + tree from_elem = fold_build2 (MEM_REF, + element_type, + fold_build2 (POINTER_PLUS_EXPR, + element_pointer_type, + from_elements, + from_off), + fold_convert (element_pointer_type, + integer_zero_node)); + + /* XXX + if may_overlap then modify only if dst_offset < src_offset */ + a68_add_stmt (fold_build2 (MODIFY_EXPR, element_type, + to_elem, from_elem)); + } + else + { + a68_add_stmt (copy_multiple_dimension_elems (dim + 1, num_dimensions, + to, from, + to_elements, from_elements, + to_offset, from_offset, + indexes)); + } + + /* indexes[dim]++ */ + a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, ssizetype, + indexes[dim], ssize_int (1))); + } + tree loop_body = a68_pop_range (); + + return fold_build1 (LOOP_EXPR, void_type_node, loop_body); +} + +/* Copy the elements of a given multiple (string) FROM to the multiple (string) + TO. + + The dimensions and bounds of both multiples are supposed to match, and they + are supposed to not be flat. + + XXX simple cases with same strides may be done with a memcpy. + XXX compile this into a support routine to reduce code size. */ + +tree +a68_multiple_copy_elems (MOID_T *mode, tree to, tree from) +{ + gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (to)) + && A68_ROW_TYPE_P (TREE_TYPE (from))); + + /* Deflex modes as needed and determine dimension. */ + if (IS_FLEX (mode)) + mode = SUB (mode); + int num_dimensions = (mode == M_STRING ? 1 : DIM (mode)); + + a68_push_range (NULL); + to = a68_lower_tmpvar ("to%", TREE_TYPE (to), to); + from = a68_lower_tmpvar ("from%", TREE_TYPE (from), from); + tree from_elements = a68_multiple_elements (from); + tree element_pointer_type = TREE_TYPE (from_elements); + from_elements = a68_lower_tmpvar ("from_elements%", element_pointer_type, + from_elements); + tree to_elements = a68_lower_tmpvar ("to_elements%", element_pointer_type, + a68_multiple_elements (to)); + + tree *indexes = (tree *) xmalloc (num_dimensions * sizeof (tree)); + tree to_offset = size_zero_node; + tree from_offset = size_zero_node; + a68_add_stmt (copy_multiple_dimension_elems (0 /* dim */, num_dimensions, + to, from, + to_elements, from_elements, + &to_offset, &from_offset, + indexes)); + free (indexes); + return a68_pop_range (); +} + +/* Given a rows type, return the number of dimensions. */ + +tree +a68_rows_dim (tree exp) +{ + gcc_assert (A68_ROWS_TYPE_P (TREE_TYPE (exp))); + + /* dim% is the first field in the rows struct. */ + tree dim_field = TYPE_FIELDS (TREE_TYPE (exp)); + return fold_build3 (COMPONENT_REF, + TREE_TYPE (dim_field), + exp, + dim_field, + NULL_TREE); +} + +/* Given a multiple value, create a rows value reflecting the multiple's + dimensions and triplets. */ + +tree +a68_rows_value (tree multiple) +{ + tree rows_type = CTYPE (M_ROWS); + tree dim_field = TYPE_FIELDS (rows_type); + tree triplets_field = TREE_CHAIN (dim_field); + + tree dimensions = save_expr (a68_multiple_dimensions (multiple)); + tree triplets = fold_build1 (ADDR_EXPR, TREE_TYPE (triplets_field), + a68_multiple_triplets (multiple)); + return build_constructor_va (rows_type, 2, + dim_field, dimensions, + triplets_field, triplets); +} + +/* Given a rows value and a dimension number, return the upper bound or the + lower of the given dimension. The returned bound is a ssizetype. + + DIM must be a sizetype. */ + +static tree +rows_lower_or_upper_bound (tree rows, tree dim, bool upper) +{ + tree rows_type = TREE_TYPE (rows); + tree triplet_type = a68_triplet_type (); + tree triplet_pointer_type = build_pointer_type (triplet_type); + tree triplet_lb_field = TYPE_FIELDS (triplet_type); + tree triplet_ub_field = TREE_CHAIN (TYPE_FIELDS (triplet_type)); + tree triplets_field = TREE_CHAIN (TYPE_FIELDS (rows_type)); + tree triplets = fold_build3 (COMPONENT_REF, triplet_pointer_type, + rows, triplets_field, NULL_TREE); + tree triplet_offset = fold_build2 (MULT_EXPR, sizetype, + dim, + size_in_bytes (triplet_type)); + tree bound = fold_build3 (COMPONENT_REF, ssizetype, + fold_build1 (INDIRECT_REF, triplet_type, + fold_build2 (POINTER_PLUS_EXPR, + triplet_pointer_type, + triplets, + triplet_offset)), + upper ? triplet_ub_field : triplet_lb_field, + NULL_TREE); + + return bound; +} + +/* Return the lower bound of dimension DIM of ROWS. */ + +tree +a68_rows_lower_bound (tree rows, tree dim) +{ + return rows_lower_or_upper_bound (rows, dim, false); +} + +/* Return the upper bound of dimension DIM of ROWS. */ + +tree +a68_rows_upper_bound (tree rows, tree dim) +{ + return rows_lower_or_upper_bound (rows, dim, true); +} + +/* Return a tree that checks that a given INDEX is correct given a multiple's + bounds in a given rank DIM. + + If UPPER_BOUND is true then INDEX shall be less or equal than the multiple's + upper bound. Otherwise INDEX shall be bigger or equal than the multiple's + lower bound. + + If the condition above doesn't hold then a call to a run-time function is + performed: if UPPER_BOUND is true then ARRAYUPPERBOUND is called. Otherwise + ARRAYLOWERBOUND is called. */ + +tree +a68_multiple_single_bound_check (NODE_T *p, tree dim, + tree multiple, tree index, bool upper_bound) +{ + index = save_expr (index); + multiple = save_expr (multiple); + + tree bound = (upper_bound + ? a68_multiple_upper_bound (multiple, dim) + : a68_multiple_lower_bound (multiple, dim)); + a68_libcall_fn libcall = (upper_bound + ? A68_LIBCALL_ARRAYUPPERBOUND + : A68_LIBCALL_ARRAYLOWERBOUND); + + /* Build the call to ARRAY*BOUNDS. */ + unsigned int lineno = NUMBER (LINE (INFO (p))); + const char *filename_str = FILENAME (LINE (INFO (p))); + tree filename = build_string_literal (strlen (filename_str) + 1, + filename_str); + tree call = a68_build_libcall (libcall, + void_type_node, 4, + filename, + build_int_cst (unsigned_type_node, lineno), + fold_convert (ssizetype, index), + fold_convert (ssizetype, bound)); + call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node); + + tree bounds_check = fold_build2 (upper_bound ? LE_EXPR : GE_EXPR, + ssizetype, + fold_convert (ssizetype, index), + bound); + return fold_build2_loc (a68_get_node_location (p), + TRUTH_ORIF_EXPR, + ssizetype, + bounds_check, call); +} + +/* Return a tree that checks whether the given DIM is a valid dimension/rank of + a boundable object with dimension BOUNDABLE_DIM. If the provided DIM is not + a valid dimention then a call to the run-time function ARRAYDIM is + performed. + + BOUNDABLE_DIM and DIM must be of type sizetype. They are both one-based. + + The parse tree node P is used as the source for the filename and line number + passed to the run-time function. */ + +static tree +a68_boundable_dim_check (NODE_T *p, tree boundable_dim, tree dim) +{ + boundable_dim = save_expr (boundable_dim); + dim = save_expr (dim); + + /* Build the call to ARRAYDIM. */ + unsigned int lineno = NUMBER (LINE (INFO (p))); + const char *filename_str = FILENAME (LINE (INFO (p))); + tree filename = build_string_literal (strlen (filename_str) + 1, + filename_str); + tree call = a68_build_libcall (A68_LIBCALL_ARRAYDIM, + void_type_node, 4, + filename, + build_int_cst (unsigned_type_node, lineno), + boundable_dim, dim); + call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node); + + tree dim_check = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, + fold_build2 (GT_EXPR, boolean_type_node, dim, size_zero_node), + fold_build2 (LE_EXPR, boolean_type_node, dim, boundable_dim)); + return fold_build2_loc (a68_get_node_location (p), + TRUTH_ORIF_EXPR, + ssizetype, + dim_check, call); +} + +/* Return a tree that checks whether the given DIM is a valid dimension/rank of + the given rows value ROWS. + + DIM is a sizetype. + The parse tree node P is used as the source for the filename and line + number. */ + +tree +a68_rows_dim_check (NODE_T *p, tree rows, tree dim) +{ + return a68_boundable_dim_check (p, a68_rows_dim (rows), dim); +} + +/* Return a tree that checks whether the given DIM is a valid dimension/rank of + the given multiple value MULTIPLE. + + DIM is a sizetype. + The parse tree node P is used as the source for the filename and line + number. */ + +tree +a68_multiple_dim_check (NODE_T *p, tree multiple, tree dim) +{ + return a68_boundable_dim_check (p, a68_multiple_dimensions (multiple), dim); +} + +/* Return a tree that checks whether the given INDEX falls within the bounds of + MULTIPLE in the rank DIM. If the provided index is out of bounds then a + call to the run-time function ARRAYBOUNDS is performed. + + DIM must be a sizetype. + MULTIPLE must be a multiple value. + INDEX must be a ssizetype. + + The parse tree node P is used as the source for the filename and line number + passed to the run-time function. */ + +tree +a68_multiple_bounds_check (NODE_T *p, tree dim, + tree multiple, tree index) +{ + index = save_expr (index); + multiple = save_expr (multiple); + + tree upper_bound = a68_multiple_upper_bound (multiple, dim); + tree lower_bound = a68_multiple_lower_bound (multiple, dim); + + /* Build the call to ARRAYBOUNDS. */ + unsigned int lineno = NUMBER (LINE (INFO (p))); + const char *filename_str = FILENAME (LINE (INFO (p))); + tree filename = build_string_literal (strlen (filename_str) + 1, + filename_str); + tree call = a68_build_libcall (A68_LIBCALL_ARRAYBOUNDS, + void_type_node, 5, + filename, + build_int_cst (unsigned_type_node, lineno), + fold_convert (ssizetype, index), + fold_convert (ssizetype, lower_bound), + fold_convert (ssizetype, upper_bound)); + call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node); + + /* If LB > UB, the dimension contains no elements. + Otherwise, it must hold IDX >= LB && IDX <= UB */ + tree bounds_check = fold_build2 (TRUTH_AND_EXPR, sizetype, + fold_build2 (LE_EXPR, ssizetype, + lower_bound, upper_bound), + fold_build2 (TRUTH_AND_EXPR, + boolean_type_node, + fold_build2 (GE_EXPR, ssizetype, + fold_convert (ssizetype, + index), + lower_bound), + fold_build2 (LE_EXPR, ssizetype, + fold_convert (ssizetype, + index), + upper_bound))); + return fold_build2_loc (a68_get_node_location (p), + TRUTH_ORIF_EXPR, + ssizetype, + bounds_check, call); +} + +/* Emit a run-time error if the bounds of M1 and M2 are not the same. Both + multiples are assumed to have the same type and therefore feature the same + number of dimensions. */ + +tree +a68_multiple_bounds_check_equal (NODE_T *p, tree m1, tree m2) +{ + m1 = save_expr (m1); + m2 = save_expr (m2); + + /* First determine the rank of the multiples and check they match. */ + tree m1_dimensions = a68_multiple_dimensions (m1); + tree m2_dimensions = a68_multiple_dimensions (m2); + gcc_assert (TREE_CODE (m1_dimensions) == INTEGER_CST + && TREE_CODE (m2_dimensions) == INTEGER_CST); + + int dim1 = tree_to_shwi (m1_dimensions); + int dim2 = tree_to_shwi (m2_dimensions); + gcc_assert (dim1 == dim2); + + a68_push_range (NULL /* VOID */); + + /* For each dimension, check that bounds are the same in both multiples. */ + int i; + for (i = 0; i < dim1; ++i) + { + tree dim_tree = build_int_cst (ssizetype, i); + tree dim_plus_one = fold_build2 (PLUS_EXPR, ssizetype, + dim_tree, + fold_convert (ssizetype, size_one_node)); + + tree lb1 = save_expr (a68_multiple_lower_bound (m1, dim_tree)); + tree lb2 = save_expr (a68_multiple_lower_bound (m2, dim_tree)); + + tree ub1 = save_expr (a68_multiple_upper_bound (m1, dim_tree)); + tree ub2 = save_expr (a68_multiple_upper_bound (m2, dim_tree)); + + tree bounds_equal = fold_build2 (TRUTH_AND_EXPR, + boolean_type_node, + fold_build2 (EQ_EXPR, boolean_type_node, + lb1, lb2), + fold_build2 (EQ_EXPR, boolean_type_node, + ub1, ub2)); + + unsigned int lineno = NUMBER (LINE (INFO (p))); + const char *filename_str = FILENAME (LINE (INFO (p))); + tree filename = build_string_literal (strlen (filename_str) + 1, + filename_str); + tree call = a68_build_libcall (A68_LIBCALL_ARRAYBOUNDSMISMATCH, + void_type_node, 7, + filename, + build_int_cst (unsigned_type_node, lineno), + dim_plus_one, + lb1, ub1, lb2, ub2); + call = fold_build2 (COMPOUND_EXPR, boolean_type_node, call, boolean_false_node); + + tree check = fold_build2_loc (a68_get_node_location (p), + TRUTH_ORIF_EXPR, boolean_type_node, + bounds_equal, + call); + a68_add_stmt (check); + } + + return a68_pop_range (); +} + +/* Allocate a multiple on the heap. + + M is the mode the multiple to allocate. + DIM is the number of dimensions of the multiple. + ELEMS is a pointer to the elements of the multiple. + ELEMS_SIZE is the size in bytes of ELEMS. + *LOWER_BOUND and *UPPER_BOUND are the bounds for the DIM dimensions. */ + +tree +a68_row_malloc (tree type, int dim, tree elems, tree elems_size, + tree *lower_bound, tree *upper_bound) +{ + tree ptr_to_type = build_pointer_type (type); + + a68_push_range (NULL); + + /* Allocate space for the descriptor. */ + tree ptr_to_multiple = a68_lower_tmpvar ("ptr_to_multiple%", ptr_to_type, + a68_lower_malloc (type, size_in_bytes (type))); + tree multiple = a68_row_value (type, dim, + elems, elems_size, + lower_bound, upper_bound); + a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node, + fold_build1 (INDIRECT_REF, type, ptr_to_multiple), + multiple)); + a68_add_stmt (ptr_to_multiple); + tree res = a68_pop_range (); + TREE_TYPE (res) = ptr_to_type; + return res; +} diff --git a/gcc/algol68/a68-low-posix.cc b/gcc/algol68/a68-low-posix.cc new file mode 100644 index 000000000000..6b6ae76cf375 --- /dev/null +++ b/gcc/algol68/a68-low-posix.cc @@ -0,0 +1,559 @@ +/* Lowering routines for the POSIX prelude. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Set the exit status of the running process, to be returned to the OS upon + exit. */ + +tree +a68_posix_setexitstatus (void) +{ + return a68_get_libcall (A68_LIBCALL_SET_EXIT_STATUS); +} + +/* Number of command line arguments passed to the program. */ + +tree +a68_posix_argc (void) +{ + return a68_get_libcall (A68_LIBCALL_POSIX_ARGC); +} + +/* Gets the Nth command line argument passed to the program. If N is out of + range the result is an empty string. */ + +tree +a68_posix_argv (void) +{ + static tree argv_fndecl; + + if (argv_fndecl == NULL_TREE) + { + argv_fndecl + = a68_low_toplevel_func_decl ("argv", + build_function_type_list (CTYPE (M_STRING), + a68_int_type, + NULL_TREE)); + announce_function (argv_fndecl); + + tree param = a68_low_func_param (argv_fndecl, "n", a68_int_type); + DECL_ARGUMENTS (argv_fndecl) = param; + + a68_push_function_range (argv_fndecl, CTYPE (M_STRING), + true /* top_level */); + + a68_push_range (M_STRING); + tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0)); + TREE_ADDRESSABLE (len) = 1; + + tree ptrtochar_type = build_pointer_type (a68_char_type); + tree elems = a68_lower_tmpvar ("elems%", ptrtochar_type, + a68_build_libcall (A68_LIBCALL_POSIX_ARGV, + ptrtochar_type, 2, + param, + fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), + len))); + tree lower_bound = ssize_int (1); + tree upper_bound = fold_convert (ssizetype, len); + tree elems_size = fold_build2 (MULT_EXPR, sizetype, + len, + size_in_bytes (a68_char_type)); + a68_add_stmt (a68_row_value (CTYPE (M_STRING), 1 /* dim */, + elems, elems_size, + &lower_bound, &upper_bound)); + tree body = a68_pop_range (); + a68_pop_function_range (body); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (argv_fndecl)), + argv_fndecl); +} + +/* Gets the value of an environment variable, or an empty string if the + variable is not set. */ + +tree +a68_posix_getenv (void) +{ + static tree getenv_fndecl; + + if (getenv_fndecl == NULL_TREE) + { + getenv_fndecl + = a68_low_toplevel_func_decl ("getenv", + build_function_type_list (CTYPE (M_STRING), + CTYPE (M_STRING), + NULL_TREE)); + announce_function (getenv_fndecl); + + tree param = a68_low_func_param (getenv_fndecl, "varname", CTYPE (M_STRING)); + DECL_ARGUMENTS (getenv_fndecl) = param; + + a68_push_function_range (getenv_fndecl, CTYPE (M_STRING), + true /* top_level */); + + a68_push_range (M_STRING); + + tree varname = a68_lower_tmpvar ("varname%", CTYPE (M_STRING), + param); + + tree ptrtochar_type = build_pointer_type (a68_char_type); + tree convelems = a68_lower_tmpvar ("convelems%", ptrtochar_type, + build_int_cst (ptrtochar_type, 0)); + TREE_ADDRESSABLE (convelems) = 1; + tree convelemslen = a68_lower_tmpvar ("convelemslen%", sizetype, + size_int (0)); + TREE_ADDRESSABLE (convelemslen) = 1; + + tree call = a68_build_libcall (A68_LIBCALL_POSIX_GETENV, + void_type_node, 5, + a68_multiple_elements (varname), + a68_multiple_num_elems (varname), + a68_multiple_stride (varname, size_zero_node), + fold_build1 (ADDR_EXPR, build_pointer_type (ptrtochar_type), + convelems), + fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), + convelemslen)); + a68_add_stmt (call); + tree lower_bound = ssize_int (1); + tree upper_bound = fold_convert (ssizetype, convelemslen); + tree convelems_size = fold_build2 (MULT_EXPR, sizetype, + convelemslen, + size_in_bytes (a68_char_type)); + a68_add_stmt (a68_row_value (CTYPE (M_STRING), 1 /* dim */, + convelems, convelems_size, + &lower_bound, &upper_bound)); + tree body = a68_pop_range (); + a68_pop_function_range (body); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (getenv_fndecl)), + getenv_fndecl); +} + +tree +a68_posix_putchar (void) +{ + return a68_get_libcall (A68_LIBCALL_POSIX_PUTCHAR); +} + +tree +a68_posix_puts (void) +{ + static tree puts_fndecl; + + if (puts_fndecl == NULL_TREE) + { + puts_fndecl + = a68_low_toplevel_func_decl ("puts", + build_function_type_list (void_type_node, + CTYPE (M_STRING), + NULL_TREE)); + announce_function (puts_fndecl); + + tree param = a68_low_func_param (puts_fndecl, "str", CTYPE (M_STRING)); + DECL_ARGUMENTS (puts_fndecl) = param; + + a68_push_function_range (puts_fndecl, void_type_node, + true /* top_level */); + + tree call = a68_build_libcall (A68_LIBCALL_POSIX_PUTS, + void_type_node, 3, + a68_multiple_elements (param), + a68_multiple_num_elems (param), + a68_multiple_stride (param, size_zero_node)); + a68_pop_function_range (call); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (puts_fndecl)), + puts_fndecl); +} + +tree +a68_posix_fconnect (void) +{ + static tree fconnect_fndecl; + + if (fconnect_fndecl == NULL_TREE) + { + fconnect_fndecl + = a68_low_toplevel_func_decl ("fconnect", + build_function_type_list (a68_int_type, + CTYPE (M_STRING), + a68_bits_type, + NULL_TREE)); + announce_function (fconnect_fndecl); + + tree host = a68_low_func_param (fconnect_fndecl, "host", CTYPE (M_STRING)); + tree port = a68_low_func_param (fconnect_fndecl, "port", a68_int_type); + DECL_ARGUMENTS (fconnect_fndecl) = chainon (host, port); + + a68_push_function_range (fconnect_fndecl, a68_int_type, + true /* top_level */); + + + tree body = a68_build_libcall (A68_LIBCALL_POSIX_FCONNECT, + a68_int_type, 4, + a68_multiple_elements (host), + a68_multiple_num_elems (host), + a68_multiple_stride (host, size_zero_node), + port); + a68_pop_function_range (body); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fconnect_fndecl)), + fconnect_fndecl); +} + +tree +a68_posix_fcreate (void) +{ + static tree fcreate_fndecl; + + if (fcreate_fndecl == NULL_TREE) + { + fcreate_fndecl + = a68_low_toplevel_func_decl ("fcreate", + build_function_type_list (a68_int_type, + CTYPE (M_STRING), + a68_bits_type, + NULL_TREE)); + announce_function (fcreate_fndecl); + + tree pathname = a68_low_func_param (fcreate_fndecl, "pathname", CTYPE (M_STRING)); + tree mode = a68_low_func_param (fcreate_fndecl, "mode", a68_int_type); + DECL_ARGUMENTS (fcreate_fndecl) = chainon (pathname, mode); + + a68_push_function_range (fcreate_fndecl, a68_int_type, + true /* top_level */); + + + tree body = a68_build_libcall (A68_LIBCALL_POSIX_FCREATE, + a68_int_type, 4, + a68_multiple_elements (pathname), + a68_multiple_num_elems (pathname), + a68_multiple_stride (pathname, size_zero_node), + mode); + a68_pop_function_range (body); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fcreate_fndecl)), + fcreate_fndecl); +} + +tree +a68_posix_fopen (void) +{ + static tree fopen_fndecl; + + if (fopen_fndecl == NULL_TREE) + { + fopen_fndecl + = a68_low_toplevel_func_decl ("fopen", + build_function_type_list (a68_int_type, + CTYPE (M_STRING), + a68_bits_type, + NULL_TREE)); + announce_function (fopen_fndecl); + + tree pathname = a68_low_func_param (fopen_fndecl, "pathname", CTYPE (M_STRING)); + tree flags = a68_low_func_param (fopen_fndecl, "flags", a68_int_type); + DECL_ARGUMENTS (fopen_fndecl) = chainon (pathname, flags); + + a68_push_function_range (fopen_fndecl, a68_int_type, + true /* top_level */); + + + tree body = a68_build_libcall (A68_LIBCALL_POSIX_FOPEN, + a68_int_type, 4, + a68_multiple_elements (pathname), + a68_multiple_num_elems (pathname), + a68_multiple_stride (pathname, size_zero_node), + flags); + a68_pop_function_range (body); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fopen_fndecl)), + fopen_fndecl); +} + +tree +a68_posix_fclose (void) +{ + return a68_get_libcall (A68_LIBCALL_POSIX_FCLOSE); +} + +tree +a68_posix_fsize (void) +{ + return a68_get_libcall (A68_LIBCALL_POSIX_FSIZE); +} + +tree +a68_posix_lseek (void) +{ + return a68_get_libcall (A68_LIBCALL_POSIX_LSEEK); +} + +tree +a68_posix_errno (void) +{ + return a68_get_libcall (A68_LIBCALL_POSIX_ERRNO); +} + +tree +a68_posix_perror (void) +{ + static tree perror_fndecl; + + if (perror_fndecl == NULL_TREE) + { + perror_fndecl + = a68_low_toplevel_func_decl ("perror", + build_function_type_list (void_type_node, + CTYPE (M_STRING), + NULL_TREE)); + announce_function (perror_fndecl); + + tree str = a68_low_func_param (perror_fndecl, "str", CTYPE (M_STRING)); + DECL_ARGUMENTS (perror_fndecl) = str; + + a68_push_function_range (perror_fndecl, void_type_node, + true /* top_level */); + + tree body = a68_build_libcall (A68_LIBCALL_POSIX_PERROR, + a68_int_type, 3, + a68_multiple_elements (str), + a68_multiple_num_elems (str), + a68_multiple_stride (str, size_zero_node)); + a68_pop_function_range (body); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (perror_fndecl)), + perror_fndecl); +} + +tree +a68_posix_strerror (void) +{ + static tree strerror_fndecl; + + if (strerror_fndecl == NULL_TREE) + { + strerror_fndecl + = a68_low_toplevel_func_decl ("strerror", + build_function_type_list (CTYPE (M_STRING), + a68_int_type, + NULL_TREE)); + announce_function (strerror_fndecl); + + tree errnum = a68_low_func_param (strerror_fndecl, "errnum", a68_int_type); + DECL_ARGUMENTS (strerror_fndecl) = errnum; + + a68_push_function_range (strerror_fndecl, CTYPE (M_STRING), + true /* top_level */); + + tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0)); + TREE_ADDRESSABLE (len) = 1; + + tree call = a68_build_libcall (A68_LIBCALL_POSIX_STRERROR, + void_type_node, 2, + errnum, + fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), len)); + tree elems = a68_lower_tmpvar ("elems%", build_pointer_type (a68_char_type), call); + + tree lower_bound = ssize_int (1); + tree upper_bound = fold_convert (ssizetype, len); + tree elems_size = fold_build2 (MULT_EXPR, sizetype, + len, size_in_bytes (a68_char_type)); + + tree body = a68_row_value (CTYPE (M_STRING), 1 /* dim */, + elems, elems_size, + &lower_bound, &upper_bound); + a68_pop_function_range (body); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (strerror_fndecl)), + strerror_fndecl); +} + +tree +a68_posix_getchar (void) +{ + return a68_get_libcall (A68_LIBCALL_POSIX_GETCHAR); +} + +tree +a68_posix_fgetc (void) +{ + return a68_get_libcall (A68_LIBCALL_POSIX_FGETC); +} + +tree +a68_posix_fputc (void) +{ + return a68_get_libcall (A68_LIBCALL_POSIX_FPUTC); +} + +tree +a68_posix_fputs (void) +{ + static tree fputs_fndecl; + + if (fputs_fndecl == NULL_TREE) + { + fputs_fndecl + = a68_low_toplevel_func_decl ("fputs", + build_function_type_list (a68_int_type, + a68_int_type, + CTYPE (M_STRING), + NULL_TREE)); + announce_function (fputs_fndecl); + + tree fd = a68_low_func_param (fputs_fndecl, "fd", a68_int_type); + tree str = a68_low_func_param (fputs_fndecl, "str", CTYPE (M_STRING)); + DECL_ARGUMENTS (fputs_fndecl) = chainon (fd, str); + + a68_push_function_range (fputs_fndecl, a68_int_type, + true /* top_level */); + + + tree body = a68_build_libcall (A68_LIBCALL_POSIX_FPUTS, + a68_int_type, 4, + fd, + a68_multiple_elements (str), + a68_multiple_num_elems (str), + a68_multiple_stride (str, size_zero_node)); + a68_pop_function_range (body); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fputs_fndecl)), + fputs_fndecl); +} + +tree +a68_posix_fgets (void) +{ + static tree fgets_fndecl; + + if (fgets_fndecl == NULL_TREE) + { + fgets_fndecl + = a68_low_toplevel_func_decl ("fgets", + build_function_type_list (CTYPE (M_REF_STRING), + a68_int_type, + a68_int_type, + NULL_TREE)); + announce_function (fgets_fndecl); + + tree fd = a68_low_func_param (fgets_fndecl, "fd", a68_int_type); + tree n = a68_low_func_param (fgets_fndecl, "n", a68_int_type); + DECL_ARGUMENTS (fgets_fndecl) = chainon (fd, n); + + a68_push_function_range (fgets_fndecl, CTYPE (M_REF_STRING), + true /* top_level */); + + tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0)); + TREE_ADDRESSABLE (len) = 1; + + tree call = a68_build_libcall (A68_LIBCALL_POSIX_FGETS, + CTYPE (M_REF_STRING), 3, + fd, n, + fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), len)); + tree elems = a68_lower_tmpvar ("elems%", build_pointer_type (a68_char_type), call); + + tree lower_bound = ssize_int (1); + tree upper_bound = fold_convert (ssizetype, len); + tree elems_size = fold_build2 (MULT_EXPR, sizetype, + len, size_in_bytes (a68_char_type)); + tree body = a68_row_malloc (CTYPE (M_STRING), 1 /* dim */, + elems, elems_size, + &lower_bound, &upper_bound); + a68_pop_function_range (body); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fgets_fndecl)), + fgets_fndecl); +} + +tree +a68_posix_gets (void) +{ + static tree gets_fndecl; + + if (gets_fndecl == NULL_TREE) + { + gets_fndecl + = a68_low_toplevel_func_decl ("gets", + build_function_type_list (CTYPE (M_REF_STRING), + a68_int_type, + NULL_TREE)); + announce_function (gets_fndecl); + + tree n = a68_low_func_param (gets_fndecl, "n", a68_int_type); + DECL_ARGUMENTS (gets_fndecl) = n; + + a68_push_function_range (gets_fndecl, CTYPE (M_REF_STRING), + true /* top_level */); + + tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0)); + TREE_ADDRESSABLE (len) = 1; + + tree call = a68_build_libcall (A68_LIBCALL_POSIX_GETS, + CTYPE (M_REF_STRING), 2, + n, fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), len)); + tree elems = a68_lower_tmpvar ("elems%", build_pointer_type (a68_char_type), call); + + tree lower_bound = ssize_int (1); + tree upper_bound = fold_convert (ssizetype, len); + tree elems_size = fold_build2 (MULT_EXPR, sizetype, + len, size_in_bytes (a68_char_type)); + tree body = a68_row_malloc (CTYPE (M_STRING), 1 /* dim */, + elems, elems_size, + &lower_bound, &upper_bound); + a68_pop_function_range (body); + } + + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (gets_fndecl)), + gets_fndecl); +} diff --git a/gcc/algol68/a68-low-prelude.cc b/gcc/algol68/a68-low-prelude.cc new file mode 100644 index 000000000000..55c0895bec52 --- /dev/null +++ b/gcc/algol68/a68-low-prelude.cc @@ -0,0 +1,2193 @@ +/* Lower Algol 68 pre-defined operators and procedures. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "convert.h" + +#include "a68.h" + +/* The following handlers are for lowing the entities defined in + a68-parser-prelude.c. */ + +tree +a68_lower_unimplemented (NODE_T *p, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + fatal_error (a68_get_node_location (p), + "no lowering routine installed for construct. jemarch has been lazy"); +} + +tree +a68_lower_charabs2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_char_abs (op); +} + +tree +a68_lower_boolabs2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_bool_abs (op); +} + +tree +a68_lower_intabs2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_int_abs (op); +} + +tree +a68_lower_realabs2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_real_abs (op); +} + +tree +a68_lower_confirm2 (NODE_T *p, LOW_CTX_T ctx) +{ + /* Used to implement monadic +. */ + return a68_lower_tree (NEXT (SUB (p)), ctx); +} + +tree +a68_lower_negate2 (NODE_T *p, LOW_CTX_T ctx) +{ + return fold_build1_loc (a68_get_node_location (p), + NEGATE_EXPR, + CTYPE (MOID (p)), + a68_lower_tree (NEXT (SUB (p)), ctx)); +} + +/* Lower an ENTIER standard monadic operator. */ + +tree +a68_lower_entier2 (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *op = NEXT (SUB (p)); + return a68_real_entier (a68_lower_tree (op, ctx), MOID (p), MOID (op)); +} + +/* Lower a ROUND standard monadic operator. + + This operator gets a LONGSETY REAL and produces a LONGSETY INT which is the + nearest integer to the given real. */ + +tree +a68_lower_round2 (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *op = NEXT (SUB (p)); + return a68_real_round (a68_lower_tree (op, ctx), MOID (p), MOID (op)); +} + +tree +a68_lower_not2 (NODE_T *p, LOW_CTX_T ctx) +{ + return fold_build1_loc (a68_get_node_location (p), + TRUTH_NOT_EXPR, + CTYPE (MOID (p)), + a68_lower_tree (NEXT (SUB (p)), ctx)); +} + +tree +a68_lower_and3 (NODE_T *p, LOW_CTX_T ctx) +{ + return fold_build2_loc (a68_get_node_location (p), + TRUTH_AND_EXPR, + CTYPE (MOID (p)), + a68_lower_tree (SUB (p), ctx), + a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); +} + +tree +a68_lower_or3 (NODE_T *p, LOW_CTX_T ctx) +{ + return fold_build2_loc (a68_get_node_location (p), + TRUTH_OR_EXPR, + CTYPE (MOID (p)), + a68_lower_tree (SUB (p), ctx), + a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); +} + +tree +a68_lower_xor3 (NODE_T *p, LOW_CTX_T ctx) +{ + return fold_build2_loc (a68_get_node_location (p), + TRUTH_XOR_EXPR, + CTYPE (MOID (p)), + a68_lower_tree (SUB (p), ctx), + a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); +} + +tree +a68_lower_plus_int (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *m = MOID (p); + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_int_plus (m, op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_plus_real (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *m = MOID (p); + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_real_plus (m, op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_minus_int (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *m = MOID (p); + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_int_minus (m, op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_minus_real (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *m = MOID (p); + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_real_minus (m, op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_mult_int (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *m = MOID (p); + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_int_mult (m, op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_mult_real (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *m = MOID (p); + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_real_mult (m, op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_multab3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree lhs = a68_lower_tree (SUB (p), ctx); + lhs = a68_consolidate_ref (MOID (SUB (p)), lhs); + lhs = save_expr (lhs); + NODE_T *rhs_node = NEXT (NEXT (SUB (p))); + tree rhs = a68_lower_tree (rhs_node, ctx); + tree operation = fold_build2_loc (a68_get_node_location (p), + MULT_EXPR, + TREE_TYPE (rhs), + a68_low_deref (lhs, SUB (p)), + rhs); + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (lhs), + a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)), + lhs); +} + +tree +a68_lower_over3 (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *m = MOID (p); + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_int_div (m, op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_mod3 (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *m = MOID (p); + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_int_mod (m, op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_div3 (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_real_div (MOID (p), + a68_lower_tree (SUB (p), ctx), + a68_lower_tree (NEXT (NEXT (SUB (p))), ctx), + a68_get_node_location (p)); +} + +tree +a68_lower_rdiv3 (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_real_div (MOID (p), + fold_build1 (FLOAT_EXPR, CTYPE (MOID (p)), + a68_lower_tree (SUB (p), ctx)), + fold_build1 (FLOAT_EXPR, CTYPE (MOID (p)), + a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)), + a68_get_node_location (p)); +} + +tree +a68_lower_int_eq3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_int_eq (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_int_ne3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_int_ne (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_int_lt3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_int_lt (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_int_le3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_int_le (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_int_gt3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_int_gt (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_int_ge3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_int_ge (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_real_eq3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_real_eq (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_real_ne3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_real_ne (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_real_lt3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_real_lt (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_real_le3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_real_le (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_real_gt3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_real_gt (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_real_ge3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_real_ge (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_char_eq3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_char_eq (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_char_ne3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_char_ne (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_char_lt3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_char_lt (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_char_le3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_char_le (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_char_gt3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_char_gt (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_char_ge3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_char_ge (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_bool_eq3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_bool_eq (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_bool_ne3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_bool_ne (op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_sign2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_int_sign (op); +} + +tree +a68_lower_realsign2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_real_sign (op); +} + +tree +a68_lower_plusab3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree lhs = a68_lower_tree (SUB (p), ctx); + lhs = a68_consolidate_ref (MOID (SUB (p)), lhs); + lhs = save_expr (lhs); + NODE_T *rhs_node = NEXT (NEXT (SUB (p))); + tree rhs = a68_lower_tree (rhs_node, ctx); + tree operation = fold_build2_loc (a68_get_node_location (p), + PLUS_EXPR, + TREE_TYPE (rhs), + a68_low_deref (lhs, SUB (p)), + rhs); + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (lhs), + a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)), + lhs); +} + +tree +a68_lower_minusab3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree lhs = a68_lower_tree (SUB (p), ctx); + lhs = a68_consolidate_ref (MOID (SUB (p)), lhs); + lhs = save_expr (lhs); + NODE_T *rhs_node = NEXT (NEXT (SUB (p))); + tree rhs = a68_lower_tree (rhs_node, ctx); + tree operation = fold_build2_loc (a68_get_node_location (p), + MINUS_EXPR, + TREE_TYPE (rhs), + a68_low_deref (lhs, SUB (p)), + rhs); + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (lhs), + a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)), + lhs); +} + +tree +a68_lower_overab3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree lhs = a68_lower_tree (SUB (p), ctx); + lhs = a68_consolidate_ref (MOID (SUB (p)), lhs); + lhs = save_expr (lhs); + NODE_T *rhs_node = NEXT (NEXT (SUB (p))); + tree rhs = a68_lower_tree (rhs_node, ctx); + tree operation = fold_build2_loc (a68_get_node_location (p), + TRUNC_DIV_EXPR, + TREE_TYPE (rhs), + a68_low_deref (lhs, SUB (p)), + rhs); + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (lhs), + a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)), + lhs); +} + +tree +a68_lower_modab3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree lhs = a68_lower_tree (SUB (p), ctx); + lhs = a68_consolidate_ref (MOID (SUB (p)), lhs); + lhs = save_expr (lhs); + NODE_T *rhs_node = NEXT (NEXT (SUB (p))); + tree rhs = a68_lower_tree (rhs_node, ctx); + tree operation = fold_build2_loc (a68_get_node_location (p), + TRUNC_MOD_EXPR, + TREE_TYPE (rhs), + a68_low_deref (lhs, SUB (p)), + rhs); + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (lhs), + a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)), + lhs); +} + +tree +a68_lower_divab3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree lhs = a68_lower_tree (SUB (p), ctx); + lhs = a68_consolidate_ref (MOID (SUB (p)), lhs); + lhs = save_expr (lhs); + NODE_T *rhs_node = NEXT (NEXT (SUB (p))); + tree rhs = a68_lower_tree (rhs_node, ctx); + tree operation = fold_build2_loc (a68_get_node_location (p), + RDIV_EXPR, + TREE_TYPE (rhs), + a68_low_deref (lhs, SUB (p)), + rhs); + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (lhs), + a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)), + lhs); +} + +/* UPB comes in two flavors. + + The unary operator returns the upper bound of the first dimension of the + operand multple. + + The binary operator returns the upper bound of the given dimension of the + operand multiple. The dimension is one-based. If the specified dimension + is out of bounds then an a run-time error is raised. */ + +static tree +upb (NODE_T *p, tree boundable, tree dim) +{ + boundable = save_expr (boundable); + dim = save_expr (dim); + + /* BOUNDABLE can be a multiple or a ROWS. */ + tree zero_based_dim + = save_expr (fold_build2 (MINUS_EXPR, TREE_TYPE (dim), dim, size_one_node)); + tree type = TREE_TYPE (boundable); + if (A68_ROW_TYPE_P (type)) + { + return fold_build2 (COMPOUND_EXPR, ssizetype, + a68_multiple_dim_check (p, boundable, dim), + a68_multiple_upper_bound (boundable, zero_based_dim)); + } + else if (A68_ROWS_TYPE_P (type)) + { + return fold_build2 (COMPOUND_EXPR, ssizetype, + a68_rows_dim_check (p, boundable, dim), + a68_rows_upper_bound (boundable, zero_based_dim)); + } + else + gcc_unreachable (); +} + +tree +a68_lower_upb2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree multiple = a68_lower_tree (NEXT (SUB (p)), ctx); + return fold_convert (CTYPE (MOID (p)), upb (p, multiple, size_one_node)); +} + +tree +a68_lower_upb3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree dim = fold_convert (sizetype, a68_lower_tree (SUB (p), ctx)); + tree multiple = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return fold_convert (CTYPE (MOID (p)), upb (p, multiple, dim)); +} + +/* LWB comes in two flavors. + + The unary operator returns the lower bound of the first dimension of the + operand multple. + + The binary operator returns the lower bound of the given dimension of the + operand multiple. The dimension is one-based. If the specified dimension + is out of bounds then an a run-time error is raised. */ + +static tree +lwb (NODE_T *p, tree boundable, tree dim) +{ + boundable = save_expr (boundable); + dim = save_expr (dim); + + /* BOUNDABLE can be a multiple or an union whose all alternatives yield a + multiple. */ + tree zero_based_dim + = save_expr (fold_build2 (MINUS_EXPR, TREE_TYPE (dim), dim, size_one_node)); + tree type = TREE_TYPE (boundable); + if (A68_ROW_TYPE_P (type)) + { + return fold_build2 (COMPOUND_EXPR, ssizetype, + a68_multiple_dim_check (p, boundable, dim), + a68_multiple_lower_bound (boundable, zero_based_dim)); + } + else if (A68_ROWS_TYPE_P (type)) + { + return fold_build2 (COMPOUND_EXPR, ssizetype, + a68_rows_dim_check (p, boundable, dim), + a68_rows_lower_bound (boundable, zero_based_dim)); + } + else + gcc_unreachable (); +} + +tree +a68_lower_lwb2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree multiple = a68_lower_tree (NEXT (SUB (p)), ctx); + return fold_convert (CTYPE (MOID (p)), lwb (p, multiple, size_one_node)); +} + +tree +a68_lower_lwb3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree dim = fold_convert (sizetype, a68_lower_tree (SUB (p), ctx)); + tree multiple = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return fold_convert (CTYPE (MOID (p)), lwb (p, multiple, dim)); +} + +/* ELEMS comes in two flavors. + + The unary operator returns the number of elements in the first dimension of + the operand multple. + + DIM must be a size. + + The binary operator returns the number of elements in the given dimension of the + operand multiple. The dimension is one-based. If the specified dimension + is out of bounds then an a run-time error is raised. */ + +static tree +elems (NODE_T *p, tree boundable, tree dim) +{ + dim = save_expr (dim); + + /* BOUNDABLE can be a multiple or a ROWS. */ + tree type = TREE_TYPE (boundable); + + /* Make DIM zero-based. */ + tree dim_minus_one + = fold_build2 (MINUS_EXPR, TREE_TYPE (dim), dim, size_one_node); + + boundable = save_expr (boundable); + tree upper_bound = NULL_TREE; + tree lower_bound = NULL_TREE; + tree check_dimension = NULL_TREE; + if (A68_ROW_TYPE_P (type)) + { + upper_bound = a68_multiple_upper_bound (boundable, dim_minus_one); + lower_bound = a68_multiple_lower_bound (boundable, dim_minus_one); + check_dimension = a68_multiple_dim_check (p, boundable, dim); + } + else if (A68_ROWS_TYPE_P (type)) + { + upper_bound = a68_rows_upper_bound (boundable, dim_minus_one); + lower_bound = a68_rows_lower_bound (boundable, dim_minus_one); + check_dimension = a68_rows_dim_check (p, boundable, dim); + } + else + gcc_unreachable (); + + upper_bound = save_expr (upper_bound); + lower_bound = save_expr (lower_bound); + + tree non_flat = fold_build2 (PLUS_EXPR, + sizetype, + fold_convert (sizetype, + fold_build2 (MINUS_EXPR, ssizetype, + upper_bound, lower_bound)), + size_one_node); + + tree elems = fold_build3 (COND_EXPR, sizetype, + fold_build2 (LT_EXPR, boolean_type_node, + upper_bound, lower_bound), + size_zero_node, + non_flat); + + if (OPTION_BOUNDS_CHECKING (&A68_JOB)) + elems = fold_build2 (COMPOUND_EXPR, sizetype, + check_dimension, + elems); + + return elems; +} + +tree +a68_lower_elems2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree multiple = a68_lower_tree (NEXT (SUB (p)), ctx); + return fold_convert (CTYPE (MOID (p)), elems (p, multiple, size_one_node)); +} + +tree +a68_lower_elems3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree dim = fold_convert (sizetype, a68_lower_tree (SUB (p), ctx)); + tree multiple = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return fold_convert (CTYPE (MOID (p)), elems (p, multiple, dim)); +} + +tree +a68_lower_pow_int (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_int_pow (MOID (p), op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_pow_real (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *mode = MOID (p); + MOID_T *op1_mode = MOID (SUB (p)); + MOID_T *op2_mode = MOID (NEXT (NEXT (SUB (p)))); + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_real_pow (mode, op1_mode, op2_mode, + op1, op2, a68_get_node_location (p)); +} + +tree +a68_lower_odd2 (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *op = NEXT (SUB (p)); + + return fold_build2_loc (a68_get_node_location (p), + EQ_EXPR, + a68_bool_type, + fold_build2 (BIT_AND_EXPR, + CTYPE (MOID (op)), + a68_lower_tree (op, ctx), + build_int_cst (CTYPE (MOID (op)), 1)), + build_int_cst (CTYPE (MOID (op)), 1)); +} + +tree +a68_lower_string_eq3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + tree cmp = a68_string_cmp (op1, op2); + + return fold_build2_loc (a68_get_node_location (p), + EQ_EXPR, + a68_bool_type, + cmp, + build_int_cst (a68_int_type, 0)); +} + +tree +a68_lower_string_ne3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + tree cmp = a68_string_cmp (op1, op2); + + return fold_build2_loc (a68_get_node_location (p), + NE_EXPR, + a68_bool_type, + cmp, + build_int_cst (a68_int_type, 0)); +} + +tree +a68_lower_string_lt3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + tree cmp = a68_string_cmp (op1, op2); + + return fold_build2_loc (a68_get_node_location (p), + LT_EXPR, + a68_bool_type, + cmp, + build_int_cst (a68_int_type, 0)); +} + +tree +a68_lower_string_le3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + tree cmp = a68_string_cmp (op1, op2); + + return fold_build2_loc (a68_get_node_location (p), + LE_EXPR, + a68_bool_type, + cmp, + build_int_cst (a68_int_type, 0)); +} + +tree +a68_lower_string_gt3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + tree cmp = a68_string_cmp (op1, op2); + + return fold_build2_loc (a68_get_node_location (p), + GT_EXPR, + a68_bool_type, + cmp, + build_int_cst (a68_int_type, 0)); +} + +tree +a68_lower_string_ge3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + tree cmp = a68_string_cmp (op1, op2); + + return fold_build2_loc (a68_get_node_location (p), + GE_EXPR, + a68_bool_type, + cmp, + build_int_cst (a68_int_type, 0)); +} + +tree +a68_lower_string_plus3 (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_string_concat (a68_lower_tree (SUB (p), ctx), + a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)); +} + +tree +a68_lower_string_plusab3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree lhs = a68_lower_tree (SUB (p), ctx); + lhs = a68_consolidate_ref (MOID (SUB (p)), lhs); + lhs = save_expr (lhs); + NODE_T *rhs_node = NEXT (NEXT (SUB (p))); + tree rhs = a68_lower_tree (rhs_node, ctx); + tree operation = a68_string_concat (a68_low_deref (lhs, SUB (p)), rhs); + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (lhs), + a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)), + lhs); +} + +tree +a68_lower_string_plusto3 (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *lhs_node = NEXT (NEXT (SUB (p))); + tree lhs = a68_lower_tree (lhs_node, ctx); + lhs = a68_consolidate_ref (MOID (lhs_node), lhs); + lhs = save_expr (lhs); + MOID_T *lhs_mode = MOID (lhs_node); + NODE_T *rhs_node = SUB (p); + tree rhs = a68_lower_tree (rhs_node, ctx); + tree operation = a68_string_concat (rhs, a68_low_deref (lhs, NEXT (NEXT (SUB (p))))); + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (lhs), + a68_low_assignation (p, lhs, lhs_mode, + operation, MOID (rhs_node)), + lhs); +} + +tree +a68_lower_repr2 (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *op = NEXT (SUB (p)); + return a68_char_repr (op, a68_lower_tree (op, ctx)); +} + +tree +a68_lower_char_plus3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + return a68_string_concat (a68_string_from_char (op1), + a68_string_from_char (op2)); +} + +tree +a68_lower_char_mult3 (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *n1 = SUB (p); + NODE_T *n2 = NEXT (NEXT (SUB (p))); + + if (MOID (n1) == M_INT) + { + gcc_assert (MOID (n2) == M_STRING || MOID (n2) == M_ROW_CHAR); + return a68_string_mult (a68_string_from_char (a68_lower_tree (n2, ctx)), + a68_lower_tree (n1, ctx)); + } + else + { + gcc_assert (MOID (n1) == M_CHAR); + gcc_assert (MOID (n2) == M_INT); + return a68_string_mult (a68_string_from_char (a68_lower_tree (n1, ctx)), + a68_lower_tree (n2, ctx)); + } +} + +tree +a68_lower_string_mult3 (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *n1 = SUB (p); + NODE_T *n2 = NEXT (NEXT (SUB (p))); + + if (MOID (n1) == M_INT) + { + gcc_assert (MOID (n2) == M_STRING || MOID (n2) == M_ROW_CHAR); + return a68_string_mult (a68_lower_tree (n2, ctx), + a68_lower_tree (n1, ctx)); + } + else + { + gcc_assert (MOID (n1) == M_STRING || MOID (n1) == M_ROW_CHAR); + gcc_assert (MOID (n2) == M_INT); + return a68_string_mult (a68_lower_tree (n1, ctx), + a68_lower_tree (n2, ctx)); + } +} + +tree +a68_lower_string_multab3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree lhs = a68_lower_tree (SUB (p), ctx); + lhs = a68_consolidate_ref (MOID (SUB (p)), lhs); + lhs = save_expr (lhs); + NODE_T *rhs_node = NEXT (NEXT (SUB (p))); + tree rhs = a68_lower_tree (rhs_node, ctx); + tree operation = a68_string_mult (a68_low_deref (lhs, SUB (p)), rhs); + + return fold_build2_loc (a68_get_node_location (p), + COMPOUND_EXPR, + TREE_TYPE (lhs), + a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)), + lhs); +} + +/* SIZETY BITS operators. */ + +tree +a68_lower_bin2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_bits_bin (MOID (p), op); +} + +tree +a68_lower_bitabs2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_bits_abs (MOID (p), op); +} + +tree +a68_lower_bitleng2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_bits_leng (CTYPE (MOID (p)), op); +} + +tree +a68_lower_bitshorten2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_bits_shorten (CTYPE (MOID (p)), op); +} + +tree +a68_lower_bitnot2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_bits_not (op); +} + +tree +a68_lower_bitand3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_bits_and (op1, op2); +} + +tree +a68_lower_bitior3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_bits_ior (op1, op2); +} + +tree +a68_lower_bitxor3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_bits_xor (op1, op2); +} + +tree +a68_lower_shl3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree bits = a68_lower_tree (SUB (p), ctx); + tree shift = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_bits_shift (shift, bits); +} + +tree +a68_lower_shr3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree bits = a68_lower_tree (SUB (p), ctx); + tree shift = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_bits_shift (fold_build1 (NEGATE_EXPR, + TREE_TYPE (shift), shift), + bits); +} + +tree +a68_lower_bitelem3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree pos = a68_lower_tree (SUB (p), ctx); + tree bits = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_bits_elem (p, pos, bits); +} + +tree +a68_lower_bit_eq3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_bits_eq (op1, op2); +} + +tree +a68_lower_bit_ne3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_bits_ne (op1, op2); +} + +tree +a68_lower_bit_le3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_bits_subset (op1, op2); +} + +tree +a68_lower_bit_ge3 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + return a68_bits_subset (op2, op1); +} + +/* Environment enquiries. */ + +tree +a68_lower_maxint (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_int_maxval (CTYPE (MOID (p))); +} + +tree +a68_lower_minint (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_int_minval (CTYPE (MOID (p))); +} + +tree +a68_lower_maxbits (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_bits_maxbits (CTYPE (MOID (p))); +} + +tree +a68_lower_maxreal (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_real_maxval (CTYPE (MOID (p))); +} + +tree +a68_lower_minreal (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_real_minval (CTYPE (MOID (p))); +} + +tree +a68_lower_smallreal (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_real_smallval (CTYPE (MOID (p))); +} + +tree +a68_lower_bitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_bits_width (a68_bits_type); +} + +tree +a68_lower_longbitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_bits_width (a68_long_bits_type); +} + +tree +a68_lower_longlongbitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_bits_width (a68_long_long_bits_type); +} + +tree +a68_lower_shortbitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_bits_width (a68_short_bits_type); +} + +tree +a68_lower_shortshortbitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_bits_width (a68_short_short_bits_type); +} + +tree +a68_lower_intwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_int_width (a68_int_type); +} + +tree +a68_lower_longintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_int_width (a68_long_int_type); +} + +tree +a68_lower_longlongintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_int_width (a68_long_long_int_type); +} + +tree +a68_lower_shortintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_int_width (a68_short_int_type); +} + +tree +a68_lower_shortshortintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_int_width (a68_short_short_int_type); +} + +tree +a68_lower_realwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_real_width (a68_real_type); +} + +tree +a68_lower_longrealwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_real_width (a68_long_real_type); +} + +tree +a68_lower_longlongrealwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_real_width (a68_long_long_real_type); +} + +tree +a68_lower_expwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_real_exp_width (a68_real_type); +} + +tree +a68_lower_longexpwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_real_exp_width (a68_long_real_type); +} + +tree +a68_lower_longlongexpwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_real_exp_width (a68_long_long_real_type); +} + +tree +a68_lower_pi (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_real_pi (CTYPE (MOID (p))); +} + +tree +a68_lower_nullcharacter (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + static tree null_character = NULL_TREE; + + if (null_character == NULL_TREE) + null_character = build_int_cst (a68_char_type, 0); + return null_character; +} + +tree +a68_lower_flip (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + static tree flip = NULL_TREE; + + if (flip == NULL_TREE) + flip = build_int_cst (a68_char_type, 84); /* T */ + return flip; +} + +tree +a68_lower_eofchar (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + static tree eofchar = NULL_TREE; + + if (eofchar == NULL_TREE) + eofchar = build_int_cst (a68_char_type, -1); + return eofchar; +} + +tree +a68_lower_replacementchar (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + static tree replacementchar = NULL_TREE; + + if (replacementchar == NULL_TREE) + replacementchar = build_int_cst (a68_char_type, 0xfffd); + return replacementchar; +} + +tree +a68_lower_flop (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + static tree flop = NULL_TREE; + + if (flop == NULL_TREE) + flop = build_int_cst (a68_char_type, 70); /* F */ + return flop; +} + +tree +a68_lower_errorchar (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + static tree errorchar = NULL_TREE; + + if (errorchar == NULL_TREE) + errorchar = build_int_cst (a68_char_type, 42); /* * */ + return errorchar; +} + +tree +a68_lower_blank (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + static tree blank = NULL_TREE; + + if (blank == NULL_TREE) + blank = build_int_cst (a68_char_type, 32); + return blank; +} + +tree +a68_lower_intlengths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + HOST_WIDE_INT int_size = int_size_in_bytes (a68_int_type); + HOST_WIDE_INT long_int_size = int_size_in_bytes (a68_long_int_type); + HOST_WIDE_INT long_long_int_size = int_size_in_bytes (a68_long_long_int_type); + + gcc_assert (int_size != -1); + gcc_assert (long_int_size != -1); + gcc_assert (long_long_int_size != -1); + + int lengths = 1; + if (long_long_int_size != long_int_size) + lengths++; + if (long_int_size != int_size) + lengths++; + + return build_int_cst (CTYPE (MOID (p)), lengths); +} + +tree +a68_lower_intshorths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + HOST_WIDE_INT int_size = int_size_in_bytes (a68_int_type); + HOST_WIDE_INT short_int_size = int_size_in_bytes (a68_short_int_type); + HOST_WIDE_INT short_short_int_size = int_size_in_bytes (a68_short_short_int_type); + + gcc_assert (int_size != -1); + gcc_assert (short_int_size != -1); + gcc_assert (short_short_int_size != -1); + + int shorths = 1; + if (short_short_int_size != short_int_size) + shorths++; + if (short_int_size != int_size) + shorths++; + + return build_int_cst (CTYPE (MOID (p)), shorths); +} + +tree +a68_lower_bitslengths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + HOST_WIDE_INT bits_size = int_size_in_bytes (a68_bits_type); + HOST_WIDE_INT long_bits_size = int_size_in_bytes (a68_long_bits_type); + HOST_WIDE_INT long_long_bits_size = int_size_in_bytes (a68_long_long_bits_type); + + gcc_assert (bits_size != -1); + gcc_assert (long_bits_size != -1); + gcc_assert (long_long_bits_size != -1); + + int lengths = 1; + if (long_long_bits_size != long_bits_size) + lengths++; + if (long_bits_size != bits_size) + lengths++; + + return build_int_cst (CTYPE (MOID (p)), lengths); +} + +tree +a68_lower_bitsshorths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + HOST_WIDE_INT bits_size = int_size_in_bytes (a68_bits_type); + HOST_WIDE_INT short_bits_size = int_size_in_bytes (a68_short_bits_type); + HOST_WIDE_INT short_short_bits_size = int_size_in_bytes (a68_short_short_bits_type); + + gcc_assert (bits_size != -1); + gcc_assert (short_bits_size != -1); + gcc_assert (short_short_bits_size != -1); + + int shorths = 1; + if (short_short_bits_size != short_bits_size) + shorths++; + if (short_bits_size != bits_size) + shorths++; + + return build_int_cst (CTYPE (MOID (p)), shorths); +} + +tree +a68_lower_reallengths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + HOST_WIDE_INT real_size = int_size_in_bytes (a68_real_type); + HOST_WIDE_INT long_real_size = int_size_in_bytes (a68_long_real_type); + HOST_WIDE_INT long_long_real_size = int_size_in_bytes (a68_long_long_real_type); + + gcc_assert (real_size != -1); + gcc_assert (long_real_size != -1); + gcc_assert (long_long_real_size != -1); + + int lengths = 1; + if (long_long_real_size != long_real_size) + lengths++; + if (long_real_size != real_size) + lengths++; + + return build_int_cst (CTYPE (MOID (p)), lengths); +} + +tree +a68_lower_realshorths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return build_int_cst (CTYPE (MOID (p)), 1); +} + +tree +a68_lower_infinity (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return build_real (CTYPE (MOID (p)), dconstinf); +} + +tree +a68_lower_minusinfinity (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return build_real (CTYPE (MOID (p)), dconstninf); +} + +tree +a68_lower_maxabschar (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_char_max (); +} + +tree +a68_lower_sqrt (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_sqrt (a68_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_sqrt (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_sqrt (a68_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_long_sqrt (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_sqrt (a68_long_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_tan (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_tan (a68_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_tan (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_tan (a68_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_long_tan (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_tan (a68_long_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_sin (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_sin (a68_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_sin (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_sin (a68_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_long_sin (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_sin (a68_long_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_cos (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_cos (a68_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_cos (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_cos (a68_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_long_cos (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_cos (a68_long_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_acos (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_acos (a68_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_acos (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_acos (a68_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_long_acos (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_acos (a68_long_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_asin (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_asin (a68_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_asin (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_asin (a68_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_long_asin (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_asin (a68_long_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_atan (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_atan (a68_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_atan (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_atan (a68_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_long_atan (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_atan (a68_long_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_ln (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_ln (a68_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_ln (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_ln (a68_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_long_ln (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_ln (a68_long_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_log (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_log (a68_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_log (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_log (a68_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_long_log (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_log (a68_long_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_exp (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_exp (a68_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_exp (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_exp (a68_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_long_long_exp (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_real_exp (a68_long_long_real_type); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_reali (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + tree t = a68_complex_i (M_COMPLEX, op1, op2); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_longreali (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + tree t = a68_complex_i (M_LONG_COMPLEX, op1, op2); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_longlongreali (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + tree t = a68_complex_i (M_LONG_LONG_COMPLEX, op1, op2); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_inti (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + tree t = a68_complex_i (M_COMPLEX, + convert_to_real (a68_real_type, op1), + convert_to_real (a68_real_type, op2)); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_longinti (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + tree t= a68_complex_i (M_LONG_COMPLEX, + convert_to_real (a68_long_real_type, op1), + convert_to_real (a68_long_real_type, op2)); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_longlonginti (NODE_T *p, LOW_CTX_T ctx) +{ + tree op1 = a68_lower_tree (SUB (p), ctx); + tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + tree t = a68_complex_i (M_LONG_LONG_COMPLEX, + convert_to_real (a68_long_long_real_type, op1), + convert_to_real (a68_long_long_real_type, op2)); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_re2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + tree t = a68_complex_re (op); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_im2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + tree t = a68_complex_im (op); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_conj2 (NODE_T *p, LOW_CTX_T ctx) +{ + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + return a68_complex_conj (MOID (p), op); +} + +tree +a68_lower_shortenint2 (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_int_shorten (MOID (p), MOID (NEXT (SUB (p))), + a68_lower_tree (NEXT (SUB (p)), ctx)); +} + +tree +a68_lower_lengint2 (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_int_leng (MOID (p), MOID (NEXT (SUB (p))), + a68_lower_tree (NEXT (SUB (p)), ctx)); +} + +tree +a68_lower_shortenreal2 (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_real_shorten (MOID (p), MOID (NEXT (SUB (p))), + a68_lower_tree (NEXT (SUB (p)), ctx)); +} + +tree +a68_lower_lengreal2 (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_real_leng (MOID (p), MOID (NEXT (SUB (p))), + a68_lower_tree (NEXT (SUB (p)), ctx)); +} + +tree +a68_lower_random (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_get_libcall (A68_LIBCALL_RANDOM); +} + +tree +a68_lower_longrandom (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + /* Note we dont build a call because this will get deprocedured in case it is + actually called. */ + return a68_get_libcall (A68_LIBCALL_LONGRANDOM); +} + +tree +a68_lower_longlongrandom (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_get_libcall (A68_LIBCALL_LONGLONGRANDOM); +} + +/********* POSIX prelude. ***************/ + +tree +a68_lower_setexitstatus (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_setexitstatus (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixargc (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_argc (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixargv (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_argv (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixgetenv (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_getenv (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixputchar (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_putchar (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixputs (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_puts (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixfconnect (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_fconnect (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixfopen (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_fopen (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixfcreate (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_fcreate (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixfclose (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_fclose (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixfsize (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_fsize (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixlseek (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_lseek (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixseekcur (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return build_int_cst (a68_int_type, 0); +} + +tree +a68_lower_posixseekend (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return build_int_cst (a68_int_type, 1); +} + +tree +a68_lower_posixseekset (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return build_int_cst (a68_int_type, 2); +} + +tree +a68_lower_posixstdinfiledes (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return build_int_cst (a68_int_type, 0); +} + +tree +a68_lower_posixstdoutfiledes (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return build_int_cst (a68_int_type, 1); +} + +tree +a68_lower_posixstderrfiledes (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return build_int_cst (a68_int_type, 2); +} + +tree +a68_lower_posixfileodefault (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + /* Please keep in sync with libga68/ga68-posix.c */ + return build_int_cst (a68_bits_type, 0x99999999); +} + +tree +a68_lower_posixfileordwr (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + /* Please keep in sync with libga68/ga68-posix.c */ + return build_int_cst (a68_bits_type, 0x2); +} + +tree +a68_lower_posixfileordonly (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + /* Please keep in sync with libga68/ga68-posix.c */ + return build_int_cst (a68_bits_type, 0x0); +} + +tree +a68_lower_posixfileowronly (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + /* Please keep in sync with libga68/ga68-posix.c */ + return build_int_cst (a68_bits_type, 0x1); +} + +tree +a68_lower_posixfileotrunc (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + /* Please keep in sync with libga68/ga68-posix.c */ + return build_int_cst (a68_bits_type, 0x8); +} + +tree +a68_lower_posixerrno (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_errno (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixperror (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_perror (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixstrerror (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_strerror (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixfputc (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_fputc (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixfputs (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_fputs (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixgetchar (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_getchar (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + + +tree +a68_lower_posixfgetc (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_fgetc (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixgets (NODE_T *p ATTRIBUTE_UNUSED, + LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_gets (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} + +tree +a68_lower_posixfgets (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree t = a68_posix_fgets (); + if (CAN_HAVE_LOCATION_P (t)) + SET_EXPR_LOCATION (t, a68_get_node_location (p)); + return t; +} diff --git a/gcc/algol68/a68-low-procs.cc b/gcc/algol68/a68-low-procs.cc new file mode 100644 index 000000000000..cc43d52aa6bf --- /dev/null +++ b/gcc/algol68/a68-low-procs.cc @@ -0,0 +1,52 @@ +/* Lowering routines for all things related to procedures. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Return a tree with the yielding of SKIP for the given procedure mode. */ + +tree +a68_get_proc_skip_tree (MOID_T *m) +{ + /* A SKIP for a procecure mode lowers to a NULL pointer to a function. */ + return build_int_cst (CTYPE (m), 0); +} diff --git a/gcc/algol68/a68-low-ranges.cc b/gcc/algol68/a68-low-ranges.cc new file mode 100644 index 000000000000..9a2008aa571b --- /dev/null +++ b/gcc/algol68/a68-low-ranges.cc @@ -0,0 +1,699 @@ +/* Management of ranges in the Algol 68 front-end. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" +#include "tree-nested.h" + +#include "a68.h" + +/* Many Algol 68 constructions introduce a new range of definitions. This is + the case of clauses and of routine definitions. The stack of ranges at any + point in the program determines the "nest" of the constructions declared in + the program. This nest carries a record of all the declarations forming the + environment in which that construct is to be interpreted. + + This file contains a manager of ranges of which we allocate one for each + range inducing construct. The top-level range corresponds to the primal + environment. + + The ranges are used by the lowering code in order to create GCC tree BLOCK + nodes, and also to keep track of the set of declarations and of statements + being added by the current serial clause. */ + +struct GTY (()) range +{ + /* Whether this range entry doesn't introduce a lexical frame. Declarations + and decl_exprs get added to the nearst enclosing range that is not + frameless. */ + bool frameless; + + /* A chain of _DECL nodes for all variables, constants, functions, + and typedef types. These are in the reverse of the order supplied. */ + tree names; + + /* A statements list of DECL_EXPR nodes for all the declarations in the + range. These are prepended to the statements list when the range is + closed. */ + tree decl_exprs; + + /* The context of the range, either a function declaration or a translation + unit. */ + tree context; + + /* The range below this one. */ + struct range *next; + + /* Statement list. */ + tree stmt_list; + + /* List of blocks to which the block created for this range is the + superblock. */ + tree blocks; + + /* Mode associated with the range. For serial clauses, this is the mode of + the value yielded by the clause. */ + MOID_T *mode; + + /* If not TREE_NULL, then the range corresponds to a function, which can be + either nested or defined at top-level. */ + tree fndecl; + bool top_level_function; + + /* The following fields are used by ranges introduced by serial + clauses. */ + bool save_restore_stack; + bool has_completers; + tree clause_result_decl; + tree clause_exit_label_decl; + tree clause_stack_save_decl; +}; + +/* Global and current ranges. */ + +static GTY (()) struct range *global_range; +static GTY (()) struct range *current_range; + +/* Create a new range and push it in the list. */ + +static struct range * +new_range (void) +{ + struct range *range = ggc_alloc (); + + range->frameless = false; + range->names = NULL; + range->decl_exprs = alloc_stmt_list (); + range->context = NULL; + range->next = NULL; + range->blocks = NULL_TREE; + range->stmt_list = alloc_stmt_list (); + range->fndecl = NULL_TREE; + range->top_level_function = false; + range->save_restore_stack = false; + range->has_completers = false; + range->clause_result_decl = NULL_TREE; + range->clause_exit_label_decl = NULL_TREE; + range->clause_stack_save_decl = NULL_TREE; + range->mode = NO_MOID; + return range; +} + +/* Push a new frameless range. */ + +void +a68_push_stmt_list (MOID_T *mode) +{ + a68_push_range (mode); + current_range->frameless = true; +} + +/* Pop a frameless range. */ + +tree +a68_pop_stmt_list (void) +{ + /* This will result into a stmt list. */ + tree res = a68_pop_range (); + gcc_assert (TREE_CODE (res) == STATEMENT_LIST); + return res; +} + +/* Push a new range. */ + +void +a68_push_range (MOID_T *mode) +{ + struct range *range = new_range (); + if (current_range) + range->context = current_range->context; + range->next = current_range; + range->mode = mode; + current_range = range; +} + +/* Pop a range, with a finalizer. + + Return a BIND_EXPR, a statement list or a TRY_FINALLY_EXPR. */ + +tree +a68_pop_range_with_finalizer (tree finalizer) +{ + tree range = a68_pop_range (); + return fold_build2 (TRY_FINALLY_EXPR, TREE_TYPE (range), + range, finalizer); +} + +/* Pop a range. Return either a BIND_EXPR or a statements list. */ + +tree +a68_pop_range (void) +{ + struct range *range = current_range; + current_range = range->next; + tree type = (range->mode == NULL ? void_type_node : CTYPE (range->mode)); + + /* If TYPE is a pointer type and the last expression in the statement list is + a variable of the type pointed by TYPE then take its address. */ + tree_stmt_iterator i = tsi_last (range->stmt_list); + if (POINTER_TYPE_P (type) && TREE_TYPE (type) == TREE_TYPE (tsi_stmt (i))) + { + append_to_statement_list_force (a68_consolidate_ref (range->mode, tsi_stmt (i)), + &range->stmt_list); + tsi_delink (&i); + } + + tree clause = NULL_TREE; + if (range->frameless) + clause = range->stmt_list; + else + { + /* Create a block and set its declarations and supercontext. */ + tree block = make_node (BLOCK); + BLOCK_VARS (block) = range->names; + BLOCK_SUBBLOCKS (block) = range->blocks; + + /* In each subblock, record that this is its superior. */ + for (tree t = range->blocks; t; t = BLOCK_CHAIN (t)) + BLOCK_SUPERCONTEXT (t) = block; + + if (range->fndecl) + { + BLOCK_SUPERCONTEXT (block) = range->fndecl; + DECL_INITIAL (range->fndecl) = block; + } + else + { + current_range->blocks + = block_chainon (current_range->blocks, block); + } + + TREE_USED (block) = true; + + /* Create a BIND if the range contains declarations. Otherwise just + use the statements list. */ + clause = range->stmt_list; + if (range->names != NULL_TREE) + { + clause = build3 (BIND_EXPR, + type, + range->names, + range->stmt_list, + block); + TREE_SIDE_EFFECTS (clause) = 1; + BIND_EXPR_VARS (clause) = BLOCK_VARS (block); + } + + /* Prepend the decl_exprs to the range's statements list. */ + tree_stmt_iterator q = tsi_start (range->stmt_list); + tsi_link_before (&q, range->decl_exprs, TSI_SAME_STMT); + } + + /* Set the type of the stmt_list. */ + TREE_TYPE (range->stmt_list) = type; + TREE_SIDE_EFFECTS (range->stmt_list) = 1; + + return clause; +} + +/* Add a new expression to the current range. */ + +void +a68_add_stmt (tree exp) +{ + if (exp == void_node) + /* This may result from a mode declaration. */ + return; + gcc_assert (current_range != NULL); + append_to_statement_list_force (exp, + ¤t_range->stmt_list); +} + +/* Add a new declaration to the current range. */ + +void +a68_add_decl (tree decl) +{ + gcc_assert (current_range != NULL); + struct range *range = current_range; + + /* Search for the right frame where to add the declaration. */ + while (range->frameless) + { + gcc_assert (range->next != NULL); + range = range->next; + } + + tree n = range->names; + while (n != decl && n != NULL) + n = TREE_CHAIN (n); + if (n != decl) + { + if (decl != current_function_decl) + DECL_CONTEXT (decl) = range->context; + /* Note this list needs to be in reverse order for compatibility with + GCC. */ + TREE_CHAIN (decl) = range->names; + range->names = decl; + } +} + +/* Add a new declaration expr to the current range. */ + +void +a68_add_decl_expr (tree decl_expr) +{ + gcc_assert (current_range != NULL); + struct range *range = current_range; + + /* Search for the right frame where to add the declaration expr. */ + while (range->frameless) + { + gcc_assert (range->next != NULL); + range = range->next; + } + + append_to_statement_list_force (decl_expr, &range->decl_exprs); +} + +/* Add a completer in the current range. */ + +void +a68_add_completer (void) +{ + struct range *range = current_range; + + /* The last statement in the statements list is either a single unit or a + labeled unit, i.e a COMPOUND_EXPR whose first expression is a label and + second expression is the unit. Consolidate the unit within the labeled + unit to a ref. */ + tree_stmt_iterator i = tsi_last (range->stmt_list); + tree last_expr = tsi_stmt (i); + + if (TREE_CODE (last_expr) == COMPOUND_EXPR + && TREE_CODE (TREE_OPERAND (last_expr, 0)) == LABEL_EXPR) + { + TREE_OPERAND (last_expr, 1) = a68_consolidate_ref (range->mode, + TREE_OPERAND (last_expr, 1)); + TREE_TYPE (last_expr) = TREE_TYPE (TREE_OPERAND (last_expr, 1)); + } + else + last_expr = a68_consolidate_ref (range->mode, last_expr); + + /* Now assign the labeled unit to the clause result decl then jump to the end + of the serial clause. */ + append_to_statement_list_force (fold_build2 (MODIFY_EXPR, + void_type_node, + range->clause_result_decl, + last_expr), + &range->stmt_list); + tsi_delink (&i); + append_to_statement_list_force (fold_build1 (GOTO_EXPR, void_type_node, + range->clause_exit_label_decl), + &range->stmt_list); + range->has_completers = true; +} + +/* Get the context of the current range. */ + +tree +a68_range_context (void) +{ + gcc_assert (current_range != NULL); + return current_range->context; +} + +/* Get the list of declarations in the current range. */ + +tree +a68_range_names (void) +{ + struct range *range = current_range; + + while (range->frameless && range->next != NULL) + range = range->next; + + if (range != NULL) + return range->names; + else + return NULL_TREE; +} + +/* Get the statements list of the current range. */ + +tree +a68_range_stmt_list (void) +{ + gcc_assert (current_range != NULL); + return current_range->stmt_list; +} + +/* Push a range for a function. */ + +void +a68_push_function_range (tree fndecl, tree result_type, + bool top_level) +{ + a68_push_range (NULL /* VOID */); + current_range->fndecl = fndecl; + current_range->top_level_function = top_level; + current_range->context = fndecl; + + /* Setup the result declaration. */ + tree resdecl = build_decl (UNKNOWN_LOCATION, + RESULT_DECL, + get_identifier ("resdecl%"), + result_type); + DECL_ARTIFICIAL (resdecl) = 1; + DECL_IGNORED_P (resdecl) = 1; + DECL_CONTEXT (resdecl) = fndecl; + DECL_RESULT (fndecl) = resdecl; + rest_of_decl_compilation (fndecl, 1, 0); + make_decl_rtl (fndecl); + allocate_struct_function (fndecl, false); + + /* Let GCC know the current scope is this function. */ + current_function_decl = fndecl; +} + +/* Pop a range for a function. */ + +void +a68_pop_function_range (tree body) +{ + tree fndecl = current_range->fndecl; + bool top_level = current_range->top_level_function; + + if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node) + { + a68_add_stmt (body); + } + else + { + /* Append the return statement. + Note that this does the copy of the returned value. */ + tree return_stmt = fold_build1 (RETURN_EXPR, + void_type_node, + fold_build2 (MODIFY_EXPR, + TREE_TYPE (DECL_RESULT (fndecl)), + DECL_RESULT (fndecl), + a68_low_dup (body, true /* use_heap */))); + a68_add_stmt (return_stmt); + } + + /* Set the body of the function. */ + DECL_SAVED_TREE (fndecl) = a68_pop_range (); + + /* Output the GENERIC tree for the function.. */ + dump_function (TDI_original, fndecl); + /* This compiles the function all the way to assembler language output. + Nested functions are finalized when the containing top-level function is + finalized. */ + if (top_level || a68_in_global_range ()) + cgraph_node::finalize_function (fndecl, true); + else + /* Register this function with cgraph just far enough to get it added to + our parent's nested function list. */ + (void) cgraph_node::get_create (fndecl); + + /* Let GCC know the current scope has changed. */ + current_function_decl = NULL_TREE; + for (struct range *r = current_range; r; r = r->next) + { + if (r->fndecl != NULL_TREE) + current_function_decl = r->fndecl; + } +} + +/* Push a range for a serial clause. + + label1: BIND_EXPR_BODY (STATEMENT_LIST ( + expr1; label1, + expr2 expr1, + exit label2: clause_result = expr2, + expr3; goto exit_label, + expr4 label2, + exit label3: expr3, + expr5 clause_result = expr4, + goto exit_label, + label3, + clause_result = expr5, + exit_label, + clause_result)) */ + +void +a68_push_serial_clause_range (MOID_T *clause_mode, + bool save_restore_stack) +{ + /* Get the type of the enclosing clause. */ + tree clause_type = CTYPE (clause_mode); + + /* If the serial clause has declarations that involve dynamic allocation, and + the environ it establishes is local, then save the stack pointer. */ + if (save_restore_stack) + { + a68_push_range (clause_mode); + current_range->save_restore_stack = true; + + tree outer_clause_result_decl = build_decl (UNKNOWN_LOCATION, + VAR_DECL, + NULL, /* Set below. */ + clause_type); + char *outer_clause_result_name = xasprintf ("outer_clause_result%d%%", + DECL_UID (outer_clause_result_decl)); + DECL_NAME (outer_clause_result_decl) = get_identifier (outer_clause_result_name); + free (outer_clause_result_name); + current_range->clause_result_decl = outer_clause_result_decl; + a68_add_decl (outer_clause_result_decl); + + /* Variable used to save the stack pointer. */ + tree stack_save_decl = build_decl (UNKNOWN_LOCATION, + VAR_DECL, + get_identifier ("stack_save%"), + build_pointer_type (char_type_node)); + current_range->clause_stack_save_decl = stack_save_decl; + a68_add_decl (stack_save_decl); + a68_add_stmt (fold_build1 (DECL_EXPR, + TREE_TYPE (stack_save_decl), + stack_save_decl)); + + /* Save stack pointer. */ + tree call = builtin_decl_implicit (BUILT_IN_STACK_SAVE); + call = build_call_expr_loc (UNKNOWN_LOCATION, call, 0); + a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node, + stack_save_decl, call)); + } + + /* Push a new range. */ + a68_push_range (clause_mode); + current_range->save_restore_stack = save_restore_stack; + + /* Create a decl for clause_result with the right type and add it to the + block's declaration list. */ + tree clause_result_decl = build_decl (UNKNOWN_LOCATION, + VAR_DECL, + NULL, /* Set below. */ + clause_type); + char *clause_result_name = xasprintf ("clause_result%d%%", DECL_UID (clause_result_decl)); + DECL_NAME (clause_result_decl) = get_identifier (clause_result_name); + // free (clause_result_name); + DECL_INITIAL (clause_result_decl) = a68_get_skip_tree (clause_mode); + DECL_CONTEXT (clause_result_decl) = current_range->context; + current_range->clause_result_decl = clause_result_decl; + + /* Create a decl for the clause's exit label. */ + tree clause_exit_label_decl = build_decl (UNKNOWN_LOCATION, + LABEL_DECL, + NULL, /* Set below. */ + void_type_node); + char *exit_label_name = xasprintf ("clause_exit_label%d%%", DECL_UID (clause_exit_label_decl)); + DECL_NAME (clause_exit_label_decl) = get_identifier (exit_label_name); + free (exit_label_name); + DECL_CONTEXT (clause_exit_label_decl) = current_range->context; + current_range->clause_exit_label_decl = clause_exit_label_decl; +} + +/* Pop a range for a serial clause and return the resulting bind + expression. */ + +tree +a68_pop_serial_clause_range (void) +{ + struct range *range = current_range; + MOID_T *clause_mode = range->mode; + tree clause_type = CTYPE (clause_mode); + + /* The last expression in the statements list is either a single unit or a + labeled unit. Consolidate it to a ref if required by the mode of the + serial clause. */ + { + tree_stmt_iterator si = tsi_last (range->stmt_list); + tree last_expr = tsi_stmt (si); + if (TREE_CODE (last_expr) == COMPOUND_EXPR + && TREE_CODE (TREE_OPERAND (last_expr, 0)) == LABEL_EXPR) + { + TREE_OPERAND (last_expr, 1) = a68_consolidate_ref (range->mode, + TREE_OPERAND (last_expr, 1)); + TREE_TYPE (last_expr) = TREE_TYPE (TREE_OPERAND (last_expr, 1)); + } + else + last_expr = a68_consolidate_ref (range->mode, last_expr); + a68_add_stmt (last_expr); + tsi_delink (&si); + } + + /* If the serial clause has completers, we have to make use of the + clause_result% and clause_exit_label% mechanism to assure the statements + list has a single exit at the end. */ + if (range->has_completers) + { + /* First prepend EXPR_DECL expressions for clause_result% and + clause_exit_label% */ + { + tree_stmt_iterator si = tsi_start (range->stmt_list); + tsi_link_before (&si, + fold_build1 (DECL_EXPR, + TREE_TYPE (range->clause_result_decl), + range->clause_result_decl), + TSI_CONTINUE_LINKING); + tsi_link_before (&si, + fold_build1 (DECL_EXPR, + TREE_TYPE (range->clause_exit_label_decl), + range->clause_exit_label_decl), + TSI_CONTINUE_LINKING); + } + + /* Then turn the last expression in stmt_list to an assignment to + clause_result_decl%, but don't bother if it has been voided. */ + if (clause_type != a68_void_type) + { + tree_stmt_iterator si = tsi_last (range->stmt_list); + tree last_expr = tsi_stmt (si); + + a68_add_stmt (build2 (MODIFY_EXPR, + clause_type, + range->clause_result_decl, + last_expr)); + tsi_delink (&si); + } + + a68_add_decl (range->clause_result_decl); + a68_add_decl (range->clause_exit_label_decl); + + /* Finally append the exit label and last expression with + result_decl. */ + a68_add_stmt (build1 (LABEL_EXPR, void_type_node, range->clause_exit_label_decl)); + a68_add_stmt (build1 (NON_LVALUE_EXPR, clause_type, range->clause_result_decl)); + } + + /* Check that the type of the last statement in the statements list is the + same than the type corresponding to the clause mode. */ + { + tree_stmt_iterator si = tsi_last (range->stmt_list); + if (TREE_TYPE (tsi_stmt (si)) != clause_type + /* But NIL can appear in a context expecting VOID with no widening. */ + && !(clause_type == a68_void_type + && POINTER_TYPE_P (TREE_TYPE (tsi_stmt (si))) + && TREE_CODE (tsi_stmt (si)) == INTEGER_CST + && tree_to_shwi (tsi_stmt (si)) == 0) + /* And any row type is valid when M_ROWS is expected. */ + && !(A68_ROWS_TYPE_P (clause_type) + && A68_ROWS_TYPE_P (TREE_TYPE (tsi_stmt (si)))) + /* Do not rely on comparing pointer types, as the equality fails in + that case. We need a better way of comparing types, either using + TYPE_CANONICAL or caching. */ + && !(POINTER_TYPE_P (TREE_TYPE (tsi_stmt (si))) && POINTER_TYPE_P (clause_type))) + { + printf ("last statement:\n"); + debug_tree (tsi_stmt (si)); + printf ("expected type:\n"); + debug_tree (clause_type); + gcc_unreachable (); + } + } + + /* If the serial clause has declarations that involve dynamic allocation, and + the environ it establishes is local, then restore the stack pointer. */ + if (range->save_restore_stack) + { + /* Turn last expression of inner clause into a modify statement. This + may involve a copy. This can be omitted if the serial clause yields + void. */ + if (clause_type != a68_void_type) + { + tree_stmt_iterator si = tsi_last (range->stmt_list); + tree last_expr = tsi_stmt (si); + + a68_add_stmt (build2 (MODIFY_EXPR, + clause_type, + range->next->clause_result_decl, + a68_low_dup (last_expr))); + tsi_delink (&si); + } + + /* Finish inner clause, restoring stack pointer on finalizing. */ + tree restore_sp = builtin_decl_implicit (BUILT_IN_STACK_RESTORE); + restore_sp = build_call_expr_loc (UNKNOWN_LOCATION, restore_sp, 1, + current_range->next->clause_stack_save_decl); + a68_add_stmt (a68_pop_range_with_finalizer (restore_sp)); + /* The result value is now in clause_result_decl. */ + a68_add_stmt (build1 (NON_LVALUE_EXPR, clause_type, + current_range->clause_result_decl)); + } + + return a68_pop_range (); +} + +/* Whether the current range is the global range. */ + +bool +a68_in_global_range (void) +{ + return current_range == global_range; +} + +/* Initialize ranges. */ + +void +a68_init_ranges (void) +{ + global_range = new_range (); + global_range->context = build_translation_unit_decl (NULL); + current_range = global_range; +} + +#include "gt-algol68-a68-low-ranges.h" diff --git a/gcc/algol68/a68-low-reals.cc b/gcc/algol68/a68-low-reals.cc new file mode 100644 index 000000000000..ab0064a4855b --- /dev/null +++ b/gcc/algol68/a68-low-reals.cc @@ -0,0 +1,620 @@ +/* Lowering routines for all things related to REAL values. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "math.h" /* For log10 */ + +#include "a68.h" + +tree +a68_get_real_skip_tree (MOID_T *m) +{ + tree int_type = NULL_TREE; + tree real_type = NULL_TREE; + + if (m == M_REAL) + { + int_type = a68_int_type; + real_type = a68_real_type; + } + else if (m == M_LONG_REAL) + { + int_type = a68_long_int_type; + real_type = a68_long_real_type; + } + else if (m == M_LONG_LONG_REAL) + { + int_type = a68_long_long_int_type; + real_type = a68_long_long_real_type; + } + else + gcc_unreachable (); + + return build_real_from_int_cst (real_type, + build_int_cst (int_type, 0)); +} + +static tree +addr_of_builtin_decl (enum built_in_function fncode) +{ + tree builtin = builtin_decl_explicit (fncode); + return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (builtin)), builtin); +} + +/* Build PI for the given real type. */ + +tree +a68_real_pi (tree type) +{ + return build_real (type, dconst_pi ()); +} + +/* Given a real type, build the maximum value expresssable with that type. */ + +tree +a68_real_maxval (tree type) +{ + REAL_VALUE_TYPE max; + real_maxval (&max, 0, TYPE_MODE (type)); + return build_real (type, max); +} + +/* Given a real type, build the minimum value expressable with that type. */ + +tree +a68_real_minval (tree type) +{ + REAL_VALUE_TYPE min; + real_maxval (&min, 1, TYPE_MODE (type)); + return build_real (type, min); +} + +/* Given a real type, build the smallest value which can be meaningfully added + to or substracted from 1. */ + +tree +a68_real_smallval (tree type) +{ + /* The smallest real value which can be meaningfully added to or subtracted + from 1. */ + const machine_mode mode = TYPE_MODE (type); + const struct real_format *fmt = REAL_MODE_FORMAT (mode); + + char buf[128]; + if (fmt->pnan < fmt->p) + snprintf (buf, sizeof (buf), "0x1p%d", fmt->emin - fmt->p); + else + snprintf (buf, sizeof (buf), "0x1p%d", 1 - fmt->p); + + REAL_VALUE_TYPE res; + real_from_string (&res, buf); + return build_real (type, res); +} + +/* Given a real type, build an INT with the number of decimal digits required + to represent a mantissa, such that a real is not reglected in comparison + with 1, not including sign. */ + +tree +a68_real_width (tree type) +{ + const machine_mode mode = TYPE_MODE (type); + const struct real_format *fmt = REAL_MODE_FORMAT (mode); + return build_int_cst (a68_int_type, fmt->p); +} + +/* Given a real type, build an INT with the number of decimal digits required + to represent a decimal exponent, such that a real can be correctly + represented, not including sign. */ + +tree +a68_real_exp_width (tree type ATTRIBUTE_UNUSED) +{ + const machine_mode mode = TYPE_MODE (type); + const struct real_format *fmt = REAL_MODE_FORMAT (mode); + const double log10_2 = .30102999566398119521; + double log10_b = log10_2; + int max_10_exp = fmt->emax * log10_b; + + return build_int_cst (a68_int_type, 1 + log10 (max_10_exp)); +} + +/* Given a real value VAL, return -1 if it is less than zero, 0 if it is zero + and +1 if it is bigger than zero. The built value is always of mode + M_INT. */ + +tree +a68_real_sign (tree val) +{ + tree zero = build_real (TREE_TYPE (val), dconst0); + return fold_build3 (COND_EXPR, + a68_int_type, + build2 (EQ_EXPR, integer_type_node, val, zero), + build_int_cst (a68_int_type, 0), + fold_build3 (COND_EXPR, + a68_int_type, + fold_build2 (GT_EXPR, integer_type_node, val, zero), + build_int_cst (a68_int_type, 1), + build_int_cst (a68_int_type, -1))); +} + +/* Absolute value of a real value. */ + +tree +a68_real_abs (tree val) +{ + return fold_build1 (ABS_EXPR, TREE_TYPE (val), val); +} + +tree +a68_real_sqrt (tree type) +{ + enum built_in_function builtin; + + if (type == float_type_node) + builtin = BUILT_IN_SQRTF; + else if (type == double_type_node) + builtin = BUILT_IN_SQRT; + else if (type == long_double_type_node) + builtin = BUILT_IN_SQRTL; + else + gcc_unreachable (); + + return addr_of_builtin_decl (builtin); +} + +tree +a68_real_tan (tree type) +{ + enum built_in_function builtin; + + if (type == float_type_node) + builtin = BUILT_IN_TANF; + else if (type == double_type_node) + builtin = BUILT_IN_TAN; + else if (type == long_double_type_node) + builtin = BUILT_IN_TANL; + else + gcc_unreachable (); + + return addr_of_builtin_decl (builtin); +} + +tree +a68_real_sin (tree type) +{ + enum built_in_function builtin; + + if (type == float_type_node) + builtin = BUILT_IN_SINF; + else if (type == double_type_node) + builtin = BUILT_IN_SIN; + else if (type == long_double_type_node) + builtin = BUILT_IN_SINL; + else + gcc_unreachable (); + + return addr_of_builtin_decl (builtin); +} + +tree +a68_real_cos (tree type) +{ + enum built_in_function builtin; + + if (type == float_type_node) + builtin = BUILT_IN_COSF; + else if (type == double_type_node) + builtin = BUILT_IN_COS; + else if (type == long_double_type_node) + builtin = BUILT_IN_COSL; + else + gcc_unreachable (); + + return addr_of_builtin_decl (builtin); +} + +tree +a68_real_acos (tree type) +{ + enum built_in_function builtin; + + if (type == float_type_node) + builtin = BUILT_IN_ACOSF; + else if (type == double_type_node) + builtin = BUILT_IN_ACOS; + else if (type == long_double_type_node) + builtin = BUILT_IN_ACOSL; + else + gcc_unreachable (); + + return addr_of_builtin_decl (builtin); +} + +tree +a68_real_asin (tree type) +{ + enum built_in_function builtin; + + if (type == float_type_node) + builtin = BUILT_IN_ASINF; + else if (type == double_type_node) + builtin = BUILT_IN_ASIN; + else if (type == long_double_type_node) + builtin = BUILT_IN_ASINL; + else + gcc_unreachable (); + + return addr_of_builtin_decl (builtin); +} + +tree +a68_real_atan (tree type) +{ + enum built_in_function builtin; + + if (type == float_type_node) + builtin = BUILT_IN_ATANF; + else if (type == double_type_node) + builtin = BUILT_IN_ATAN; + else if (type == long_double_type_node) + builtin = BUILT_IN_ATANL; + else + gcc_unreachable (); + + return addr_of_builtin_decl (builtin); +} + +tree +a68_real_ln (tree type) +{ + enum built_in_function builtin; + + if (type == float_type_node) + builtin = BUILT_IN_LOGF; + else if (type == double_type_node) + builtin = BUILT_IN_LOG; + else if (type == long_double_type_node) + builtin = BUILT_IN_LOGL; + else + gcc_unreachable (); + + return addr_of_builtin_decl (builtin); +} + +tree +a68_real_log (tree type) +{ + enum built_in_function builtin; + + if (type == float_type_node) + builtin = BUILT_IN_LOG10F; + else if (type == double_type_node) + builtin = BUILT_IN_LOG10; + else if (type == long_double_type_node) + builtin = BUILT_IN_LOG10L; + else + gcc_unreachable (); + + return addr_of_builtin_decl (builtin); +} + +tree +a68_real_exp (tree type) +{ + enum built_in_function builtin; + + if (type == float_type_node) + builtin = BUILT_IN_EXPF; + else if (type == double_type_node) + builtin = BUILT_IN_EXP; + else if (type == long_double_type_node) + builtin = BUILT_IN_EXPL; + else + gcc_unreachable (); + + return addr_of_builtin_decl (builtin); +} + +/* Build the real value lengthened from the value of VAL, from mode + FROM_MODE to mode TO_MODE. */ + +tree +a68_real_leng (MOID_T *to_mode, MOID_T *from_mode ATTRIBUTE_UNUSED, tree val) +{ + /* Lengthening can be done by just a conversion. */ + return fold_convert (CTYPE (to_mode), val); +} + +/* Build the real value that can be lengthened to the value of VAL, from mode + FROM_MODE to mode TO_MODE. + + If VAL cannot be represented in TO_MODE because it is bigger than the most + positive value representable in TO_MODE, then it is truncated to that value. + + Likewise, if VAL cannot be represented in TO_MODE because it is less than + the most negative value representable in TO_MODE, then it is truncated to + that value. */ + +tree +a68_real_shorten (MOID_T *to_mode, MOID_T *from_mode ATTRIBUTE_UNUSED, tree val) +{ + tree most_positive_value = fold_convert (CTYPE (from_mode), + a68_real_maxval (CTYPE (to_mode))); + tree most_negative_value = fold_convert (CTYPE (from_mode), + a68_real_minval (CTYPE (to_mode))); + + val = save_expr (val); + most_positive_value = save_expr (most_positive_value); + most_negative_value = save_expr (most_negative_value); + return fold_build3 (COND_EXPR, CTYPE (to_mode), + fold_build2 (GT_EXPR, a68_bool_type, val, most_positive_value), + fold_convert (CTYPE (to_mode), most_positive_value), + fold_build3 (COND_EXPR, CTYPE (to_mode), + fold_build2 (LT_EXPR, a68_bool_type, val, most_negative_value), + fold_convert (CTYPE (to_mode), most_negative_value), + fold_convert (CTYPE (to_mode), val))); +} + +/* Given a real expression VAL of mode MODE, produce an integral value which is + equal to the given real, or the next integer below (more negative than) the + given real. */ + +tree +a68_real_entier (tree val, MOID_T *to_mode, MOID_T *from_mode) +{ + tree fn = NULL_TREE; + tree to_type = CTYPE (to_mode); + + if (from_mode == M_REAL) + { + if (to_type == integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_IFLOORF); + else if (to_type == long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LFLOORF); + else if (to_type == long_long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LLFLOORF); + else + gcc_unreachable (); + } + else if (from_mode == M_LONG_REAL) + { + if (to_type == integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_IFLOOR); + else if (to_type == long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LFLOOR); + else if (to_type == long_long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LLFLOOR); + else + gcc_unreachable (); + } + else if (from_mode == M_LONG_LONG_REAL) + { + if (to_type == integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_IFLOORL); + else if (to_type == long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LFLOORL); + else if (to_type == long_long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LLFLOORL); + else + gcc_unreachable (); + } + else + gcc_unreachable (); + + return build_call_expr_loc (UNKNOWN_LOCATION, fn, 1, val); +} + +/* Given a real expression VAL of mode MODE, produce an integral value which is + the nearest integer to the given real. */ + +tree +a68_real_round (tree val, MOID_T *to_mode, MOID_T *from_mode) +{ + tree fn = NULL_TREE; + tree to_type = CTYPE (to_mode); + + if (from_mode == M_REAL) + { + if (to_type == integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_IROUNDF); + else if (to_type == long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LROUNDF); + else if (to_type == long_long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LLROUNDF); + else + gcc_unreachable (); + } + else if (from_mode == M_LONG_REAL) + { + if (to_type == integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_IROUND); + else if (to_type == long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LROUND); + else if (to_type == long_long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LLROUND); + else + gcc_unreachable (); + } + else if (from_mode == M_LONG_LONG_REAL) + { + if (to_type == integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_IROUNDL); + else if (to_type == long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LROUNDL); + else if (to_type == long_long_integer_type_node) + fn = builtin_decl_explicit (BUILT_IN_LLROUNDL); + else + gcc_unreachable (); + } + else + gcc_unreachable (); + + return build_call_expr_loc (UNKNOWN_LOCATION, fn, 1, val); +} + + +/* Given two real values of mode M, build an expression that calculates the + addition of A and B. */ + +tree +a68_real_plus (MOID_T *m, tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, PLUS_EXPR, CTYPE (m), a, b); +} + +/* Given two real values of mode M, build an expression that calculates the + subtraction of A by B. */ + +tree +a68_real_minus (MOID_T *m, tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, MINUS_EXPR, CTYPE (m), a, b); +} + +/* Given two real values of mode M, build an expression that calculates the + multiplication of A by B. */ + +tree +a68_real_mult (MOID_T *m, tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, MULT_EXPR, CTYPE (m), a, b); +} + +/* Given two real values of mode M, build an expression that calculates the + division of A by B. */ + +tree +a68_real_div (MOID_T *m, tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, RDIV_EXPR, CTYPE (m), a, b); +} + +/* Given two real values of mode M, build an expression that calculates whether + A = B. */ + +tree +a68_real_eq (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, EQ_EXPR, boolean_type_node, a, b); +} + +/* Given two real values of mode M, build an expression that calculates whether + A /= B. */ + +tree +a68_real_ne (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b); +} + +/* Given two real values of mode M, build an expression that calculates whether + A < B. */ + +tree +a68_real_lt (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, LT_EXPR, boolean_type_node, a, b); +} + +/* Given two real values of mode M, build an expression that calculates + whether A <= B. */ + +tree +a68_real_le (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, LE_EXPR, boolean_type_node, a, b); +} + +/* Given two real values of mode M, build an expression that calculates whether + A > B. */ + +tree +a68_real_gt (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, GT_EXPR, boolean_type_node, a, b); +} + +/* Given two real values of mode M, build an expression that calculates whether + A >= B. */ + +tree +a68_real_ge (tree a, tree b, location_t loc) +{ + return fold_build2_loc (loc, GE_EXPR, boolean_type_node, a, b); +} + +/* Exponentiation involving real values. + + REAL <- REAL, REAL + REAL <- REAL, INT + LONG REAL <- LONG REAL, LONG REAL + LONG REAL <- LONG REAL, INT + LONG LONG REAL <- LONG LONG REAL, LONG LONG REAL + LONG LONG REAL <- LONG LONG REAL, INT */ + +tree +a68_real_pow (MOID_T *m, MOID_T *a_mode, MOID_T *b_mode, + tree a, tree b, location_t loc) +{ + enum built_in_function built_in; + if (m == M_REAL) + { + gcc_assert (a_mode == M_REAL); + built_in = b_mode == M_REAL ? BUILT_IN_POWF : BUILT_IN_POWIF; + } + else if (m == M_LONG_REAL) + { + gcc_assert (a_mode == M_LONG_REAL); + built_in = b_mode == M_LONG_REAL ? BUILT_IN_POW : BUILT_IN_POWI; + } + else if (m == M_LONG_LONG_REAL) + { + gcc_assert (a_mode == M_LONG_LONG_REAL); + built_in = b_mode == M_LONG_LONG_REAL ? BUILT_IN_POWL : BUILT_IN_POWIL; + } + else + gcc_unreachable (); + + tree call = builtin_decl_explicit (built_in); + gcc_assert (call != NULL_TREE); + return build_call_expr_loc (loc, call, 2, a, b); +} diff --git a/gcc/algol68/a68-low-refs.cc b/gcc/algol68/a68-low-refs.cc new file mode 100644 index 000000000000..ba9987b57ed8 --- /dev/null +++ b/gcc/algol68/a68-low-refs.cc @@ -0,0 +1,52 @@ +/* Lowering routines for all things related to names. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Return a tree with the yielding of SKIP for the given name mode. */ + +tree +a68_get_ref_skip_tree (MOID_T *m) +{ + /* Build a NULL pointer. */ + return build_int_cst (CTYPE (m), 0); +} diff --git a/gcc/algol68/a68-low-runtime.cc b/gcc/algol68/a68-low-runtime.cc new file mode 100644 index 000000000000..4ea93e991e10 --- /dev/null +++ b/gcc/algol68/a68-low-runtime.cc @@ -0,0 +1,225 @@ +/* Libcalls to Algol 68 run-time functions. + Copyright (C) 2006-2025 Free Software Foundation, Inc. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + Adapted from gcc/d/runtime.cc. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* The lowering pass may generate expressions to call various runtime library + functions. Most of these functions are implemented in libga68. This file + provides facilities to compile libcalls to runtime functions. The file + a68-low-runtime.def contains a database of available runtime library + functions. */ + +enum a68_libcall_type +{ + LCT_VOID, + LCT_CHAR, + LCT_CONSTCHARPTR, + LCT_VOIDPTR, + LCT_UNISTR, + LCT_UNISTRPTR, + LCT_SIZE, + LCT_SSIZE, + LCT_SIZEPTR, + LCT_UINT, + LCT_INT, + LCT_LONGLONGINT, + LCT_FLOAT, + LCT_DOUBLE, + LCT_LONGDOUBLE, + LCT_END +}; + +/* An array of all types that are used by the runtime functions we need. */ + +static tree libcall_types[LCT_END]; + +/* Internal list of library functions. */ + +static tree libcall_decls[A68_LIBCALL_LAST]; + +/* Return the TREE type that is described by TYPE. */ + +static tree +get_libcall_type (a68_libcall_type type) +{ + if (libcall_types[type]) + return libcall_types[type]; + + if (type == LCT_VOID) + libcall_types[type] = void_type_node; + else if (type == LCT_CHAR) + libcall_types[type] = uint32_type_node; + else if (type == LCT_CONSTCHARPTR) + libcall_types[type] = build_pointer_type (build_qualified_type (char_type_node, + TYPE_QUAL_CONST)); + else if (type == LCT_VOIDPTR) + libcall_types[type] = ptr_type_node; + else if (type == LCT_UNISTR) + libcall_types[type] = build_pointer_type (a68_char_type); + else if (type == LCT_UNISTRPTR) + libcall_types[type] = build_pointer_type (build_pointer_type (a68_char_type)); + else if (type == LCT_SIZE) + libcall_types[type] = sizetype; + else if (type == LCT_SSIZE) + libcall_types[type] = ssizetype; + else if (type == LCT_SIZEPTR) + libcall_types[type] = build_pointer_type (sizetype); + else if (type == LCT_UINT) + libcall_types[type] = unsigned_type_node; + else if (type == LCT_INT) + libcall_types[type] = integer_type_node; + else if (type == LCT_LONGLONGINT) + libcall_types[type] = long_long_integer_type_node; + else if (type == LCT_FLOAT) + libcall_types[type] = float_type_node; + else if (type == LCT_DOUBLE) + libcall_types[type] = double_type_node; + else if (type == LCT_LONGDOUBLE) + libcall_types[type] = long_double_type_node; + else + gcc_unreachable (); + + return libcall_types[type]; +} + +/* Build and return a function declaration named NAME. The RETURN_TYPE is the + type returned, FLAGS are the expression call flags, and NPARAMS is the + number of arguments, the types of which are provided in `...'. */ + +static tree +build_libcall_decl (const char *name, a68_libcall_type return_type, + int flags, int nparams, ...) +{ + tree *args = XALLOCAVEC (tree, nparams); + bool varargs = false; + tree fntype; + + /* Add parameter types, using `void' as the last parameter type + to mean this function accepts a variable list of arguments. */ + va_list ap; + va_start (ap, nparams); + + for (int i = 0; i < nparams; i++) + { + a68_libcall_type ptype = (a68_libcall_type) va_arg (ap, int); + tree type = get_libcall_type (ptype); + + if (type == void_type_node) + { + varargs = true; + nparams = i; + } + else + args[i] = type; + } + + va_end (ap); + + /* Build the function. */ + tree tret = get_libcall_type (return_type); + if (varargs) + fntype = build_varargs_function_type_array (tret, nparams, args); + else + fntype = build_function_type_array (tret, nparams, args); + + tree decl = build_decl (UNKNOWN_LOCATION, FUNCTION_DECL, + get_identifier (name), fntype); + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + DECL_ARTIFICIAL (decl) = 1; + DECL_VISIBILITY (decl) = VISIBILITY_DEFAULT; + DECL_VISIBILITY_SPECIFIED (decl) = 1; + + /* Set any attributes on the function, such as malloc or noreturn. */ + set_call_expr_flags (decl, flags); + return decl; +} + +/* Return or create the runtime library function declaration for LIBCALL. + Library functions are generated as needed. This could probably be changed + in the future to be done in the compiler init stage, like GCC builtin trees + are. */ + +tree +a68_get_libcall (a68_libcall_fn libcall) +{ + if (libcall_decls[libcall]) + return libcall_decls[libcall]; + + switch (libcall) + { +#define DEF_A68_RUNTIME(CODE, NAME, TYPE, PARAMS, FLAGS) \ + case A68_LIBCALL_ ## CODE: \ + libcall_decls[libcall] = build_libcall_decl (NAME, TYPE, FLAGS, PARAMS); \ + break; +#include "a68-low-runtime.def" +#undef DEF_A68_RUNTIME + default: + gcc_unreachable (); + } + + return libcall_decls[libcall]; +} + +/* Generate a call to LIBCALL, returning the result as TYPE. NARGS is the + number of call arguments, the expressions of which are provided in `...'. + This does not perform conversions or promotions on the arguments. */ + +tree +a68_build_libcall (a68_libcall_fn libcall, tree type ATTRIBUTE_UNUSED, + int nargs, ...) +{ + /* Build the call expression to the runtime function. */ + tree decl = a68_get_libcall (libcall); + tree *args = XALLOCAVEC (tree, nargs); + va_list ap; + + va_start (ap, nargs); + for (int i = 0; i < nargs; i++) + args[i] = va_arg (ap, tree); + va_end (ap); + + tree result = build_call_expr_loc_array (input_location, decl, nargs, args); + + /* Assumes caller knows what it is doing. */ + return result; +} diff --git a/gcc/algol68/a68-low-runtime.def b/gcc/algol68/a68-low-runtime.def new file mode 100644 index 000000000000..04cca03ca51b --- /dev/null +++ b/gcc/algol68/a68-low-runtime.def @@ -0,0 +1,92 @@ +/* a68-low-runtime.def -- Definitions for Algol 68 runtime functions. + Copyright (C) 2025 Jose E. Marchesi. + +GCC is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GCC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +/* Helper macros for parameter building. */ +#define P0() 0 +#define P1(T1) 1, LCT_ ## T1 +#define P2(T1, T2) \ + 2, LCT_ ## T1, LCT_ ## T2 +#define P3(T1, T2, T3) \ + 3, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3 +#define P4(T1, T2, T3, T4) \ + 4, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4 +#define P5(T1, T2, T3, T4, T5) \ + 5, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4, LCT_ ## T5 +#define P6(T1, T2, T3, T4, T5, T6) \ + 6, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4, LCT_ ## T5, LCT_ ## T6 +#define P7(T1, T2, T3, T4, T5, T6, T7) \ + 7, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4, LCT_ ## T5, LCT_ ## T6, LCT_ ## T7 +#define RT(T1) LCT_ ## T1 + +/* Algol 68 runtime library functions. */ + +/* DEF_A68_RUNTIME (CODE, NAME, TYPE, PARAMS, FLAGS) + CODE The enum code used to refer to this function. + NAME The name of this function as a string. + FLAGS ECF flags to describe attributes of the function. + + Used for declaring functions that are called by generated code. */ + +DEF_A68_RUNTIME (ASSERT, "_libga68_assert", RT(VOID), P2(CONSTCHARPTR, UINT), ECF_NORETURN) +DEF_A68_RUNTIME (SET_EXIT_STATUS, "_libga68_set_exit_status", RT(VOID), P1(INT), 0) +DEF_A68_RUNTIME (MALLOC, "_libga68_malloc", RT(VOIDPTR), P1(SIZE), ECF_NOTHROW | ECF_LEAF | ECF_MALLOC) +DEF_A68_RUNTIME (DEREFNIL, "_libga68_derefnil", RT(VOID), P2(CONSTCHARPTR, UINT), ECF_NORETURN) +DEF_A68_RUNTIME (UNREACHABLE, "_libga68_unreachable", RT(VOID), P2(CONSTCHARPTR, UINT), ECF_NORETURN) +DEF_A68_RUNTIME (INVALIDCHARERROR, "_libga68_invalidcharerror", RT(VOID), P3(CONSTCHARPTR,UINT,INT), ECF_NORETURN) +DEF_A68_RUNTIME (BITSBOUNDSERROR, "_libga68_bitsboundserror", RT(VOID), P3(CONSTCHARPTR,UINT,SSIZE), ECF_NORETURN) +DEF_A68_RUNTIME (ARRAYLOWERBOUND, "_libga68_lower_bound", RT(VOID), + P4(CONSTCHARPTR, UINT, SSIZE, SSIZE), ECF_NORETURN) +DEF_A68_RUNTIME (ARRAYUPPERBOUND, "_libga68_upper_bound", RT(VOID), + P4(CONSTCHARPTR, UINT, SSIZE, SSIZE), ECF_NORETURN) +DEF_A68_RUNTIME (ARRAYBOUNDS, "_libga68_bounds", RT(VOID), + P5(CONSTCHARPTR, UINT, SSIZE, SSIZE, SSIZE), ECF_NORETURN) +DEF_A68_RUNTIME (ARRAYBOUNDSMISMATCH, "_libga68_bounds_mismatch", RT(VOID), + P7(CONSTCHARPTR, UINT, SIZE, SSIZE, SSIZE, SSIZE, SSIZE), ECF_NORETURN) +DEF_A68_RUNTIME (ARRAYDIM, "_libga68_dim", RT(VOID), + P4(CONSTCHARPTR, UINT, SIZE, SIZE), ECF_NORETURN) +DEF_A68_RUNTIME (RANDOM, "_libga68_random", RT(FLOAT), P0(), 0) +DEF_A68_RUNTIME (LONGRANDOM, "_libga68_longrandom", RT(DOUBLE), P0(), 0) +DEF_A68_RUNTIME (LONGLONGRANDOM, "_libga68_longlongrandom", RT(LONGDOUBLE), P0(), 0) +DEF_A68_RUNTIME (POSIX_FCONNECT, "_libga68_posixfconnect", RT(INT), P4(UNISTRPTR,SIZE,SIZE,INT), 0) +DEF_A68_RUNTIME (POSIX_FOPEN, "_libga68_posixfopen", RT(INT), P4(UNISTRPTR,SIZE,SIZE,UINT), 0) +DEF_A68_RUNTIME (POSIX_FCREATE, "_libga68_posixcreat", RT(INT), P4(UNISTRPTR,SIZE,SIZE,UINT), 0) +DEF_A68_RUNTIME (POSIX_FCLOSE, "_libga68_posixclose", RT(INT), P0(), 0) +DEF_A68_RUNTIME (POSIX_FSIZE, "_libga68_posixfsize", RT(LONGLONGINT), P1(INT), 0) +DEF_A68_RUNTIME (POSIX_ARGC, "_libga68_posixargc", RT(INT), P0(), 0) +DEF_A68_RUNTIME (POSIX_ARGV, "_libga68_posixargv", RT(UNISTRPTR), P2(INT, SIZEPTR), 0) +DEF_A68_RUNTIME (POSIX_PUTCHAR, "_libga68_posixputchar", RT(CHAR), P1(CHAR), 0) +DEF_A68_RUNTIME (POSIX_FPUTC, "_libga68_posixfputc", RT(CHAR), P2(INT,CHAR), 0) +DEF_A68_RUNTIME (POSIX_PUTS, "_libga68_posixputs", RT(VOID), P3(UNISTR,SIZE,SIZE), 0) +DEF_A68_RUNTIME (POSIX_FPUTS, "_libga68_posixfputs", RT(INT), P4(INT,UNISTRPTR,SIZE,SIZE), 0) +DEF_A68_RUNTIME (POSIX_GETCHAR, "_libga68_posixgetchar", RT(CHAR), P0(), 0) +DEF_A68_RUNTIME (POSIX_FGETC, "_libga68_posixfgetc", RT(CHAR), P1(INT), 0) +DEF_A68_RUNTIME (POSIX_GETS, "_libga68_posixgets", RT(UNISTRPTR), P2(INT,SIZEPTR), 0) +DEF_A68_RUNTIME (POSIX_FGETS, "_libga68_posixfgets", RT(UNISTRPTR), P3(INT,INT,SIZEPTR), 0) +DEF_A68_RUNTIME (POSIX_GETENV, "_libga68_posixgetenv", RT(VOID), P5(UNISTR,SIZE,SIZE,UNISTRPTR,SIZEPTR), 0) +DEF_A68_RUNTIME (POSIX_ERRNO, "_libga68_posixerrno", RT(INT), P0(), 0) +DEF_A68_RUNTIME (POSIX_PERROR, "_libga68_posixperror", RT(VOID), P3(UNISTR,SIZE,SIZE), 0) +DEF_A68_RUNTIME (POSIX_STRERROR, "_libga68_posixstrerror", RT(UNISTRPTR), P2(INT, SIZEPTR), 0) +DEF_A68_RUNTIME (POSIX_LSEEK, "_libga68_posixlseek", RT(LONGLONGINT), P3(INT,LONGLONGINT,INT), 0) +DEF_A68_RUNTIME (U32_CMP2, "_libga68_u32_cmp2", RT(INT), P6(UNISTR, SIZE, SIZE, UNISTR, SIZE, SIZE), 0) + +#undef P0 +#undef P1 +#undef P2 +#undef P3 +#undef P4 +#undef P5 +#undef RT diff --git a/gcc/algol68/a68-low-strings.cc b/gcc/algol68/a68-low-strings.cc new file mode 100644 index 000000000000..f5822037e33b --- /dev/null +++ b/gcc/algol68/a68-low-strings.cc @@ -0,0 +1,399 @@ +/* Lowering routines for all things related to STRINGs. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Return a tree with the yielding of SKIP for M_STRING. */ + +tree +a68_get_string_skip_tree (void) +{ + return a68_get_multiple_skip_tree (M_FLEX_ROW_CHAR); +} + +/* Copy chars from STR to ELEMENTS starting at TO_INDEX chars in ELEMENTS. */ + +static void +copy_string (tree elements, tree to_index, tree str) +{ + tree char_pointer_type = build_pointer_type (a68_char_type); + tree num_elems + = a68_lower_tmpvar ("num_elems%", sizetype, a68_multiple_num_elems (str)); + + tree from_index + = a68_lower_tmpvar ("from_index%", sizetype, size_zero_node); + tree from_offset + = a68_lower_tmpvar ("from_offset%", sizetype, size_zero_node); + + /* Begin of loop body. */ + a68_push_range (NULL); + { + /* if (from_index == num_elems) break; */ + a68_add_stmt (fold_build1 (EXIT_EXPR, void_type_node, + fold_build2 (GE_EXPR, sizetype, + from_index, num_elems))); + + /* *(elements + to_index) = *(elements + from_index) */ + tree to_offset = fold_build2 (MULT_EXPR, sizetype, + to_index, size_in_bytes (a68_char_type)); + a68_add_stmt (fold_build2 (MODIFY_EXPR, + void_type_node, + fold_build2 (MEM_REF, a68_char_type, + fold_build2 (POINTER_PLUS_EXPR, + char_pointer_type, + elements, to_offset), + fold_convert (char_pointer_type, + integer_zero_node)), + fold_build2 (MEM_REF, a68_char_type, + fold_build2 (POINTER_PLUS_EXPR, + char_pointer_type, + a68_multiple_elements (str), + from_offset), + fold_convert (char_pointer_type, + integer_zero_node)))); + + /* from_offset = from_offset + stride */ + a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node, + from_offset, + fold_build2 (PLUS_EXPR, sizetype, + from_offset, + a68_multiple_stride (str, size_zero_node)))); + /* to_index = to_index + 1 */ + a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, sizetype, to_index, size_one_node)); + + /* from_index = from_index + 1 */ + a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, sizetype, from_index, size_one_node)); + } + + /* End of loop body. */ + tree loop_body = a68_pop_range (); + a68_add_stmt (fold_build1 (LOOP_EXPR, + void_type_node, + loop_body)); +} + +/* Given two STRINGs STR1 and STR2, allocate a new string on the stack with a + copy of the concatenated characters of the given string. */ + +tree +a68_string_concat (tree str1, tree str2) +{ + tree char_pointer_type = build_pointer_type (a68_char_type); + static tree string_concat_fndecl; + + if (string_concat_fndecl == NULL_TREE) + { + string_concat_fndecl + = a68_low_toplevel_func_decl ("string_concat", + build_function_type_list (char_pointer_type, + TREE_TYPE (str1), + TREE_TYPE (str2), + NULL_TREE)); + announce_function (string_concat_fndecl); + + tree s1 = a68_low_func_param (string_concat_fndecl, "s1", TREE_TYPE (str1)); + tree s2 = a68_low_func_param (string_concat_fndecl, "s2", TREE_TYPE (str2)); + DECL_ARGUMENTS (string_concat_fndecl) = chainon (s1, s2); + + a68_push_function_range (string_concat_fndecl, char_pointer_type, + true /* top_level */); + + tree n1 = a68_lower_tmpvar ("n1%", sizetype, a68_multiple_num_elems (s1)); + tree n2 = a68_lower_tmpvar ("n2%", sizetype, a68_multiple_num_elems (s2)); + tree num_elems = a68_lower_tmpvar ("num_elems%", sizetype, + fold_build2 (PLUS_EXPR, sizetype, n1, n2)); + + /* First allocate memory for the result string. We need enough space to + hold the elements of both strings with a stride of 1S. */ + tree char_pointer_type = build_pointer_type (a68_char_type); + tree elements_size = fold_build2 (MULT_EXPR, sizetype, + size_in_bytes (a68_char_type), + num_elems); + tree elements = a68_lower_tmpvar ("elements%", char_pointer_type, + a68_lower_malloc (a68_char_type, elements_size)); + + /* Copy elements. */ + tree to_index = a68_lower_tmpvar ("to_index%", sizetype, size_zero_node); + copy_string (elements, to_index, s1); + copy_string (elements, to_index, s2); + a68_pop_function_range (elements); + } + + /* Build the resulting multiple. */ + str1 = save_expr (str1); + str2 = save_expr (str2); + tree n1 = a68_multiple_num_elems (str1); + tree n2 = a68_multiple_num_elems (str2); + tree num_elems = save_expr (fold_build2 (PLUS_EXPR, sizetype, n1, n2)); + tree elements_size = fold_build2 (MULT_EXPR, sizetype, + size_in_bytes (a68_char_type), + num_elems); + tree lower_bound = ssize_int (1); + tree upper_bound = fold_convert (ssizetype, num_elems); + tree elements = build_call_nary (char_pointer_type, + fold_build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (string_concat_fndecl)), + string_concat_fndecl), + 2, str1, str2); + return a68_row_value (CTYPE (M_STRING), 1 /* dim */, + elements, elements_size, + &lower_bound, &upper_bound); +} + +/* Given a STRING STR and an INT FACTOR, return STRING concatenated to itself + FACTOR - 1 times. + + Negative values of FACTOR are interpreted as zero. */ + +tree +a68_string_mult (tree str, tree factor) +{ + a68_push_range (M_STRING); + + str = save_expr (str); + tree ssize_one_node = ssize_int (1); + tree res = a68_lower_tmpvar ("res%", CTYPE (M_STRING), str); + tree index = a68_lower_tmpvar ("index%", ssizetype, ssize_one_node); + + /* Begin of loop body. */ + a68_push_range (NULL); + + /* if (index == FACTOR) break; */ + a68_add_stmt (fold_build1 (EXIT_EXPR, + void_type_node, + fold_build2 (GE_EXPR, ssizetype, + index, + fold_convert (ssizetype, factor)))); + + /* res += str */ + a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (res), + res, + a68_string_concat (res, str))); + + /* index++ */ + a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, + ssizetype, + index, ssize_one_node)); + tree loop_body = a68_pop_range (); + /* End of loop body. */ + a68_add_stmt (fold_build1 (LOOP_EXPR, + void_type_node, + loop_body)); + a68_add_stmt (res); + return a68_pop_range (); +} + +/* Given a CHAR C, build a string whose contents are just that CHAR. */ + +tree +a68_string_from_char (tree c) +{ + tree lower_bound = ssize_int (1); + tree upper_bound = lower_bound; + tree char_pointer_type = build_pointer_type (a68_char_type); + + a68_push_range (M_STRING); + + tree elements = a68_lower_tmpvar ("elements%", char_pointer_type, + a68_lower_malloc (a68_char_type, + size_one_node)); + a68_add_stmt (fold_build2 (MODIFY_EXPR, + void_type_node, + fold_build1 (INDIRECT_REF, a68_char_type, elements), + c)); + a68_add_stmt (a68_row_value (CTYPE (M_STRING), 1 /* dim */, + elements, + size_in_bytes (a68_char_type), + &lower_bound, &upper_bound)); + return a68_pop_range (); +} + +/* Compare the two given strings lexicographically and return -1 (less than), 0 + (equal to) or 1 (bigger than) reflecting the result of the comparison. */ + +tree +a68_string_cmp (tree s1, tree s2) +{ + s1 = save_expr (s1); + tree s1_elems = a68_multiple_elements (s1); + tree s1_len = a68_multiple_num_elems (s1); + tree s1_stride = a68_multiple_stride (s1, size_zero_node); + + s2 = save_expr (s2); + tree s2_elems = a68_multiple_elements (s2); + tree s2_len = a68_multiple_num_elems (s2); + tree s2_stride = a68_multiple_stride (s2, size_zero_node); + + return a68_build_libcall (A68_LIBCALL_U32_CMP2, + a68_int_type, 6, + s1_elems, s1_len, s1_stride, + s2_elems, s2_len, s2_stride); +} + +/* Return a newly allocated UTF-8 string resulting from processing the string + breaks in STR. This function assumes the passed string is well-formed (the + scanner is in charge of seeing that is true) and just ICEs if it is not. + NODE is used as the location for diagnostics in case the string breaks + contain some invalid data. */ + +char * +a68_string_process_breaks (NODE_T *node, const char *str) +{ + size_t len = 0; + char *res = NULL; + + /* First calculate the size of the resulting string. */ + for (const char *p = str; *p != '\0';) + { + if (*p == '\'') + { + switch (p[1]) + { + case '\'': + case 'n': + case 'f': + case 'r': + case 't': + len += 1; + p += 2; + break; + case '(': + p += 2; + while (1) + { + if (p[0] == ')') + { + p++; + break; + } + else if (p[0] == ',' || ISSPACE (p[0])) + { + p++; + continue; + } + + /* An Unicode codepoint encoded in UTF-8 occupies at most six + octets. */ + len += 6; + p += (p[0] == 'u' ? 5 : 9); + } + break; + default: + gcc_unreachable (); + } + } + else + { + len += 1; + p += 1; + } + } + + /* Now and allocate it, adding space for a trailing NULL. */ + res = (char *) xmalloc (len + 1); + + /* Finally fill it with the result of expanding all the string breaks. */ + size_t offset = 0; + for (const char *p = str; *p != '\0';) + { + if (*p == '\'') + { + switch (p[1]) + { + case '\'': res[offset] = '\''; p += 2; offset += 1; break; + case 'n': res[offset] = '\n'; p += 2; offset += 1; break; + case 't': res[offset] = '\t'; p += 2; offset += 1; break; + case 'r': res[offset] = '\r'; p += 2; offset += 1; break; + case 'f': res[offset] = '\f'; p += 2; offset += 1; break; + case '(': + { + p += 2; + while (1) + { + if (p[0] == ')') + { + p++; + break; + } + else if (p[0] == ',' || ISSPACE (p[0])) + { + p++; + continue; + } + + /* Skip the u or U. */ + gcc_assert (p[0] == 'u' || p[0] == 'U'); + p++; + + const char *begin = p; + char *end; + int64_t codepoint = strtol (p, &end, 16); + gcc_assert (end > p); + p = end; + /* Append the UTF-8 encoding of the obtained codepoint to + the `res' string. */ + int n = a68_u8_uctomb ((uint8_t *) res + offset, codepoint, 6); + if (n < 0) + { + char *start = CHAR_IN_LINE (INFO (node)) + (begin - str); + a68_scan_error (LINE (INFO (node)), start, + "invalid Unicode codepoint in string literal"); + } + + offset += n; + } + break; + } + default: gcc_unreachable (); + } + } + else + { + res[offset] = *p; + offset += 1; + p += 1; + } + } + res[offset] = '\0'; + + return res; +} diff --git a/gcc/algol68/a68-low-structs.cc b/gcc/algol68/a68-low-structs.cc new file mode 100644 index 000000000000..12bb6192fb43 --- /dev/null +++ b/gcc/algol68/a68-low-structs.cc @@ -0,0 +1,63 @@ +/* Lowering routines for all things related to structs. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Return a tree with the yielding of SKIP for the given structured mode. */ + +tree +a68_get_struct_skip_tree (MOID_T *m) +{ + /* Build a constructor that assigns SKIPs to each field in the struct + type. */ + + vec *ve = NULL; + tree field = TYPE_FIELDS (CTYPE (m)); + for (PACK_T *elem = PACK (m); elem; FORWARD (elem)) + { + gcc_assert (field != NULL_TREE); + CONSTRUCTOR_APPEND_ELT (ve, field, a68_get_skip_tree (MOID (elem))); + field = DECL_CHAIN (field); + } + + return build_constructor (CTYPE (m), ve); +} diff --git a/gcc/algol68/a68-low-unions.cc b/gcc/algol68/a68-low-unions.cc new file mode 100644 index 000000000000..f775877f3271 --- /dev/null +++ b/gcc/algol68/a68-low-unions.cc @@ -0,0 +1,279 @@ +/* Lowering routines for all things related to unions. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Algol 68 unions are implemented in this front-end as a data structure + consisting of an overhead followed by a value: + + overhead% + value% + + Where overhead% is an index that identifies the kind of object currently + united, and value% is a GENERIC union. The value currently united in the + union is the overhead%-th field in value%. + + At the language level there are no values of union modes in Algol 68. All + values are built from either SKIP (for uninitialized UNION values) or as the + result of an uniting coercion. */ + +/* Given an union mode P and a mode Q, return whether Q is a mode in P. */ + +bool +a68_union_contains_mode (MOID_T *p, MOID_T *q) +{ + while (EQUIVALENT (p) != NO_MOID) + p = EQUIVALENT (p); + + for (PACK_T *pack = PACK (p); pack != NO_PACK; FORWARD (pack)) + { + MOID_T *m = MOID (pack); + + if (a68_is_equal_modes (q, m, SAFE_DEFLEXING) + || (m == M_STRING && IS_ROW (q) && SUB (q) == M_CHAR) + || (q == M_STRING && IS_ROW (m) && SUB (m) == M_CHAR)) + return true; + } + + return false; +} + +/* Given an union mode P and a mode Q, return an integer with the index of the + occurrence of Q in P. */ + +int +a68_united_mode_index (MOID_T *p, MOID_T *q) +{ + int ret = 0; + while (EQUIVALENT (p) != NO_MOID) + p = EQUIVALENT (p); + for (PACK_T *pack = PACK (p); pack != NO_PACK; FORWARD (pack)) + { + MOID_T *m = MOID (pack); + + if (a68_is_equal_modes (q, m, SAFE_DEFLEXING) + || (m == M_STRING && IS_ROW (q) && SUB (q) == M_CHAR) + || (q == M_STRING && IS_ROW (m) && SUB (m) == M_CHAR)) + return ret; + ret += 1; + } + + /* Not found. Shouldn't happen. */ + gcc_unreachable (); + return 0; +} + +/* Given two united modes FROM and TO, and an overhead FROM_OVERHEAD in mode + FROM, return the corresponding overhead in mode TO. + + This function assumes that the mode with FROM_OVERHEAD in mode FROM exists + in TO. */ + +tree +a68_union_translate_overhead (MOID_T *from, tree from_overhead, + MOID_T *to) +{ + /* Note that the initialization value for to_overhead should never be used. + XXX perhaps translate it to a run-time call to abort/compiler-error. */ + tree to_overhead = size_int (0); + + from_overhead = save_expr (from_overhead); + + int i = 0; + for (PACK_T *pack = PACK (from); pack != NO_PACK; FORWARD (pack), ++i) + { + MOID_T *mode = MOID (pack); + + if (a68_union_contains_mode (to, mode)) + { + to_overhead = fold_build3 (COND_EXPR, sizetype, + fold_build2 (EQ_EXPR, boolean_type_node, + from_overhead, + size_int (i)), + size_int (a68_united_mode_index (to, mode)), + to_overhead); + } + } + + return to_overhead; +} + +/* Get the overhead of a given united value EXP. */ + +tree +a68_union_overhead (tree exp) +{ + tree type = TREE_TYPE (exp); + tree overhead_field = TYPE_FIELDS (type); + return fold_build3 (COMPONENT_REF, + TREE_TYPE (overhead_field), + exp, + overhead_field, + NULL_TREE); +} + +/* Set the overhead of a given united value EXP to OVERHEAD. */ + +tree +a68_union_set_overhead (tree exp, tree overhead) +{ + tree type = TREE_TYPE (exp); + tree overhead_field = TYPE_FIELDS (type); + return fold_build2 (MODIFY_EXPR, + TREE_TYPE (overhead), + fold_build3 (COMPONENT_REF, + TREE_TYPE (overhead_field), + exp, + overhead_field, + NULL_TREE), + overhead); +} + +/* Get the cunion in the given union EXP. */ + +tree +a68_union_cunion (tree exp) +{ + tree type = TREE_TYPE (exp); + tree value_field = TREE_CHAIN (TYPE_FIELDS (type)); + return fold_build3 (COMPONENT_REF, + TREE_TYPE (value_field), + exp, + value_field, + NULL_TREE); +} + +/* Build a SKIP value for a given union mode M. + + The SKIP value computed is: + + overhead% refers to the first united mode in the union + value% is the SKIP for the first united mode in the union +*/ + +tree +a68_get_union_skip_tree (MOID_T *m) +{ + tree type = CTYPE (m); + tree overhead_field = TYPE_FIELDS (type); + tree value_field = TREE_CHAIN (TYPE_FIELDS (type)); + + /* Overhead selects the first union alternative. */ + tree overhead = size_zero_node; + /* First union alternative. + + Note that the first union alternative corresponds to the last alternative + in the mode as written in the source program. */ + tree value_type = TREE_TYPE (value_field); + tree first_alternative_field = TYPE_FIELDS (value_type); + tree value = build_constructor_va (TREE_TYPE (value_field), + 1, + first_alternative_field, + a68_get_skip_tree (MOID (PACK (m)))); + return build_constructor_va (CTYPE (m), + 2, + overhead_field, overhead, + value_field, value); +} + +/* Return the alternative (value) at the index INDEX in the united value + EXP. */ + +tree +a68_union_alternative (tree exp, int index) +{ + tree type = TREE_TYPE (exp); + tree value_field = TREE_CHAIN (TYPE_FIELDS (type)); + tree value = fold_build3 (COMPONENT_REF, + TREE_TYPE (value_field), + exp, + value_field, + NULL_TREE); + + /* Get the current alternative in the value union. */ + tree value_type = TREE_TYPE (value_field); + tree alternative_field = TYPE_FIELDS (value_type); + for (int i = 0; i < index; ++i) + { + gcc_assert (TREE_CHAIN (alternative_field)); + alternative_field = TREE_CHAIN (alternative_field); + } + + /* Get the current alternative from the value. */ + return fold_build3 (COMPONENT_REF, + TREE_TYPE (alternative_field), + value, + alternative_field, + NULL_TREE); +} + +/* Return a constructor for an union of mode MODE, holding the value in EXP + which is of mode EXP_MODE. */ + +tree +a68_union_value (MOID_T *mode, tree exp, MOID_T *exp_mode) +{ + tree type = CTYPE (mode); + tree overhead_field = TYPE_FIELDS (type); + tree value_field = TREE_CHAIN (TYPE_FIELDS (type)); + + int alternative_index = a68_united_mode_index (mode, exp_mode); + tree overhead = build_int_cst (sizetype, alternative_index); + + /* Get the field for the alternative corresponding to alternative_index. */ + tree value_type = TREE_TYPE (value_field); + tree alternative_field = TYPE_FIELDS (value_type); + for (int i = 0; i < alternative_index; ++i) + { + gcc_assert (TREE_CHAIN (alternative_field)); + alternative_field = TREE_CHAIN (alternative_field); + } + + tree value = build_constructor_va (TREE_TYPE (value_field), + 1, + alternative_field, + a68_consolidate_ref (exp_mode, exp)); + return build_constructor_va (type, + 2, + overhead_field, overhead, + value_field, value); +} diff --git a/gcc/algol68/a68-low-units.cc b/gcc/algol68/a68-low-units.cc new file mode 100644 index 000000000000..9802468873b2 --- /dev/null +++ b/gcc/algol68/a68-low-units.cc @@ -0,0 +1,1253 @@ +/* Lower units to GENERIC. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Note that enclosed clauses, which are units, are handled in + a68-low-clauses. */ + +/* Lower an applied identifier. + + This lowers into the declaration of the referred identifier. The + declaration of the identifier should now be available in the symbol table + entry for the identifier. */ + +tree +a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx) +{ + if (TAG_TABLE (TAX (p)) == A68_STANDENV) + { + /* This identifier is defined in the standard prelude. Use its lowering + handler. */ + LOWERER_T lowerer = LOWERER (TAX (p)); + return (*lowerer) (p, ctx); + } + else + { + tree id_decl = TAX_TREE_DECL (TAX (p)); + + if (id_decl == NULL_TREE) + { + /* This is an applied identifier used before the corresponding defining + identifier gets defined in either an identity declaration or a + variable declaration. Create the declaration and install it in the + symbol table. The declaration itself, declaration expr and + initialization assignment for the declaration will be emitted by the + corresponding declaration lowering handler. Note that the defining + identifier (and therefore the declaration associated with this applied + identifier) may be in an outer lexical block. */ + + if (IS (MOID (p), PROC_SYMBOL)) + { + bool external = (MOIF (TAX (p)) != NO_MOIF); + const char *extern_symbol = EXTERN_SYMBOL (TAX (p)); + if (VARIABLE (TAX (p))) + { + if (external) + id_decl + = a68_make_variable_declaration_decl (p, NAME (MOIF (TAX (p))), external, + extern_symbol); + else + id_decl + = a68_make_variable_declaration_decl (p, ctx.module_definition_name); + } + else if (IN_PROC (TAX (p))) + { + if (external) + id_decl + = a68_make_proc_identity_declaration_decl (p, NAME (MOIF (TAX (p))), + false /* indicant */, + external, + extern_symbol); + else + id_decl + = a68_make_proc_identity_declaration_decl (p, ctx.module_definition_name); + } + else + { + if (external) + id_decl + = a68_make_identity_declaration_decl (p, NAME (MOIF (TAX (p))), + false /* indicant */, + external, extern_symbol); + else + id_decl + = a68_make_identity_declaration_decl (p, ctx.module_definition_name); + } + } + else + { + bool external = (MOIF (TAX (p)) != NO_MOIF); + const char *extern_symbol = EXTERN_SYMBOL (TAX (p)); + if (VARIABLE (TAX (p))) + { + if (external) + id_decl + = a68_make_variable_declaration_decl (p, NAME (MOIF (TAX (p))), external, + extern_symbol); + else + id_decl + = a68_make_variable_declaration_decl (p, ctx.module_definition_name); + } + else + { + if (external) + id_decl + = a68_make_identity_declaration_decl (p, NAME (MOIF (TAX (p))), + false /* indicant */, external, + extern_symbol); + else + id_decl + = a68_make_identity_declaration_decl (p, ctx.module_definition_name); + } + } + + TAX_TREE_DECL (TAX (p)) = id_decl; + } + + /* If the identifier refers to a FUNCTION_DECL, this means the declaration + was made by a procecure-identity-dclaration. The applied identifier in + that case refers to the address of the corresponding function. */ + if (TREE_CODE (id_decl) == FUNCTION_DECL) + return fold_build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (id_decl)), + id_decl); + else + return id_decl; + } +} + +/* Lower a string denotation. + + String denotations are of mode []CHAR, and lower into a multiple with a + single dimension, and with the following characteristics: + + - The lower bound of dimension 0 is 1. + - The upper bound of dimension 0 is strlen (NSYMBOL (p)). + - The stride of dimension 0 is 0. + - The pointed elements are a buffer of CHARs allocated in the stack. */ + +tree +a68_lower_string_denotation (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + /* First process string breaks. */ + char *str = a68_string_process_breaks (p, NSYMBOL (p)); + + /* Build a multiple of UCS-4 CHARs from the resulting UTF-8 string. */ + size_t ucslen; + uint32_t *ucsbuf = a68_u8_to_u32 ((const uint8_t *) str, strlen (str), + NULL, &ucslen); + free (str); + tree string_literal = build_string_literal (ucslen * sizeof (uint32_t), + (char *) ucsbuf, a68_char_type); + tree elements = string_literal; + tree lower_bound = fold_convert (ssizetype, size_one_node); + tree upper_bound = ssize_int (ucslen); + tree elements_size = fold_build2 (MULT_EXPR, sizetype, + size_int (ucslen), + size_in_bytes (a68_char_type)); + tree multiple = a68_row_value (CTYPE (M_ROW_CHAR), 1, + elements, elements_size, + &lower_bound, &upper_bound); + TREE_CONSTANT (multiple) = true; + free (ucsbuf); + return multiple; +} + +/* Lower denotation. + + denotation : int denotation; real denotation; bits denotation; + row char denotation; + true symbol; false symbol; + empty symbol; + longety, int denotation; + longety, real denotation; + longety, bits denotation; + shortety, int denotation; + shortety, real denotation; + shortety, bits denotation. + + Denotations lower into GENERIC cst expressions. */ + +tree +a68_lower_denotation (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *moid = MOID (p); + + if (moid == M_VOID) + /* EMPTY */ + return a68_lower_empty (p, ctx); + else if (moid == M_BOOL) + /* TRUE or FALSE. */ + return (NSYMBOL (p)[0] == 'T') ? boolean_true_node : boolean_false_node; + else if (moid == M_CHAR) + { + char *s = a68_string_process_breaks (p, NSYMBOL (p)); + uint32_t ucs; + int length = a68_u8_mbtouc (&ucs, (const uint8_t *) s, 1); + gcc_assert (length == 1); + free (s); + return build_int_cst (a68_char_type, ucs); + } + else if (moid == M_ROW_CHAR) + return a68_lower_string_denotation (p, ctx); + else if (moid == M_INT + || moid == M_LONG_INT + || moid == M_LONG_LONG_INT + || moid == M_SHORT_INT + || moid == M_SHORT_SHORT_INT) + { + /* SIZETY INT */ + tree type; + char *end; + NODE_T *s = NO_NODE; + if (IS (SUB (p), LONGETY) || IS (SUB (p), SHORTETY)) + s = NEXT (SUB (p)); + else + s = SUB (p); + + type = CTYPE (moid); + int64_t val = strtol (NSYMBOL (s), &end, 10); + gcc_assert (end[0] == '\0'); + return build_int_cst (type, val); + } + if (moid == M_BITS + || moid == M_LONG_BITS + || moid == M_LONG_LONG_BITS + || moid == M_SHORT_BITS + || moid == M_SHORT_SHORT_BITS) + { + /* SIZETY BITS */ + + tree type; + char *end; + NODE_T *s = NO_NODE; + if (IS (SUB (p), LONGETY) || IS (SUB (p), SHORTETY)) + s = NEXT (SUB (p)); + else + s = SUB (p); + + type = CTYPE (moid); + int64_t radix = strtol (NSYMBOL (s), &end, 10); + gcc_assert (end != NSYMBOL (s) && *end == 'r'); + end++; + int64_t val = strtol (end, &end, radix); + gcc_assert (end[0] == '\0'); + return build_int_cst (type, val); + } + else if (moid == M_REAL + || moid == M_LONG_REAL + || moid == M_LONG_LONG_REAL) + { + /* SIZETY INT */ + tree type; + NODE_T *s = NO_NODE; + if (IS (SUB (p), LONGETY) || IS (SUB (p), SHORTETY)) + s = NEXT (SUB (p)); + else + s = SUB (p); + + if (moid == M_REAL) + type = float_type_node; + else if (moid == M_LONG_REAL) + type = double_type_node; + else if (moid == M_LONG_LONG_REAL) + type = long_double_type_node; + else + gcc_unreachable (); + + REAL_VALUE_TYPE val; + real_from_string (&val, NSYMBOL (s)); + return build_real (type, val); + } + + gcc_unreachable (); + return NULL_TREE; +} + +/* Lower SKIP. + + skip +*/ + +tree +a68_lower_skip (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_get_skip_tree (MOID (p)); +} + +/* Lower NIHIL. + + nihil : nil. + + NIL stands for a name referring to no value and which must be + distinguishable from any other name. It is of mode REF AMODE. NIL is never + subject to coercion and it may only occur where the context is strong, + i.e. where AMODE is known at compile-time. + + It lowers to a pointer to AMODE with value 0. */ + +tree +a68_lower_nihil (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + tree type = CTYPE (MOID (p)); + + gcc_assert (type == a68_void_type || POINTER_TYPE_P (type)); + if (type == a68_void_type) + return a68_lower_empty (p, ctx); + else + return build_int_cst (type, 0); +} + +/* Lower EMPTY. */ + +tree +a68_lower_empty (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED) +{ + return a68_get_empty (); +} + +/* Lower an identity relation. + + identity relation : tertiary, is symbol, tertiary; + tertiary, isnt symbol, tertiary. + + An identity relation determines whether two name values are the same. It + lowers into EQ_EXPR in case of IS and into NE_EXPR in case of ISNT. */ + +tree +a68_lower_identity_relation (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *lhs = SUB (p); + NODE_T *oper = NEXT (lhs); + NODE_T *rhs = NEXT (oper); + + /* Consolidate arguments to make sure we are comparing pointers in the + r-value context of the EQ_EXPR or NE_EXPR operation below. */ + tree op1 = a68_consolidate_ref (MOID (lhs), a68_lower_tree (lhs, ctx)); + tree op2 = a68_consolidate_ref (MOID (rhs), a68_lower_tree (rhs, ctx)); + + tree_code code; + if (IS (oper, IS_SYMBOL)) + code = EQ_EXPR; + else if (IS (oper, ISNT_SYMBOL)) + code = NE_EXPR; + else + gcc_unreachable (); + + return fold_build2_loc (a68_get_node_location (p), + code, boolean_type_node, op1, op2); +} + +/* Lower AND_FUNCTION and OR_FUNCTION. + + and function : tertiary, andf symbol, tertiary. + or function : tertiary, orf_symbol, tertiary. + + These are pseudo-operators that are used to implement short-circuits + evaluation of logical expressions. + + These pseudo-operators lower into TRUTH_ANDIF_EXPR or TRUTH_ORIF_EXPR, + respectively. */ + +tree +a68_lower_logic_function (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *lhs = SUB (p); + NODE_T *oper = NEXT (lhs); + NODE_T *rhs = NEXT (oper); + + tree op1 = a68_lower_tree (lhs, ctx); + tree op2 = a68_lower_tree (rhs, ctx); + + tree_code code; + if (IS (oper, ANDF_SYMBOL)) + code = TRUTH_ANDIF_EXPR; + else if (IS (oper, ORF_SYMBOL)) + code = TRUTH_ORIF_EXPR; + else + gcc_unreachable (); + + return fold_build2_loc (a68_get_node_location (p), + code, boolean_type_node, op1, op2); +} + +/* Lower a primary. + + primary : identifier; denotation; cast; enclosed clause; format text. + + The primary lowers into some GENERIC expression. */ + +tree +a68_lower_primary (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_lower_tree (SUB (p), ctx); +} + +/* Lower a cast. + + cast : declarer, enclosed clause; + void symbol, enclosed clause. + + A cast establishes a strong context with some required mode. This context + allows coercions to be applied, and these coercions have been inserted in + the parse tree by the parser. */ + +tree +a68_lower_cast (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_lower_tree (NEXT (SUB (p)), ctx); +} + +/* Lower a slice. + + slice : MULTIPLE INDEXER + + Slicing a multiple may result in either an element of the multiple, if the + operation is indexing, or another multiple, if the operation is a + trimming. */ + +static void +lower_subscript_for_indexes (NODE_T *p, LOW_CTX_T ctx) +{ + for (; p != NO_NODE; FORWARD (p)) + { + switch (ATTRIBUTE (p)) + { + case TRIMMER: + /* Because of ANNOTATION (indexer) == SLICE */ + gcc_unreachable (); + break; + case UNIT: + a68_add_stmt (a68_lower_tree (p, ctx)); + break; + case GENERIC_ARGUMENT: + case GENERIC_ARGUMENT_LIST: + lower_subscript_for_indexes (SUB (p), ctx); + break; + default: + break; + } + } +} + +static void +lower_subscript_for_trimmers (NODE_T *p, LOW_CTX_T ctx, + tree multiple, tree new_multiple, + int *dim, int *new_dim, + tree elements_pointer_type) +{ + /* new.elements := multiple.elements; + FOR dim TO num dimensions + DO CO t[dim] is either a subscript i or a trimmer i : j @ k CO + new.elements +:= i * multiple.strides[dim]; + IF t[dim] is a trimmer + THEN INT d := ( k is absent | 1 | multiple.lb[dim] - k ); + new.lb[dim] := multiple.lb[dim] - d; + new.ub[dim] := multiple.ub[dim] - d; + new.strides[dim] := multiple.strides[dim] + FI + OD + */ + + for (; p != NO_NODE; FORWARD (p)) + { + switch (ATTRIBUTE (p)) + { + case UNIT: + { + tree unit = save_expr (fold_convert (ssizetype, a68_lower_tree (p, ctx))); + tree new_elements = a68_multiple_elements (new_multiple); + tree size_dim = size_int (*dim); + tree dim_lower_bound = save_expr (a68_multiple_lower_bound (multiple, size_dim)); + tree stride = save_expr (a68_multiple_stride (multiple, size_dim)); + + /* Validate bounds. */ + if (OPTION_BOUNDS_CHECKING (&A68_JOB)) + a68_add_stmt (a68_multiple_bounds_check (p, size_dim, multiple, unit)); + + /* new_elements += i * strides[dim] */ + tree offset = fold_build2 (MULT_EXPR, sizetype, + fold_convert (sizetype, fold_build2 (MINUS_EXPR, ssizetype, + unit, dim_lower_bound)), + stride); + + offset = save_expr (offset); + new_elements = fold_build2 (POINTER_PLUS_EXPR, + elements_pointer_type, + new_elements, + offset); + a68_add_stmt (a68_multiple_set_elements (new_multiple, new_elements)); + + /* elements_size -= i * strides[dim] */ + tree elements_size = a68_multiple_elements_size (new_multiple); + elements_size = fold_build2 (MINUS_EXPR, sizetype, + elements_size, offset); + a68_add_stmt (a68_multiple_set_elements_size (new_multiple, elements_size)); + + *dim += 1; + break; + } + case TRIMMER: + { + /* First collect components from the trimmer. */ + tree size_dim = size_int (*dim); + tree dim_lower_bound = save_expr (a68_multiple_lower_bound (multiple, size_dim)); + tree lower_bound = dim_lower_bound; + tree upper_bound = save_expr (a68_multiple_upper_bound (multiple, size_dim)); + tree at = ssize_int (1); + + NODE_T *q = SUB (p); + if (q != NO_NODE) + { + if (IS (q, AT_SYMBOL)) + { + /* Both bounds are implicit. */ + at = save_expr (fold_convert (ssizetype, a68_lower_tree (NEXT (q), ctx))); + } + else if (IS (q, COLON_SYMBOL)) + { + /* Lower bound is implicit. */ + FORWARD (q); + if (IS (q, AT_SYMBOL)) + { + /* Upper bound is implicit, AT specified. */ + gcc_assert (IS (q, AT_SYMBOL)); + at = save_expr (fold_convert (ssizetype, a68_lower_tree (NEXT (q), ctx))); + } + else + { + upper_bound + = save_expr (fold_convert (ssizetype, a68_lower_tree (q, ctx))); + FORWARD (q); + if (q != NO_NODE) + { + gcc_assert (IS (q, AT_SYMBOL)); + at = save_expr (fold_convert (ssizetype, a68_lower_tree (NEXT (q), ctx))); + } + } + } + else + { + /* Lower bound is explicit. */ + lower_bound = fold_convert (ssizetype, a68_lower_tree (q, ctx)); + FORWARD (q); + gcc_assert (IS (q, COLON_SYMBOL)); + FORWARD (q); + if (q != NO_NODE) + { + if (IS (q, AT_SYMBOL)) + at = save_expr (fold_convert (ssizetype, a68_lower_tree (NEXT (q), ctx))); + else + { + upper_bound + = save_expr (fold_convert (ssizetype, a68_lower_tree (q, ctx))); + FORWARD (q); + if (q != NO_NODE && IS (q, AT_SYMBOL)) + at = + save_expr (fold_convert (ssizetype, a68_lower_tree (NEXT (q), ctx))); + } + } + } + } + + /* Time for some bounds checking. + + Note that in trimmers, given the current dimension's bounds + (L,U), we cannot simply do the check: + + L <= lower_bound <= U + L <= upper_bound <= U + + This is because the multiple may be flat, and the dimension may + have bounds such like U < L. In that case, the expressions + above would always eval to false for any lower_bound and + upper_bound. + + So we check for this instead: + + L <= lower_bound AND upper_bound <= U + + This allows to trim a "flat dimension" using a trimmer where + upper_bound < lower_bound. The result is, of course, another + "flat dimension" in the multiple result of the trimming. */ + + if (OPTION_BOUNDS_CHECKING (&A68_JOB)) + { + a68_add_stmt (a68_multiple_single_bound_check (p, size_dim, multiple, + lower_bound, + false /* upper_bound */)); + a68_add_stmt (a68_multiple_single_bound_check (p, size_dim, multiple, + upper_bound, + true /* upper_bound */)); + } + + /* new_elements += i * strides[dim] */ + tree stride = save_expr (a68_multiple_stride (multiple, size_dim)); + tree new_elements = a68_multiple_elements (new_multiple); + tree offset = fold_build2 (MULT_EXPR, sizetype, + fold_convert (sizetype, fold_build2 (MINUS_EXPR, ssizetype, + lower_bound, dim_lower_bound)), + stride); + + offset = save_expr (offset); + new_elements = fold_build2 (POINTER_PLUS_EXPR, + elements_pointer_type, + new_elements, + offset); + a68_add_stmt (a68_multiple_set_elements (new_multiple, new_elements)); + + /* elements_size -= i * strides[dim] */ + tree elements_size = a68_multiple_elements_size (new_multiple); + elements_size = fold_build2 (MINUS_EXPR, sizetype, + elements_size, offset); + a68_add_stmt (a68_multiple_set_elements_size (new_multiple, + elements_size)); + + /* Fill the triplet for this dimension in new_multiple. */ + tree size_new_dim = size_int (*new_dim); + tree d = fold_build2 (MINUS_EXPR, ssizetype, lower_bound, at); + + a68_add_stmt (a68_multiple_set_lower_bound (new_multiple, size_new_dim, + fold_build2 (MINUS_EXPR, ssizetype, + lower_bound, d))); + a68_add_stmt (a68_multiple_set_upper_bound (new_multiple, size_new_dim, + fold_build2 (MINUS_EXPR, ssizetype, + upper_bound, d))); + a68_add_stmt (a68_multiple_set_stride (new_multiple, size_new_dim, stride)); + + *new_dim += 1; + *dim += 1; + break; + } + default: + lower_subscript_for_trimmers (SUB (p), ctx, + multiple, new_multiple, + dim, new_dim, + elements_pointer_type); + } + } +} + +tree +a68_lower_slice (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *indexer = NEXT_SUB (p); + MOID_T *orig_multiple_mode = MOID (SUB (p)); + MOID_T *multiple_mode = orig_multiple_mode; + bool slicing_name = false; + + /* First of all, lower the multiple being sliced. If it is a name to a + multiple, set a flag and dereference. */ + tree multiple = a68_lower_tree (SUB (p), ctx); + MOID_T *orig_sliced_multiple_mode = MOID (p); + MOID_T *sliced_multiple_mode = MOID (p); + size_t slice_num_dimensions = 0; + if (IS_REF (MOID (SUB (p)))) + { + slicing_name = true; + multiple = a68_low_deref (multiple, SUB (p)); + multiple_mode = SUB (multiple_mode); + slice_num_dimensions = DIM (SUB (MOID (p))); + sliced_multiple_mode = SUB (sliced_multiple_mode); + } + else + slice_num_dimensions = DIM (MOID (p)); + + tree slice = NULL_TREE; + if (ANNOTATION (indexer) == SLICE) + { + /* The slice has only indexers and no trimmers. Collect units and slice + an element of the multiple using a68_multiple_slice. This operation + results in an element of the multiple. */ + + /* Collect units */ + a68_push_range (NULL); + lower_subscript_for_indexes (SUB (indexer), ctx); + tree units = a68_pop_range (); + + /* We need to allocate space for as many indexes as dimensions of the + multiple. */ + tree num_dimensions_tree = a68_multiple_dimensions (multiple); + gcc_assert (TREE_CODE (num_dimensions_tree) == INTEGER_CST); + int num_dimensions = tree_to_shwi (num_dimensions_tree); + + int num_indexes = 0; + tree *indexes = (tree *) xmalloc (sizeof (tree) * num_dimensions); + for (tree_stmt_iterator si = tsi_start (units); + !tsi_end_p (si); + tsi_next (&si)) + { + /* Add the unit to the list of indexes. */ + indexes[num_indexes] = tsi_stmt (si); + num_indexes++; + } + gcc_assert (num_indexes == num_dimensions); + + /* Slice. */ + slice = a68_multiple_slice (p, multiple, slicing_name, + num_indexes, indexes); + free (indexes); + } + else if (ANNOTATION (indexer) == TRIMMER) + { + /* The slice has both indexers and trimmers. Traverse the indexer + subtree to obtain the descriptor of the trimmed multiple (which is + another multiple) and the pointer to the elements, which points to + some position within the elements of the trimmed multiple. This + operation results in a new multiple of the same mode than the trimmed + multiple with shared elements. */ + + a68_push_range (sliced_multiple_mode); + + tree sliced_multiple = a68_lower_tmpvar ("multiple%", TREE_TYPE (multiple), + multiple); + tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * slice_num_dimensions); + tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * slice_num_dimensions); + tree ssize_one_node = fold_convert (ssizetype, size_one_node); + tree ssize_zero_node = fold_convert (ssizetype, size_zero_node); + for (size_t d = 0; d < slice_num_dimensions; ++d) + { + /* Note that these dummy bounds and the implied strides will be + overwritten by lower_subscript_for_trimmers below. */ + lower_bounds[d] = ssize_one_node; + upper_bounds[d] = ssize_zero_node; + } + tree new_multiple = a68_row_value (CTYPE (sliced_multiple_mode), + slice_num_dimensions, + a68_multiple_elements (sliced_multiple), + a68_multiple_elements_size (sliced_multiple), + lower_bounds, upper_bounds); + new_multiple = save_expr (new_multiple); + new_multiple = a68_lower_tmpvar ("new_multiple%", TREE_TYPE (new_multiple), + new_multiple); + + int dim = 0; + int new_dim = 0; + lower_subscript_for_trimmers (SUB (indexer), ctx, + sliced_multiple, new_multiple, + &dim, &new_dim, + a68_row_elements_pointer_type (TREE_TYPE (multiple))); + a68_add_stmt (new_multiple); + slice = a68_pop_range (); + + /* In case we are slicing a ref to a multiple, return the address of the + resulting multiple and not the multiple itself. But in this case we + need an address in the heap, because the trimmed multiple may be in + the heap and the result shall have the same scope. */ + if (slicing_name) + { + tree ptrtype = CTYPE (orig_sliced_multiple_mode); + tree slice_addr = fold_build1 (ADDR_EXPR, ptrtype, slice); + tree alloc = a68_lower_malloc (ptrtype, size_in_bytes (TREE_TYPE (slice))); + alloc = save_expr (alloc); + tree copy = a68_lower_memcpy (alloc, slice_addr, size_in_bytes (TREE_TYPE (slice))); + + slice = fold_build2 (COMPOUND_EXPR, ptrtype, copy, alloc); + } + } + else + gcc_unreachable (); + + return slice; +} + +/* Lower a selection. + + selection : selector, secondary. + selector : field identifier, of symbol. + + The selection lowers into a COMPONENT_REF of the field corresponding to the + field identifier. */ + +tree +a68_lower_selection (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *secondary = NEXT (SUB (p)); + NODE_T *field_identifier = SUB (SUB (p)); + + MOID_T *secondary_mode = MOID (secondary); + tree secondary_expr = a68_lower_tree (secondary, ctx); + + tree res = NULL_TREE; + + /* If the secondary is an address, we need to indirect. */ + if (IS_REF (secondary_mode)) + { + secondary_expr = a68_low_deref (secondary_expr, secondary); + secondary_mode = SUB (secondary_mode); + } + + if (IS_FLEX (secondary_mode) || IS_ROW (secondary_mode)) + { + /* This is the selection of a multiple of structs. + + The result is a multiple with same dimensions, dimension bounds and + strides than the indexed multiple. The elements pointer is made to + point to the selected field of the first struct. */ + + MOID_T *result_mode = MOID (p); + if (IS_REF (result_mode)) + result_mode = SUB (result_mode); + MOID_T *struct_mode = SUB (secondary_mode); + tree field_id = a68_get_mangled_identifier (SYMBOL (INFO (field_identifier))); + tree struct_type = CTYPE (struct_mode); + a68_push_range (result_mode); + tree selection = a68_lower_tmpvar ("selection%", CTYPE (result_mode), + a68_get_skip_tree (result_mode)); + tree multiple = a68_lower_tmpvar ("multiple%", TREE_TYPE (secondary_expr), + secondary_expr); + + /* First set the bounds of the selection, which are exactly the same + bounds than the selected multiple. */ + for (int dim = 0; dim < DIM (DEFLEX (secondary_mode)); ++dim) + { + tree size_dim = size_int (dim); + tree lower_bound = a68_multiple_lower_bound (multiple, size_dim); + tree upper_bound = a68_multiple_upper_bound (multiple, size_dim); + tree stride = a68_multiple_stride (multiple, size_dim); + a68_add_stmt (a68_multiple_set_lower_bound (selection, size_dim, + lower_bound)); + a68_add_stmt (a68_multiple_set_upper_bound (selection, size_dim, + upper_bound)); + a68_add_stmt (a68_multiple_set_stride (selection, size_dim, + stride)); + } + + /* Now set the elements pointer, which is the elements pointer of the + selected multiple offset the offset of the selected field in its + struct type. */ + tree elements = a68_multiple_elements (selection); + tree multiple_elements = a68_multiple_elements (multiple); + tree multiple_elements_size = a68_multiple_elements_size (multiple); + tree element_pointer_type = TREE_TYPE (elements); + tree field_offset = NULL_TREE; + for (tree f = TYPE_FIELDS (struct_type); f; f = DECL_CHAIN (f)) + { + if (field_id == DECL_NAME (f)) + { + field_offset = byte_position (f); + break; + } + } + gcc_assert (field_offset != NULL_TREE); + a68_add_stmt (a68_multiple_set_elements (selection, + fold_build2 (POINTER_PLUS_EXPR, + element_pointer_type, + multiple_elements, + field_offset))); + + /* The size of the buffer pointed by the elements pointer has to be + adjusted accordingly. */ + a68_add_stmt (a68_multiple_set_elements_size (selection, + fold_build2 (MINUS_EXPR, sizetype, + multiple_elements_size, + field_offset))); + + a68_add_stmt (selection); + res = a68_pop_range (); + } + else + { + /* This is the selection of a struct field. */ + gcc_assert (A68_STRUCT_TYPE_P (TREE_TYPE (secondary_expr))); + + /* Search for the selected field in the struct type. */ + tree struct_type = TREE_TYPE (secondary_expr); + tree field_id = a68_get_mangled_identifier (SYMBOL (INFO (field_identifier))); + tree field = NULL_TREE; + for (tree f = TYPE_FIELDS (struct_type); f; f = DECL_CHAIN (f)) + { + if (field_id == DECL_NAME (f)) + { + field = f; + break; + } + } + gcc_assert (field != NULL_TREE); + + /* Emit the COMPONENT_REF. */ + res = fold_build3_loc (a68_get_node_location (p), + COMPONENT_REF, + TREE_TYPE (field), + secondary_expr, + field, + NULL_TREE); + } + + /* The selection of a name yields a name. */ + if (IS_REF (MOID (secondary))) + /* XXX This may require copying. */ + return fold_build1 (ADDR_EXPR, CTYPE (MOID (p)), res); + else + return res; +} + +/* Lower a secondary. + + secondary : primary; generator; selection. + + The secondary lowers into some GENERIC expression. */ + +tree +a68_lower_secondary (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_lower_tree (SUB (p), ctx); +} + +/* Lower a formula. + + formula : secondary, operator, secondary; + secondary, operator, monadic formula; + secondary, operator, formula; + monadic formula; + monadic formula, operator, secondary; + monadic formula, operator, monadic formula; + monadic formula, operator, formula; + formula, operator, secondary; + formula, operator, monadic formula; + formula, operator, formula. + + The formula lowers into some GENERIC expression. */ + +tree +a68_lower_formula (NODE_T *p, LOW_CTX_T ctx) +{ + if (IS (SUB (p), MONADIC_FORMULA) && NEXT (SUB (p)) == NO_NODE) + return a68_lower_tree (SUB (p), ctx); + else + { + /* If the operator is defined in the standard prelude, then use its lowering + code. */ + if (TAG_TABLE (TAX (NEXT (SUB (p)))) == A68_STANDENV) + { + LOWERER_T lowerer = LOWERER (TAX (NEXT (SUB (p)))); + return (*lowerer) (p, ctx); + } + else + { + tree arg1 = a68_lower_tree (SUB (p), ctx); + tree op = a68_lower_tree (NEXT (SUB (p)), ctx); + tree arg2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx); + + if (POINTER_TYPE_P (TREE_TYPE (op))) + op = fold_build1 (INDIRECT_REF, + TREE_TYPE (TREE_TYPE (op)), + op); + return build_call_expr_loc (a68_get_node_location (p), op, 2, arg1, arg2); + } + } +} + +/* Lower a monadic formula. + + monadic formula : operator, secondary; + operator, monadic formula. + + The monadic formula lowers into some GENERIC expression. */ + +tree +a68_lower_monadic_formula (NODE_T *p, LOW_CTX_T ctx) +{ + /* If the operator is defined in the standard prelude, then use its lowering + code. */ + if (TAG_TABLE (TAX (SUB (p))) == A68_STANDENV) + { + LOWERER_T lowerer = LOWERER (TAX (SUB (p))); + return (*lowerer) (p, ctx); + } + else + { + tree op = a68_lower_tree (SUB (p), ctx); + tree secondary = a68_lower_tree (NEXT (SUB (p)), ctx); + + if (POINTER_TYPE_P (TREE_TYPE (op))) + op = fold_build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (op)), op); + return build_call_expr_loc (a68_get_node_location (p), op, 1, secondary); + } +} + +/* Lower a tertiary. + + tertiary : nihil; monadic formula; formula; secondary. + + The tertiary lowers to some GENERIC expression. */ + +tree +a68_lower_tertiary (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_lower_tree (SUB (p), ctx); +} + +/* Lower an assignation. + + assignation : tertiary, assign symbol, tertiary; + tertiary, assign symbol, identity relation; + tertiary, assign symbol, and function; + tertiary, assign symbol, or function; + tertiary, assign symbol, routine text; + tertiary, assign symbol, jump; + tertiary, assign symbol, skip; + tertiary, assign symbol, assignation; + tertiary, assign symbol, code clause. + + An assignation lowers into appending a MODIFY_EXPR to the statements list, + and the result of the expression is the left hand side. A compound + expression fits perfectly */ + +tree +a68_lower_assignation (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *lhs_node = SUB (p); + NODE_T *rhs_node = NEXT (NEXT (SUB (p))); + tree lhs = a68_lower_tree (lhs_node, ctx); + tree rhs = a68_lower_tree (rhs_node, ctx); + + return a68_low_assignation (p, + lhs, MOID (lhs_node), + rhs, MOID (rhs_node)); +} + +/* Lower a generator. + + generator : loc symbol, declarer; + heap symbol, declarer; + new symbol, declarer. + + LOC generators lower into calls to BUILT_IN_ALLOCA. + HEAP generators lower into calls to malloc. */ + +tree +a68_lower_generator (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *declarer = NEXT (SUB (p)); + return a68_low_generator (declarer, + MOID (declarer), + !IS (SUB (p), LOC_SYMBOL), + ctx); +} + +/* Lower a procedure call. + + */ + +static void +collect_call_arguments (NODE_T *p, vec *args, LOW_CTX_T ctx) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + { + /* In Algol 68 parameters are passed via an identity declaration, so + this must implement same semantics. */ + tree arg = a68_lower_tree (p, ctx); + if (HAS_ROWS (MOID (p))) + arg = a68_low_dup (arg); + arg = a68_consolidate_ref (MOID (p), arg); + args->quick_push (arg); + } + else + collect_call_arguments (SUB (p), args, ctx); + } +} + +tree +a68_lower_call (NODE_T *p, LOW_CTX_T ctx) +{ + MOID_T *proc_mode = MOID (SUB (p)); + MOID_T *ret_mode = SUB (proc_mode); + unsigned int nargs = DIM (proc_mode); + + /* Collect arguments. */ + vec *args; + vec_alloc (args, nargs); + collect_call_arguments (NEXT (SUB (p)), args, ctx); + + /* Lower the primary to call. */ + tree primary = a68_lower_tree (SUB (p), ctx); + + /* We need a pointer to a function type. */ + if (!POINTER_TYPE_P (TREE_TYPE (primary))) + primary = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (primary)), + primary); + + /* Build a function call. */ + tree call = build_call_vec (CTYPE (ret_mode), primary, args); + SET_EXPR_LOCATION (call, a68_get_node_location (p)); + return call; +} + +/* Lower a routine text. + + routine text : parameter pack, (declarer ; void symbol), colon symbol, assignation; + parameter pack, (declarer ; void symbol), colon symbol, identity relation; + parameter pack, (declarer ; void symbol), colon symbol, and function; + parameter pack, (declarer ; void symbol), colon symbol, or runction; + parameter pack, (declarer ; void symbol), colon symbol, jump; + parameter pack, (declarer ; void symbol), colon symbol, skip; + parameter pack, (declarer ; void symbol), colon symbol, tertiary; + parameter pack, (declarer ; void symbol), colon symbol, routine text; + parameter pack, (declarer ; void symboL), colon symbol, code clause; + (declarer ; void symbol), colon symbol, assignation; + (declarer ; void symbol), colon symbol, identity relation; + (declarer ; void symbol), colon symbol, and function; + (declarer ; void symbol), colon symbol, or runction; + (declarer ; void symbol), colon symbol, jump; + (declarer ; void symbol), colon symbol, skip; + (declarer ; void symbol), colon symbol, tertiary; + (declarer ; void symbol), colon symbol, routine text; + (declarer ; void symbol), colon symbol, code clause. + + Routine texts are used to create routines. They can stand as the actual + parameter of an identity declaration, as the actual parameter of a call, or + as the right-hand side of an assignation. + + This lowering function is called in two different contexts: + + 1) As part of a routine-identity-declaration, in which case the routine + resulting from this routine-text is beign ascribed to an identifier given + in ctx.proc_decl_identifier. In that case, we lower to a FUNC_DECL + initialized with the body of the routine-text. + + 2) As a free standing routine-text. In that case ctx.proc_decl_identifier is + NO_NODE. We lower to the address of a FUNC_DECL that features some unique + name. This pointer will then likely be assigned or ascribed to some + variable or identifier in non-contracted identity declaration, but we + cannot assume that so we have to opt for the indirection. */ + +tree +a68_lower_routine_text (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *s = SUB (p); + + tree func_decl = NULL_TREE; + NODE_T *defining_identifier = ctx.proc_decl_identifier; + bool defining_operator = ctx.proc_decl_operator; + if (defining_identifier != NO_NODE) + { + /* The routine-text is part of a routine-identity-declaration. */ + func_decl = TAX_TREE_DECL (TAX (defining_identifier)); + if (func_decl == NULL_TREE) + { + func_decl + = a68_make_proc_identity_declaration_decl (defining_identifier, + ctx.module_definition_name, + defining_operator /* indicant */); + TAX_TREE_DECL (TAX (defining_identifier)) = func_decl; + } + + /* If the routine-identity-declaration is in a public range then add the + declaration to the publicized declarations list. Otherwise chain the + declaration in the proper block and bind it. */ + if (PUBLIC_RANGE (TABLE (TAX (defining_identifier)))) + vec_safe_push (A68_MODULE_DEFINITION_DECLS, func_decl); + else + a68_add_decl (func_decl); + } + else + { + /* The routine-text is free standing. */ + func_decl = a68_make_anonymous_routine_decl (MOID (p)); + a68_add_decl (func_decl); + } + + a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p), + DECL_EXPR, + TREE_TYPE (func_decl), + func_decl)); + announce_function (func_decl); + + /* PARAMETER_PACK. */ + NODE_T *parameter_pack_node = NO_NODE; + tree parameter_pack = NULL_TREE; /* This is computed below. */ + if (IS (s, PARAMETER_PACK)) + { + parameter_pack_node = s; + FORWARD (s); + } + + /* DECLARER or VOID_SYMBOL */ + if (IS (s, DECLARER) || IS (s, VOID_SYMBOL)) + /* This is not used, as this formal declarer is also available in the + procedure mode. So just skip it. */ + FORWARD (s); + + /* Skip the COLON_SYMBOL. */ + gcc_assert (IS (s, COLON_SYMBOL)); + FORWARD (s); + + /* Lower the function body. + + This should be done in a new range in which the formal parameters of the + routine-text have been declared. */ + a68_push_function_range (func_decl, CTYPE (SUB (MOID (p))) /* result_type */); + if (parameter_pack_node != NO_NODE) + parameter_pack = a68_lower_tree (parameter_pack_node, ctx); + DECL_ARGUMENTS (func_decl) = parameter_pack; + ctx.proc_decl_identifier = NO_NODE; + tree func_body = a68_lower_tree (s, ctx); + a68_pop_function_range (func_body); + + if (defining_identifier != NO_NODE) + /* Routine-text immediately ascribed to some identifier in a + proc-identity-declaration. Return the FUNC_DECL. */ + return func_decl; + else + /* Free standing routine-text. Return its address. */ + return fold_build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (func_decl)), + func_decl); +} + +/* Lower an unit. + + unit : assignation; identity relation; + and function; or function; routine text; + jump; skip; tertiary; assertion; code clause. + + The unit lowers to an expression. */ + +tree +a68_lower_unit (NODE_T *p, LOW_CTX_T ctx) +{ + return a68_lower_tree (SUB (p), ctx); +} diff --git a/gcc/algol68/a68-low.cc b/gcc/algol68/a68-low.cc new file mode 100644 index 000000000000..109620248fb1 --- /dev/null +++ b/gcc/algol68/a68-low.cc @@ -0,0 +1,1705 @@ +/* Lower the Algol 68 parse tree to GENERIC. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "diagnostic.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" + +#include "a68.h" + +/* Return a tree with an identifier for the mangled version of a given + name. + + Publicized symbols feature the module name publishing them. + Internal symbols don't. + + Bold words, i.e. mode indicants, module indicants and operator indicants, + are mangled to upper-case. + + Tags, i.e. identifiers are mangled to lower-case. + + Monads and nomads are mangled to letter codes symbolizing the symbols: + + % (p)ercentage + ^ (c)aret + & (a)mpersand + + pl(u)s + - (m)inus + ~ (t)ilde + ! (b)ang + ? (q)uestion mark + > bi(g)ger than + < (l)ess than + / (s)lash + = (e)qual + : c(o)lon + * sta(r) + + Each letter code is followed by a single underscore character. */ + +static tree +get_mangled_identifier_or_indicant (const char *name, bool indicant, + const char *mname, bool internal, + bool numbered) +{ + /* First determine the size of the mangled symbol. */ + size_t mangled_size = strlen (name) + 1; + if (mname) + { + /* Add size for MNAME_ */ + mangled_size += strlen (mname) + 1; + if (internal) + /* Another _ */ + mangled_size += 1; + } + for (const char *p = name; *p; ++p) + { + mangled_size += 1; + if (strchr (MONADS, *p) != NULL + || strchr (NOMADS, *p) != NULL + || *p == ':') + /* Each monad or nomad requires two chars to encode. */ + mangled_size += 1; + } + + char *number_buf = NULL; + if (numbered) + { + static unsigned int cnt; + number_buf = xasprintf ("%d", cnt++); + mangled_size += strlen (number_buf); + } + + /* Now fill-in the mangled symbol. */ + char *mangled_name = (char *) alloca (mangled_size); + size_t pos = 0; + if (mname) + { + for (const char *p = mname; *p; ++p) + /* Module names are bold words. Make sure to emit them in upper-case. */ + mangled_name[pos++] = TOUPPER (*p); + mangled_name[pos++] = '_'; + if (internal) + mangled_name[pos++] = '_'; + } + + for (const char *p = name; *p; ++p) + { + if (strchr (MONADS, *p) != NULL + || strchr (NOMADS, *p) != NULL + || *p == ':') + { + char c; + switch (*p) + { + case '%': c = 'p'; break; + case '^': c = 'c'; break; + case '&': c = 'a'; break; + case '+': c = 'u'; break; + case '-': c = 'm'; break; + case '~': c = 't'; break; + case '!': c = 'b'; break; + case '?': c = 'q'; break; + case '>': c = 'g'; break; + case '<': c = 'l'; break; + case '/': c = 's'; break; + case '=': c = 'e'; break; + case ':': c = 'o'; break; + case '*': c = 'r'; break; + default: + /* Should not happen. */ + gcc_unreachable (); + } + mangled_name[pos++] = c; + mangled_name[pos++] = '_'; + } + else + { + if (indicant) + mangled_name[pos++] = TOUPPER (*p); + else + mangled_name[pos++] = TOLOWER (*p); + } + } + + if (numbered) + { + for (char *p = number_buf; *p; ++p) + mangled_name[pos++] = *p; + free (number_buf); + } + mangled_name[pos++] = '\0'; + + return get_identifier (mangled_name); +} + +tree +a68_get_mangled_identifier (const char *name, const char *mname, + bool internal, bool numbered) +{ + return get_mangled_identifier_or_indicant (name, false /* indicant */, mname, + internal, numbered); +} + +tree +a68_get_mangled_indicant (const char *name, const char *mname, + bool internal, bool numbered) +{ + return get_mangled_identifier_or_indicant (name, true /* indicant */, mname, + internal, numbered); +} + +/* Demangle a given SYMBOL. + + This function does the reverse operation than + get_mangled_identifier_or_indicant. */ + +char * +a68_demangle_symbol (const char *mname, const char *symbol, + bool is_operator) +{ + gcc_assert (strlen (symbol) >= strlen (mname) + 1); + /* First get rid of the module name and underscore. */ + symbol += strlen (mname) + 1; + /* Now demangle the rest. */ + size_t size = strlen (symbol) + 1; + char *demangled = (char *) xmalloc (size + 1); + size_t o = 0; + for (size_t i = 0; i < size; ++i) + { + if (symbol[i+1] == '_') + { + switch (symbol[i]) + { + case 'p': demangled[o++] = '+'; break; + case 'c': demangled[o++] = '^'; break; + case 'a': demangled[o++] = '&'; break; + case 'u': demangled[o++] = '+'; break; + case 'm': demangled[o++] = '-'; break; + case 't': demangled[o++] = '~'; break; + case 'b': demangled[o++] = '!'; break; + case 'q': demangled[o++] = '?'; break; + case 'g': demangled[o++] = '>'; break; + case 'l': demangled[o++] = '<'; break; + case 's': demangled[o++] = '/'; break; + case 'e': demangled[o++] = '='; break; + case 'o': demangled[o++] = ':'; break; + case 'r': demangled[o++] = '*'; break; + default: + /* Invalid mangling. */ + // XXX this should be checked at import time in extract. + gcc_unreachable (); + } + i += 1; + } + else + demangled[o++] = symbol[i]; + } + demangled[o] = '\0'; + + if (is_operator) + { + /* Remove trailing digits. */ + for (size_t i = strlen (demangled) - 1; i > 0; --i) + { + if (ISDIGIT (demangled[i])) + demangled[i] = '\0'; + else + break; + } + } + + return demangled; +} + +/* Return a tree with the EMPTY value. + + EMPTY is the only denotation of the VOID mode. It is used in unions to + denote "no value". It must have size zero, so it lowers into an empty + constructor with zero elements of type void. This is what GNU C uses to + implement the empty struct extension. */ + +tree +a68_get_empty (void) +{ + return build_constructor (a68_void_type, NULL); +} + +/* Return a tree with the yielding of SKIP of a given mode. + + SKIP stands for some value of some given mode. It shall be used only in a + context where the compiler can determine the mode. + + The particular value to which it elaborates is non-important, but this + compiler always uses the same values. See the a68_get_ref_*_tree functions + for details on what values are these. */ + +tree +a68_get_skip_tree (MOID_T *m) +{ + tree expr = NULL_TREE; + + while (EQUIVALENT (m) != NO_MOID) + m = EQUIVALENT (m); + + if (IS_INTEGRAL (m)) + expr = a68_get_int_skip_tree (m); + else if (m == M_CHAR) + expr = a68_get_char_skip_tree (); + else if (m == M_BOOL) + expr = a68_get_bool_skip_tree (); + else if (IS_REAL (m)) + expr = a68_get_real_skip_tree (m); + else if (IS_BITS (m)) + expr = a68_get_bits_skip_tree (m); + else if (IS_REF (m)) + expr = a68_get_ref_skip_tree (m); + else if (IS (m, PROC_SYMBOL)) + expr = a68_get_proc_skip_tree (m); + else if (IS_STRUCT (m)) + expr = a68_get_struct_skip_tree (m); + else if (IS_UNION (m)) + expr = a68_get_union_skip_tree (m); + else if (IS_FLEXETY_ROW (m)) + expr = a68_get_multiple_skip_tree (m); + else if (m == M_STRING) + expr = a68_get_string_skip_tree (); + else if (m == M_ROWS || IS (m, SERIES_MODE)) + { + /* XXX assert that all modes in the series are rows? */ + tree rows_type = CTYPE (M_ROWS); + tree dim_field = TYPE_FIELDS (rows_type); + tree triplets_field = TREE_CHAIN (dim_field); + tree null_pointer = build_int_cst (TREE_TYPE (triplets_field), 0); + expr = build_constructor_va (rows_type, 2, + dim_field, size_zero_node, + triplets_field, null_pointer); + } + else if (m == M_VOID || m == M_HIP) + expr = a68_get_empty (); + else + { + fatal_error (UNKNOWN_LOCATION, + "get skip tree: cannot compute SKIP for mode %s", + a68_moid_to_string (m, MOID_ERROR_WIDTH, NODE (m), true)); + gcc_unreachable (); + } + + return expr; +} + +/* Given a tree node EXP holding a value of mode M: + + *NUM_REFS is set to the number of REFs in M. + + *NUM_POINTERS is set to the number of pointers in the type of EXP that + correspond to the REFs in M. */ + +void +a68_ref_counts (tree exp, MOID_T *m, int *num_refs, int *num_pointers) +{ + /* Count REFs in M and pointers in the type of EXP. Note that VAR_DECLs + corresponding to REF PROC are of type pointer, so these should not count + for the count! */ + + /* Make sure we are accessing the real mode definition. */ + while (EQUIVALENT (m) != NO_MOID) + m = EQUIVALENT (m); + + *num_refs = 0; + *num_pointers = 0; + for (MOID_T *s = m; s != NO_MOID && IS_REF (s); s = SUB (s)) + *num_refs += 1; + for (tree p = TREE_TYPE (exp); + p != NULL_TREE && POINTER_TYPE_P (p) && TREE_CODE (TREE_TYPE (p)) != FUNCTION_TYPE; + p = TREE_TYPE (p)) + *num_pointers += 1; + + gcc_assert (*num_refs >= *num_pointers); +} + +/* The Algol 68 variable declaration + + [LOC|HEAP] AMODE foo; + + Is in principle equivalent to the identity declaration + + REF AMODE foo = [LOC|HEAP] AMODE; + + In both cases the object ascribed to the defining identifier `foo' is of + mode REF AMODE. The ascribed object is a name which is created by a + generator implied in the actual declarer in the first case, and an explicit + generator in the initialization expression in the second case. + + However, this front-end implements these two cases differently in order to + reduce the amount of both indirect addressing and of storage: + + - The variable declaration `[LOC|HEAP] AMODE foo;' lowers into a VAR_DECL + with type ATYPE provided that the generator is LOC and that it contains no + rows. Accessing it requires direct addressing. When its address is + required, an ADDR_EXPR shall be used. + + - The identity declaration `REF AMODE foo = LOC AMODE;' lowers into a + VAR_DECL with type *ATYPE. Accessing it requires indirect addressing. It + is effectively a pointer. + + This introduces the complication that an expression (the VAR_DECL) whose + type is TYPE can appear in a place where *TYPE is expected. This function, + given the required mode and an expression, adds as many ADDR_EXPR to EXPR as + necessary so the resulting value is of the required type. Other than this + nuisance, the parser guarantees that the entities have the right type at the + location they appear, so a call to a68_consolidate_ref is all must be needed + at any point in the lowering process to guarantee a valid value for the + context. + + This function expects: + - That the type of EXPR is zero or more pointers to a base type BTYPE. + - That the mode M is zero or more REFs to a base non-ref mode AMODE. + - That the number of pointers in the type of EXPR is less or equal than the + number of REFs in the mode M. + - That BTYPE and AMODE are equivalent. */ + +tree +a68_consolidate_ref (MOID_T *m, tree expr) +{ + int num_refs, num_pointers; + a68_ref_counts (expr, m, &num_refs, &num_pointers); + + /* Address EXPR as many times as necessary to match the number of REFs in the + desired mode. */ + while (num_pointers < num_refs) + { + if (TREE_CODE (expr) == COMPOUND_EXPR) + { + /* (..., x) -> (..., &x) */ + // gcc_assert (TREE_CODE (TREE_OPERAND (expr, 0)) == MODIFY_EXPR); + // gcc_assert (VAR_P (TREE_OPERAND (expr, 1))); + TREE_OPERAND (expr, 1) = a68_consolidate_ref (m, TREE_OPERAND (expr, 1)); + TREE_TYPE (expr) = TREE_TYPE (TREE_OPERAND (expr, 1)); + } + else + { + /* x -> &x */ + if (TREE_CODE (expr) == INDIRECT_REF) + /* expr is an indirection. Remove the pointer rather than adding + an addr. This avoids &* situations and marking stuff as + addressable unnecessarily. */ + expr = TREE_OPERAND (expr,0); + else + { + TREE_ADDRESSABLE (expr) = true; + expr = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (expr)), expr); + } + } + num_pointers += 1; + } + + return expr; +} + +/* Make a declaration for an anonymous routine of mode MODE. */ + +tree +a68_make_anonymous_routine_decl (MOID_T *mode) +{ + /* The CTYPE of MODE is a pointer to a function. We need the pointed + function type for the FUNCTION_DECL. */ + tree func_type = TREE_TYPE (CTYPE (mode)); + tree func_decl = build_decl (UNKNOWN_LOCATION, + FUNCTION_DECL, + NULL_TREE /* name, set below. */, + func_type); + char *name = xasprintf ("routine%d", DECL_UID (func_decl)); + DECL_NAME (func_decl) = a68_get_mangled_identifier (name); + free (name); + DECL_EXTERNAL (func_decl) = 0; + DECL_STATIC_CHAIN (func_decl) = !a68_in_global_range (); + /* Nested functions should be addressable. + XXX this should be propagated to their containing functions, so for now + we mark them all as addressable. */ + TREE_ADDRESSABLE (func_decl) = 1; + /* A nested function is not global. */ + TREE_PUBLIC (func_decl) = a68_in_global_range (); + TREE_STATIC (func_decl) = 1; + + return func_decl; +} + +/* Make a declaration for a constant procedure or operator. */ + +tree +a68_make_proc_identity_declaration_decl (NODE_T *identifier, + const char *module_name, + bool indicant, bool external, + const char *extern_symbol) +{ + /* The CTYPE of MODE is a pointer to a function. We need the pointed + function type for the FUNCTION_DECL. */ + tree func_type = TREE_TYPE (CTYPE (MOID (identifier))); + bool public_range = PUBLIC_RANGE (TABLE (TAX (identifier))); + tree func_decl = build_decl (UNKNOWN_LOCATION, + FUNCTION_DECL, + NULL_TREE, /* name, set below. */ + func_type); + + if (public_range) + { + bool publicized = PUBLICIZED (TAX (identifier)); + + DECL_EXTERNAL (func_decl) = 0; + if (publicized) + TREE_PUBLIC (func_decl) = 1; + else + TREE_PUBLIC (func_decl) = 0; + if (indicant) + DECL_NAME (func_decl) + = a68_get_mangled_indicant (NSYMBOL (identifier), module_name, + false /* internal */, + (IS (identifier, DEFINING_OPERATOR) + || IS (identifier, OPERATOR))); + else + DECL_NAME (func_decl) + = a68_get_mangled_identifier (NSYMBOL (identifier), module_name, + false /* internal */, + (IS (identifier, DEFINING_OPERATOR) + || IS (identifier, OPERATOR))); + } + else if (external) + { + DECL_EXTERNAL (func_decl) = 1; + TREE_PUBLIC (func_decl) = 1; + DECL_NAME (func_decl) = get_identifier (extern_symbol); + } + else + { + DECL_EXTERNAL (func_decl) = 0; + DECL_STATIC_CHAIN (func_decl) = !a68_in_global_range (); + /* Nested functions should be addressable. + XXX this should be propagated to their containing functions, so for now + we mark them all as addressable. */ + TREE_ADDRESSABLE (func_decl) = 1; + /* A nested function is not global. */ + TREE_PUBLIC (func_decl) = a68_in_global_range (); + if (indicant) + DECL_NAME (func_decl) = a68_get_mangled_indicant (NSYMBOL (identifier)); + else + DECL_NAME (func_decl) = a68_get_mangled_identifier (NSYMBOL (identifier)); + } + TREE_STATIC (func_decl) = 1; + + return func_decl; +} + +/* Make a declaration for an identity declaration. */ + +tree +a68_make_identity_declaration_decl (NODE_T *identifier, + const char *module_name, + bool indicant, bool external, + const char *extern_symbol) +{ + tree type = CTYPE (MOID (identifier)); + bool public_range = PUBLIC_RANGE (TABLE (TAX (identifier))); + tree decl = build_decl (a68_get_node_location (identifier), + VAR_DECL, + NULL_TREE, /* name, set below. */ + type); + + if (public_range) + { + bool publicized = PUBLICIZED (TAX (identifier)); + + DECL_EXTERNAL (decl) = 0; + TREE_STATIC (decl) = 1; + if (publicized) + TREE_PUBLIC (decl) = 1; + else + TREE_PUBLIC (decl) = 0; + if (indicant) + DECL_NAME (decl) = a68_get_mangled_indicant (NSYMBOL (identifier), module_name, + false /* internal */, + (IS (identifier, DEFINING_OPERATOR) + || IS (identifier, OPERATOR))); + else + DECL_NAME (decl) = a68_get_mangled_identifier (NSYMBOL (identifier), module_name, + false /* internal */, + (IS (identifier, DEFINING_OPERATOR) + || IS (identifier, OPERATOR))); + } + else if (external) + { + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + DECL_NAME (decl) = get_identifier (extern_symbol); + } + else + { + DECL_EXTERNAL (decl) = 0; + TREE_PUBLIC (decl) = 0; + DECL_NAME (decl) = a68_get_mangled_identifier (NSYMBOL (identifier)); + } + + DECL_INITIAL (decl) = a68_get_skip_tree (MOID (identifier)); + return decl; +} + +/* Make a declaration for a variable declaration. + The mode of the given identifier is expected to be a REF AMODE. */ + +tree +a68_make_variable_declaration_decl (NODE_T *identifier, + const char *module_name, + bool external, + const char *extern_symbol) +{ + gcc_assert (IS_REF (MOID (identifier))); + + MOID_T *mode = MOID (identifier); + bool use_pointer = (HEAP (TAX (identifier)) != STATIC_SYMBOL + && ((HEAP (TAX (identifier)) == HEAP_SYMBOL) + || HAS_ROWS (SUB (MOID (identifier))))); + bool public_range = PUBLIC_RANGE (TABLE (TAX (identifier))); + tree type = use_pointer ? CTYPE (mode) : CTYPE (SUB (mode)); + tree decl = build_decl (a68_get_node_location (identifier), + VAR_DECL, + NULL_TREE, /* name, set below. */ + type); + + if (public_range) + { + bool publicized = PUBLICIZED (TAX (identifier)); + + DECL_EXTERNAL (decl) = 0; + TREE_STATIC (decl) = 1; + if (publicized) + TREE_PUBLIC (decl) = 1; + else + TREE_PUBLIC (decl) = 0; + DECL_NAME (decl) = a68_get_mangled_identifier (NSYMBOL (identifier), module_name, + false /* internal */, + (IS (identifier, DEFINING_OPERATOR) + || IS (identifier, OPERATOR))); + } + else if (external) + { + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + DECL_NAME (decl) = get_identifier (extern_symbol); + } + else + { + TREE_PUBLIC (decl) = 0; + DECL_NAME (decl) = a68_get_mangled_identifier (NSYMBOL (identifier)); + } + + DECL_INITIAL (decl) = a68_get_skip_tree (use_pointer ? mode : SUB (mode)); + return decl; +} + +/* Do a checked indirection. + + P is a tree node used for its location information. + EXP is an expression that gets indirected. + EXP_MODE is the mode of exp. */ + +tree +a68_checked_indirect_ref (NODE_T *p, tree exp, MOID_T *exp_mode) +{ + tree exp_type = TREE_TYPE (exp); + tree nil_check = NULL_TREE; + + if (OPTION_NIL_CHECKING (&A68_JOB)) + { + exp = save_expr (exp); + tree consolidated_exp = a68_consolidate_ref (exp_mode, exp); + + /* Check whether we are dereferencing NIL. */ + unsigned int lineno = NUMBER (LINE (INFO (p))); + const char *filename_str = FILENAME (LINE (INFO (p))); + tree filename = build_string_literal (strlen (filename_str) + 1, + filename_str); + tree call = a68_build_libcall (A68_LIBCALL_DEREFNIL, + void_type_node, 2, + filename, + build_int_cst (unsigned_type_node, lineno)); + call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node); + nil_check = fold_build2 (NE_EXPR, exp_type, + consolidated_exp, + build_int_cst (exp_type, 0)); + nil_check = fold_build2 (TRUTH_ORIF_EXPR, exp_type, + nil_check, call); + } + + tree deref = fold_build1 (INDIRECT_REF, TREE_TYPE (exp_type), exp); + if (nil_check == NULL_TREE) + return deref; + else + return fold_build2 (COMPOUND_EXPR, TREE_TYPE (deref), + nil_check, deref); +} + +/* Deref a given expression EXP whose mode is MOID (P). + + The value to dereference always corresponds to a name, but it may consist + of: + + - Not a pointer, in which case corresponds to a name lowered to a VAR_DECL. + + - A pointer to a function, in which case corresponds to a name of mode REF + PROC, lowered to a VAR_DECL. + + - Any other pointer corresponds to a name lowered to a VAR_DECL that is a + pointer. + + In the first two cases, in both r-value and l-value situations the expected + result is achieved by just returning the value: in r-value the decl denotes + the value, in l-value the decl denotes the (direct) address of the + value. */ + +tree +a68_low_deref (tree exp, NODE_T *p) +{ + int num_refs, num_pointers; + a68_ref_counts (exp, MOID (p), &num_refs, &num_pointers); + + if (num_refs > num_pointers) + return exp; + else + { + gcc_assert (num_refs == num_pointers); + return a68_checked_indirect_ref (p, exp, MOID (p)); + } +} + +/* Get a deep-copy of a given Algol 68 value EXP. */ + +tree +a68_low_dup (tree expr, bool use_heap) +{ + tree dup = NULL_TREE; + tree type = TREE_TYPE (expr); + + /* XXX */ + use_heap = true; + + /* Determine the mode corresponding to the type of EXPR. */ + MOID_T *m = a68_type_moid (type); + gcc_assert (m != NO_MOID); + while (EQUIVALENT (m) != NO_MOID) + m = EQUIVALENT (m); + + if (A68_ROW_TYPE_P (type)) + { + /* We need to copy the elements as well as the descriptor. There is no + need to check bounds. */ + + /* Deflexe the mode as appropriate. */ + while (IS_FLEX (m)) + m = SUB (m); + gcc_assert (IS_ROW (m) || m == M_STRING); + + a68_push_range (NULL); + + /* First allocate space for the dupped elements. */ + expr = save_expr (expr); + tree elements = a68_multiple_elements (expr); + tree element_pointer_type = TREE_TYPE (elements); + tree element_type = TREE_TYPE (element_pointer_type); + tree new_elements_size = save_expr (a68_multiple_elements_size (expr)); + tree new_elements = a68_lower_tmpvar ("new_elements%", + TREE_TYPE (elements), + (use_heap + ? a68_lower_malloc (TREE_TYPE (TREE_TYPE (elements)), + new_elements_size) + : a68_lower_alloca (TREE_TYPE (TREE_TYPE (elements)), + new_elements_size))); + + /* Then copy the elements. + + If the mode of the elements stored in the multiple dont have rows, + then we can just use memcpy. Otherwise, we have to loop and recurse + to dup all the elements in the multiple one by one. + + The above applies to multiples of any number of dimensions. */ + if (m == M_STRING || !HAS_ROWS (SUB (m))) + { + a68_add_stmt (a68_lower_memcpy (new_elements, + elements, + new_elements_size)); + a68_add_stmt (new_elements); + } + else + { + /* Note that num_elems includes elements that are not accessible due + to trimming. */ + tree num_elems = a68_lower_tmpvar ("numelems%", size_type_node, + fold_build2 (TRUNC_DIV_EXPR, sizetype, + new_elements_size, + size_in_bytes (element_type))); + tree orig_elements = a68_lower_tmpvar ("orig_elements%", + element_pointer_type, elements); + tree index = a68_lower_tmpvar ("index%", size_type_node, size_zero_node); + + /* Begin of loop body. */ + a68_push_range (NULL); + + /* if (index == num_elems) break; */ + a68_add_stmt (fold_build1 (EXIT_EXPR, + void_type_node, + fold_build2 (EQ_EXPR, + size_type_node, + index, num_elems))); + /* new_elements[index] = elements[index] */ + tree offset = fold_build2 (MULT_EXPR, sizetype, + index, size_in_bytes (element_type)); + tree new_elem_lvalue = fold_build2 (MEM_REF, element_type, + fold_build2 (POINTER_PLUS_EXPR, + element_pointer_type, + new_elements, + offset), + fold_convert (element_pointer_type, + integer_zero_node)); + tree elem = fold_build2 (MEM_REF, element_type, + fold_build2 (POINTER_PLUS_EXPR, + element_pointer_type, + orig_elements, + offset), + fold_convert (element_pointer_type, + integer_zero_node)); + a68_add_stmt (fold_build2 (MODIFY_EXPR, element_type, + new_elem_lvalue, + a68_low_dup (elem, use_heap))); + /* index++ */ + a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, + size_type_node, + index, size_one_node)); + tree loop_body = a68_pop_range (); + /* End of loop body. */ + + a68_add_stmt (fold_build1 (LOOP_EXPR, + void_type_node, + loop_body)); + a68_add_stmt (new_elements); + } + + new_elements = a68_pop_range (); + TREE_TYPE (new_elements) = element_pointer_type; + + /* Now build a descriptor pointing to the dupped elements and return it. + Note that the descriptor is always allocated on the stack. */ + dup = a68_row_value_raw (type, + a68_multiple_triplets (expr), + new_elements, + new_elements_size); + } + else if (!HAS_ROWS (m)) + { + /* Non-multiple values that do not contain rows do not need to be dupped, + since they can be just moved around using the semantics of + MODIFY_EXPR. */ + dup = expr; + } + else if (A68_STRUCT_TYPE_P (type)) + { + /* Since struct value can contain multiples and unions and other values + that require deep copy, we cannot simply rely on the C semantics of a + MODIFY_EXPR. */ + tree struct_type = type; + vec *ce = NULL; + + expr = save_expr (expr); + for (tree field = TYPE_FIELDS (struct_type); + field; + field = TREE_CHAIN (field)) + { + CONSTRUCTOR_APPEND_ELT (ce, field, + a68_low_dup (fold_build3 (COMPONENT_REF, + TREE_TYPE (field), + expr, + field, + NULL_TREE), + use_heap)); + } + dup = build_constructor (struct_type, ce); + } + else if (A68_UNION_TYPE_P (type)) + { + /* We need to recurse in whatever type corresponding to the active mode + in the united value. This shall be done at run-time by using a series + of + + IF overhead IS index of mode blah in union + THEN dup = dup_type (CTYPE (mode blah in union)) + FI + */ + + MOID_T *union_mode = a68_type_moid (type); + + a68_push_range (union_mode); + dup = a68_lower_tmpvar ("dup%", type, expr); + + tree cunion_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))); + tree field_decl = TYPE_FIELDS (cunion_type); + while (EQUIVALENT (union_mode) != NO_MOID) + union_mode = EQUIVALENT (union_mode); + for (PACK_T *pack = PACK (union_mode); pack != NO_PACK; FORWARD (pack)) + { + tree continue_label_decl = build_decl (UNKNOWN_LOCATION, + LABEL_DECL, + NULL, /* Set below. */ + void_type_node); + char *label_name = xasprintf ("continue%d%%", DECL_UID (continue_label_decl)); + DECL_NAME (continue_label_decl) = get_identifier (label_name); + free (label_name); + + a68_add_decl (continue_label_decl); + + a68_add_stmt (fold_build2 (TRUTH_ORIF_EXPR, + integer_type_node, + fold_build2 (EQ_EXPR, + integer_type_node, + a68_union_overhead (dup), + size_int (a68_united_mode_index (union_mode, MOID (pack)))), + fold_build2 (COMPOUND_EXPR, + integer_type_node, + build1 (GOTO_EXPR, void_type_node, continue_label_decl), + integer_zero_node))); + a68_add_stmt (fold_build2 (MODIFY_EXPR, type, + fold_build3 (COMPONENT_REF, + TREE_TYPE (field_decl), + a68_union_cunion (dup), + field_decl, + NULL_TREE), + a68_low_dup (fold_build3 (COMPONENT_REF, + TREE_TYPE (field_decl), + a68_union_cunion (dup), + field_decl, + NULL_TREE), + use_heap))); + a68_add_stmt (build1 (LABEL_EXPR, void_type_node, continue_label_decl)); + field_decl = TREE_CHAIN (field_decl); + } + + a68_add_stmt (dup); + dup = a68_pop_range (); + } + else + /* Not an Algol 68 value. */ + gcc_unreachable (); + + return dup; +} + +/* Lower code to ascribe the value yielded by the expression in RHS to the + defining identifier implied by the LHS, which is a VAR_DECL tree. MODE is + the mode of the value to be ascribed. */ + +tree +a68_low_ascription (MOID_T *mode, tree lhs, tree rhs) +{ + gcc_assert (VAR_P (lhs)); + + tree type = CTYPE (mode); + if (IS (mode, PROC_SYMBOL)) + { + /* A pointer to a function, or a function, is expected at the right hand + side. We need a pointer for the left hand side.. */ + if (TREE_CODE (TREE_TYPE (rhs)) == FUNCTION_TYPE) + { + type = build_pointer_type (type); + rhs = fold_build1 (ADDR_EXPR, type, rhs); + } + } + + if (HAS_ROWS (mode)) + rhs = a68_low_dup (rhs); + return fold_build2 (MODIFY_EXPR, type, lhs, rhs); +} + +/* Perform an assignation of RHS to LHS. + + MODE_RHS is the mode of the rhs. + MODE_LHS is the mode of the lhs. + + MODE_LHS shall be REF [FLEX] MODE_LHS. */ + +tree +a68_low_assignation (NODE_T *p, + tree lhs, MOID_T *mode_lhs, + tree rhs, MOID_T *mode_rhs) +{ + NODE_T *lhs_node = SUB (p); + tree assignation = NULL_TREE; + tree orig_rhs = rhs; + + if (IS_FLEXETY_ROW (mode_rhs)) + { + /* Make a deep copy of the rhs. Note that we have to use the heap + because the scope of the lhs may be older than the scope of the rhs. + XXX this can be ommitted if a68_multiple_copy_elems below supports + overlapping multiples. */ + if (HAS_ROWS (mode_rhs)) + rhs = a68_low_dup (rhs, true /* use_heap */); + rhs = save_expr (rhs); + + /* Determine whether the REF [FLEX] MODE_LHS is flexible. */ + if (SUB (mode_lhs) == M_STRING || IS_FLEX (SUB (mode_lhs))) + { + /* Assigning to a flexible name updates descriptor with new bounds + and also sets the elements to the dup of the rhs. No boundscheck + is peformed. XXX but bound checking in contained values may be + necessary, ghost elements. */ + if (POINTER_TYPE_P (TREE_TYPE (lhs)) + && TREE_TYPE (TREE_TYPE (lhs)) == TREE_TYPE (rhs)) + { + /* Make sure to not evaluate the expression yielding the pointer + more than once. */ + lhs = save_expr (lhs); + tree deref_lhs = a68_checked_indirect_ref (lhs_node, lhs, mode_lhs); + assignation = fold_build2 (COMPOUND_EXPR, + TREE_TYPE (lhs), + fold_build2 (MODIFY_EXPR, TREE_TYPE (lhs), + deref_lhs, rhs), + lhs); + } + else + { + /* The lhs is either a variable or a component ref as a l-value. It + is ok to evaluate it as an r-value as well as doing so inroduces + no side-effects. */ + assignation = fold_build2 (COMPOUND_EXPR, + TREE_TYPE (lhs), + fold_build2 (MODIFY_EXPR, TREE_TYPE (lhs), + lhs, rhs), + lhs); + } + } + else + { + /* Dereference the multiple at the left-hand side. This may require + indirection. */ + + tree effective_lhs; + if (POINTER_TYPE_P (TREE_TYPE (lhs))) + { + /* The name at the lhs is a pointer. */ + gcc_assert (TREE_TYPE (TREE_TYPE (lhs)) == TREE_TYPE (rhs)); + lhs = save_expr (lhs); + effective_lhs = a68_checked_indirect_ref (lhs_node, lhs, mode_lhs); + } + else + { + /* The name at the lhs is either a variable or a component ref as + a l-value. It is ok to evaluate it as an r-value as well as + doing so introduces no side-effects. */ + effective_lhs = lhs; + } + + /* Copy over the elements in a loop. The space occupied by the + previous elements stored in the lhs multiple will be recovered by + either stack shrinkage or garbage collected. */ + tree copy_elements = a68_multiple_copy_elems (mode_rhs, effective_lhs, rhs); + assignation = fold_build2 (COMPOUND_EXPR, + TREE_TYPE (lhs), + copy_elements, + lhs); + + /* Check the bounds of the multiple at the rhs to make sure they are + the same than the bounds of the multiple already referred by the + lhs. If the bounds don't match then emit a run-time error. */ + if (OPTION_BOUNDS_CHECKING (&A68_JOB)) + assignation = fold_build2 (COMPOUND_EXPR, + TREE_TYPE (assignation), + a68_multiple_bounds_check_equal (p, + effective_lhs, + rhs), + assignation); + + } + } + else + { + /* First make sure we got a pointer in the RHS in case it is a name. */ + rhs = a68_consolidate_ref (mode_rhs, rhs); + + /* The assignation implies copying the entire value being assigned, so + make sure we do a deep copy whenever needed. Note that we have to use + the heap because the scope of the lhs may be older than the scope of + the rhs. */ + if (HAS_ROWS (mode_rhs)) + rhs = a68_low_dup (rhs, true /* use_heap */); + + if (POINTER_TYPE_P (TREE_TYPE (lhs)) + && TREE_TYPE (TREE_TYPE (lhs)) == TREE_TYPE (rhs)) + { + /* If the left hand side is a pointer, deref it, but return the + pointer. Make sure to not evaluate the expression yielding the + pointer more than once. */ + lhs = save_expr (lhs); + tree deref_lhs = a68_checked_indirect_ref (lhs_node, lhs, mode_lhs); + assignation = fold_build2 (COMPOUND_EXPR, + TREE_TYPE (lhs), + fold_build2 (MODIFY_EXPR, TREE_TYPE (lhs), + deref_lhs, rhs), + lhs); + } + else + { + /* Otherwise the lhs is either a variable or a component ref as an + l-value. It is ok to evaluate it as an r-value as well as doing + so introduces no side-effects. */ + assignation = fold_build2 (COMPOUND_EXPR, + TREE_TYPE (lhs), + fold_build2 (MODIFY_EXPR, TREE_TYPE (lhs), + lhs, rhs), + lhs); + } + } + + /* Since it is been assigned to a name, the rhs is no longer constant. */ + if (A68_ROW_TYPE_P (TREE_TYPE (orig_rhs)) || A68_STRUCT_TYPE_P (TREE_TYPE (orig_rhs))) + TREE_CONSTANT (orig_rhs) = 0; + return assignation; +} + +/* Build a tree that copies SIZE bytes from SRC into DST. */ + +tree +a68_lower_memcpy (tree dst, tree src, tree size) +{ + return build_call_expr (builtin_decl_explicit (BUILT_IN_MEMCPY), 3, + dst, src, size); +} + +/* Build a tree that allocates SIZE bytes on the stack and returns a *TYPE + pointer to it. */ + +tree +a68_lower_alloca (tree type, tree size) +{ + tree call = builtin_decl_explicit (BUILT_IN_ALLOCA_WITH_ALIGN); + call = build_call_expr_loc (UNKNOWN_LOCATION, call, 2, + size, + size_int (TYPE_ALIGN (type))); + call = fold_convert (build_pointer_type (type), call); + return call; +} + + +/* Build a tree that allocates SIZE bytes on the heap and returns a *TYPE + pointer to it. */ + +tree +a68_lower_malloc (tree type, tree size) +{ + return fold_convert (build_pointer_type (type), + a68_build_libcall (A68_LIBCALL_MALLOC, ptr_type_node, + 1, size)); +} + +/* Build code for a temporary variable named NAME, of type TYPE and initialized + to INIT. Returns the decl node for the temporary. */ + +tree +a68_lower_tmpvar (const char *name, tree type, tree init) +{ + tree tmpvar = build_decl (UNKNOWN_LOCATION, + VAR_DECL, + get_identifier (name), + type); + DECL_ARTIFICIAL (tmpvar) = 1; + DECL_IGNORED_P (tmpvar) = 1; + a68_add_decl (tmpvar); + a68_add_decl_expr (fold_build1 (DECL_EXPR, type, tmpvar)); + a68_add_stmt (fold_build2 (INIT_EXPR, type, tmpvar, init)); + return tmpvar; +} + +/* Build a FUNC_DECL for a top-level non-public function and return it. */ + +tree +a68_low_toplevel_func_decl (const char *name, tree fntype) +{ + tree fndecl = build_decl (UNKNOWN_LOCATION, + FUNCTION_DECL, + NULL /* set below */, + fntype); + char *_name = xasprintf ("__ga68_%s%d", name, DECL_UID (fndecl)); + DECL_NAME (fndecl) = get_identifier (_name); + free (_name); + DECL_EXTERNAL (fndecl) = 0; + TREE_PUBLIC (fndecl) = 0; + TREE_STATIC (fndecl) = 1; + + return fndecl; +} + +/* Build a PARM_DECL whose context is TYPE with the given NAME. */ + +tree +a68_low_func_param (tree fndecl, const char *name, tree type) +{ + tree param = build_decl (UNKNOWN_LOCATION, PARM_DECL, + get_identifier (name), type); + DECL_CONTEXT (param) = fndecl; + DECL_ARG_TYPE (param) = TREE_TYPE (param); + layout_decl (param, 0); + return param; +} + +/* Lower revelations, to calls to either its prelude or poslude. + This function always returns NULL_TREE. */ + +static tree +lower_revelations (NODE_T *p, LOW_CTX_T ctx, bool prelude) +{ + for (; p != NO_NODE; FORWARD (p)) + { + lower_revelations (SUB (p), ctx, prelude); + if (IS (p, MODULE_INDICANT)) + { + tree decl = build_decl (a68_get_node_location (p), + FUNCTION_DECL, + NULL_TREE, /* name, set below. */ + build_function_type (void_type_node, + void_list_node)); + DECL_NAME (decl) + = a68_get_mangled_identifier (prelude ? "_prelude" : "_postlude", + NSYMBOL (p)); + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + a68_add_decl (decl); + a68_add_stmt (build_call_expr_loc (a68_get_node_location (p), + decl, 0)); + } + } + + return NULL_TREE; +} + +/* Lower a module text. + + module text : revelation part, def part, postlude part, fed symbol ; + revelation part, def part, fed symbol ; + def part, postlude part, fed symbol ; + def part, postlude part, fed symbol. + def part : def symbol, enquiry clause. + postlude part : postlude symbol, serial clause. + + Each module text lowers to two functions which are callable from outside the + current compilation unit: + + MODULENAME__prelude + MODULENAME__postlude + + Declarations inside prelude and postlude are lowered into global decl trees. + The non-PUBlicized ones are marked as static. + + This handler always returns NULL_TREE. */ + +static tree +lower_module_text (NODE_T *p, LOW_CTX_T ctx) +{ + NODE_T *def_part = (IS (SUB (p), REVELATION_PART) + ? NEXT_SUB (p) + : SUB (p)); + NODE_T *revelation_part = (IS (SUB (p), REVELATION_PART) + ? SUB (p) + : NO_NODE); + NODE_T *postlude_part = (IS (NEXT (def_part), FED_SYMBOL) + ? NO_NODE + : NEXT (def_part)); + NODE_T *prelude_enquiry = NEXT_SUB (def_part); + + /* The global sentinel of the module, initialized to 0. */ + tree sentinel_decl = build_decl (UNKNOWN_LOCATION, + VAR_DECL, NULL /* name */, + sizetype); + char *sentinel_name = xasprintf ("%s__sentinel", ctx.module_definition_name); + DECL_NAME (sentinel_decl) = get_identifier (sentinel_name); + free (sentinel_name); + TREE_PUBLIC (sentinel_decl) = 0; + TREE_STATIC (sentinel_decl) = 1; + DECL_CONTEXT (sentinel_decl) = NULL_TREE; /* File scope. */ + make_decl_rtl (sentinel_decl); + varpool_node::finalize_decl (sentinel_decl); + + /* Create the prelude function. */ + tree prelude_decl = build_decl (a68_get_node_location (def_part), + FUNCTION_DECL, + NULL_TREE, /* name, set below. */ + build_function_type (void_type_node, + void_list_node)); + DECL_NAME (prelude_decl) + = a68_get_mangled_identifier ("_prelude", + ctx.module_definition_name); + DECL_EXTERNAL (prelude_decl) = 0; + TREE_PUBLIC (prelude_decl) = 1; + TREE_STATIC (prelude_decl) = 1; + + a68_push_function_range (prelude_decl, + void_type_node /* result_type */, true /* top_level */); + { + /* Increase sentinel. */ + a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, + sizetype, + sentinel_decl, size_one_node)); + + a68_push_stmt_list (NULL); + { + a68_push_stmt_list (NULL); + { + /* Add calls to preludes of modules in REVELATION_PART. */ + lower_revelations (revelation_part, ctx, true /* prelude */); + a68_add_stmt (a68_lower_tree (prelude_enquiry, ctx)); + } + tree do_prelude = a68_pop_stmt_list (); + + a68_push_stmt_list (M_VOID); + tree do_nothing = a68_pop_stmt_list (); + + /* Do the prelude work only if sentinel is 1. */ + a68_add_stmt (fold_build3 (COND_EXPR, void_type_node, + fold_build2 (EQ_EXPR, sizetype, + sentinel_decl, size_one_node), + do_prelude, do_nothing)); + } + tree prelude_body = a68_pop_stmt_list (); + a68_pop_function_range (prelude_body); + } + + /* Create the postlude function. This is done even if the module definition + has no postlude in the source code. */ + + location_t postlude_loc = UNKNOWN_LOCATION; + if (postlude_part != NO_NODE) + postlude_loc = a68_get_node_location (postlude_part); + tree postlude_decl = build_decl (postlude_loc, + FUNCTION_DECL, + NULL_TREE, /* name, set below. */ + build_function_type (void_type_node, + void_list_node)); + DECL_NAME (postlude_decl) + = a68_get_mangled_identifier ("_postlude", + ctx.module_definition_name); + DECL_EXTERNAL (postlude_decl) = 0; + TREE_PUBLIC (postlude_decl) = 1; + TREE_STATIC (postlude_decl) = 1; + + a68_push_function_range (postlude_decl, + void_type_node /* result_type */, true /* top_level */); + { + /* Decrease sentinel. */ + a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, + sizetype, + sentinel_decl, size_one_node)); + + a68_push_stmt_list (NULL); + { + a68_push_stmt_list (NULL); + { + /* Add calls to postludes of modules in REVELATION_PART. */ + lower_revelations (revelation_part, ctx, false /* prelude */); + /* Perhaps the postlude code, if there is one. */ + NODE_T *postlude_serial = NO_NODE; + if (postlude_part != NO_NODE) + postlude_serial = NEXT_SUB (postlude_part); + if (postlude_serial != NO_NODE) + a68_add_stmt (a68_lower_tree (postlude_serial, ctx)); + } + tree do_postlude = a68_pop_stmt_list (); + + a68_push_stmt_list (M_VOID); + tree do_nothing = a68_pop_stmt_list (); + + /* Do the postlude work only if sentinel is 0. */ + a68_add_stmt (fold_build3 (COND_EXPR, void_type_node, + fold_build2 (EQ_EXPR, sizetype, + sentinel_decl, size_zero_node), + do_postlude, do_nothing)); + } + tree postlude_body = a68_pop_stmt_list (); + a68_pop_function_range (postlude_body); + } + + return NULL_TREE; +} + +/* Lower a set of module declarations. + + module declaration : module symbol, defining module, equals symbol, module text ; + module_declaration, comma symbol, defining module, + equals symbol, module text. + + Each module declaration lowers into the side-effects of emitting prelude and + postlude global functions, and emitting global declarations for the + declarations in the module definition prelude. + + This handler always returns NULL_TREE. */ + +static tree +lower_module_declaration (NODE_T *p, LOW_CTX_T ctx) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, DEFINING_MODULE_INDICANT)) + { + ctx.module_definition_name = NSYMBOL (p); + A68_MODULE_DEFINITION_DECLS->truncate (0); + vec_alloc (A68_MODULE_DEFINITION_DECLS, 16); + lower_module_text (NEXT (NEXT (p)), ctx); + for (tree d : A68_MODULE_DEFINITION_DECLS) + { + if (TREE_CODE (d) == FUNCTION_DECL) + cgraph_node::finalize_function (d, true); + else + { + rest_of_decl_compilation (d, 1, 0); + make_decl_rtl (d); + } + } + } + else + lower_module_declaration (SUB (p), ctx); + } + + return NULL_TREE; +} + +/* Lower a prelude packet. + + prelude packet : module declaration. + + This handler always returns NULL_TREE. */ + +static tree +lower_prelude_packet (NODE_T *p, LOW_CTX_T ctx) +{ + a68_lower_tree (SUB (p), ctx); + return NULL_TREE; +} + +/* Lower a particular program. + + particular program : label, enclosed clause; enclosed clause. + + This handler always returns NULL_TREE. */ + +static tree +lower_particular_program (NODE_T *p, LOW_CTX_T ctx) +{ + /* Create the main function that conforms the particular program. */ + tree main_decl = build_decl (a68_get_node_location (p), + FUNCTION_DECL, + get_identifier ("__algol68_main"), + build_function_type (void_type_node, + void_list_node)); + DECL_EXTERNAL (main_decl) = 0; + TREE_PUBLIC (main_decl) = 1; + TREE_STATIC (main_decl) = 1; + + a68_push_function_range (main_decl, + void_type_node /* result_type */); + + /* Lower the body of the function. */ + NODE_T *enclosed_clause = (IS (SUB (p), ENCLOSED_CLAUSE) + ? SUB (p) : NEXT (SUB (p))); + tree body_expr = a68_lower_tree (enclosed_clause, ctx); + a68_pop_function_range (body_expr); + return NULL_TREE; +} + +/* Lower a packet. + + packet : particular program ; prelude packet. +*/ + +static tree +lower_packet (NODE_T *p, + LOW_CTX_T ctx) +{ + return a68_lower_tree (SUB (p), ctx); +} + +/* Lower the given tree P using the given context CTX. */ + +tree +a68_lower_tree (NODE_T *p, LOW_CTX_T ctx) +{ +#if 0 + for (int i = 0; i < ctx.level; ++i) + printf (" "); + printf ("LOWER TREE: %d::%s\n", + NUMBER (p), a68_attribute_name (ATTRIBUTE (p))); +#endif + ctx.level++; + + tree res = NULL_TREE; + + if (p == NO_NODE) + gcc_unreachable (); + + switch (ATTRIBUTE (p)) + { + case PACKET: + res = lower_packet (p, ctx); + break; + break; + case PRELUDE_PACKET: + res = lower_prelude_packet (p, ctx); + break; + case MODULE_DECLARATION: + res = lower_module_declaration (p, ctx); + break; + case MODULE_TEXT: + res = lower_module_text (p, ctx); + break; + case PARTICULAR_PROGRAM: + res = lower_particular_program (p, ctx); + break; + /* Clauses */ + case ENCLOSED_CLAUSE: + res = a68_lower_enclosed_clause (p, ctx); + break; + case CLOSED_CLAUSE: + res = a68_lower_closed_clause (p, ctx); + break; + case ACCESS_CLAUSE: + res = a68_lower_access_clause (p, ctx); + break; + case PARALLEL_CLAUSE: + res = a68_lower_parallel_clause (p, ctx); + break; + case COLLATERAL_CLAUSE: + res = a68_lower_collateral_clause (p, ctx); + break; + case UNIT_LIST: + res = a68_lower_unit_list (p, ctx); + break; + case CONDITIONAL_CLAUSE: + res = a68_lower_conditional_clause (p, ctx); + break; + case ENQUIRY_CLAUSE: + res = a68_lower_enquiry_clause (p, ctx); + break; + case CASE_CLAUSE: + res = a68_lower_case_clause (p, ctx); + break; + case CONFORMITY_CLAUSE: + res = a68_lower_conformity_clause (p, ctx); + break; + case LOOP_CLAUSE: + res = a68_lower_loop_clause (p, ctx); + break; + case SERIAL_CLAUSE: + res = a68_lower_serial_clause (p, ctx); + break; + case INITIALISER_SERIES: + res = a68_lower_initialiser_series (p, ctx); + break; + case EXIT_SYMBOL: + res = a68_lower_completer (p, ctx); + break; + case LABELED_UNIT: + res = a68_lower_labeled_unit (p, ctx); + break; + case LABEL: + res = a68_lower_label (p, ctx); + break; + /* Declarations. */ + case DECLARATION_LIST: + res = a68_lower_declaration_list (p, ctx); + break; + case DECLARER: + res = a68_lower_declarer (p, ctx); + break; + case IDENTITY_DECLARATION: + res = a68_lower_identity_declaration (p, ctx); + break; + case VARIABLE_DECLARATION: + res = a68_lower_variable_declaration (p, ctx); + break; + case PROCEDURE_DECLARATION: + res = a68_lower_procedure_declaration (p, ctx); + break; + case PROCEDURE_VARIABLE_DECLARATION: + res = a68_lower_procedure_variable_declaration (p, ctx); + break; + case PRIORITY_DECLARATION: + res = a68_lower_priority_declaration (p, ctx); + break; + case BRIEF_OPERATOR_DECLARATION: + res = a68_lower_brief_operator_declaration (p, ctx); + break; + case OPERATOR_DECLARATION: + res = a68_lower_operator_declaration (p, ctx); + break; + case MODE_DECLARATION: + res = a68_lower_mode_declaration (p, ctx); + break; + /* Units. */ + case UNIT: + res = a68_lower_unit (p, ctx); + break; + case ROUTINE_TEXT: + res = a68_lower_routine_text (p, ctx); + break; + case ASSIGNATION: + res = a68_lower_assignation (p, ctx); + break; + case TERTIARY: + res = a68_lower_tertiary (p, ctx); + break; + case MONADIC_FORMULA: + res = a68_lower_monadic_formula (p, ctx); + break; + case FORMULA: + res = a68_lower_formula (p, ctx); + break; + case SECONDARY: + res = a68_lower_secondary (p, ctx); + break; + case SLICE: + res = a68_lower_slice (p, ctx); + break; + case SELECTION: + res = a68_lower_selection (p, ctx); + break; + case PRIMARY: + res = a68_lower_primary (p, ctx); + break; + case GENERATOR: + res = a68_lower_generator (p, ctx); + break; + case CALL: + res = a68_lower_call (p, ctx); + break; + case CAST: + res = a68_lower_cast (p, ctx); + break; + case AND_FUNCTION: + case OR_FUNCTION: + res = a68_lower_logic_function (p, ctx); + break; + case IDENTITY_RELATION: + res = a68_lower_identity_relation (p, ctx); + break; + case EMPTY_SYMBOL: + res = a68_lower_empty (p, ctx); + break; + case NIHIL: + res = a68_lower_nihil (p, ctx); + break; + case SKIP: + res = a68_lower_skip (p, ctx); + break; + case DENOTATION: + res = a68_lower_denotation (p, ctx); + break; + case IDENTIFIER: + res = a68_lower_identifier (p, ctx); + break; + /* Coercions. */ + case ROWING: + res = a68_lower_rowing (p, ctx); + break; + case WIDENING: + res = a68_lower_widening (p, ctx); + break; + case DEPROCEDURING: + res = a68_lower_deproceduring (p, ctx); + break; + case PROCEDURING: + res = a68_lower_proceduring (p, ctx); + break; + case VOIDING: + res = a68_lower_voiding (p, ctx); + break; + case DEREFERENCING: + res = a68_lower_dereferencing (p, ctx); + break; + /* Others. */ + case UNITING: + res = a68_lower_uniting (p, ctx); + break; + case JUMP: + res = a68_lower_jump (p, ctx); + break; + case PARAMETER: + res = a68_lower_parameter (p, ctx); + break; + case PARAMETER_LIST: + res = a68_lower_parameter_list (p, ctx); + break; + case PARAMETER_PACK: + res = a68_lower_parameter_pack (p, ctx); + break; + case OPERATOR: + res = a68_lower_operator (p, ctx); + break; + case ASSERTION: + res = a68_lower_assertion (p, ctx); + break; + case STOP: + res = NULL_TREE; + break; + default: + fatal_error (a68_get_node_location (p), "cannot lower node %s", + a68_attribute_name (ATTRIBUTE (p))); + gcc_unreachable (); + break; + } + + return res; +} + +/* Lower an Algol 68 complete parse tree to a GENERIC tree. */ + +tree +a68_lower_top_tree (NODE_T *p) +{ + LOW_CTX_T top_ctx; + + top_ctx.declarer = NULL; + top_ctx.proc_decl_identifier = NO_NODE; + top_ctx.proc_decl_operator = false; + top_ctx.level = 0; + top_ctx.module_definition_name = NULL; + vec_alloc (A68_MODULE_DEFINITION_DECLS, 16); + return a68_lower_tree (p, top_ctx); +} diff --git a/gcc/algol68/a68-moids-diagnostics.cc b/gcc/algol68/a68-moids-diagnostics.cc new file mode 100644 index 000000000000..a984fbc868fd --- /dev/null +++ b/gcc/algol68/a68-moids-diagnostics.cc @@ -0,0 +1,281 @@ +/* MOID diagnostics routines. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" + +#include "a68.h" + +/* Give accurate error message. */ + +const char * +a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, int depth) +{ +#define TAIL(z) (&(z)[strlen (z)]) +#define ACTUAL_SNPRINTF_SIZE ((SNPRINTF_SIZE - len)) + static BUFFER txt; + size_t len; + if (depth == 1) + txt[0] = '\0'; + if (IS (p, SERIES_MODE)) + { + len = strlen (txt); + PACK_T *u = PACK (p); + + int N = 0; + if (u == NO_PACK) + { + if (snprintf (txt, ACTUAL_SNPRINTF_SIZE, "empty mode-list") < 0) + gcc_unreachable (); + N++; + } + else + { + for (; u != NO_PACK; FORWARD (u)) + { + if (MOID (u) != NO_MOID) + { + if (IS (MOID (u), SERIES_MODE)) + (void) a68_mode_error_text (n, MOID (u), q, context, deflex, depth + 1); + else if (!a68_is_coercible (MOID (u), q, context, deflex)) + { + len = strlen (txt); + if (len > BUFFER_SIZE / 2) + { + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " etcetera") < 0) + gcc_unreachable (); + N++; + } + else + { + if (len > 0) + { + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " and ") < 0) + gcc_unreachable (); + N++; + len = strlen (txt); + } + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%%<%s%%>", + a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0) + gcc_unreachable (); + N++; + } + } + } + } + } + if (depth == 1) + { + len = strlen (txt); + if (N == 0) + { + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "mode") < 0) + gcc_unreachable (); + len = strlen (txt); + } + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " cannot be coerced to %%<%s%%>", + a68_moid_to_string (q, MOID_ERROR_WIDTH, n)) < 0) + gcc_unreachable (); + } + } + else if (IS (p, STOWED_MODE) && IS_FLEX (q)) + { + PACK_T *u = PACK (p); + len = strlen (txt); + if (u == NO_PACK) + { + if (snprintf (txt, ACTUAL_SNPRINTF_SIZE, "empty mode-list") < 0) + gcc_unreachable (); + } + else + { + for (; u != NO_PACK; FORWARD (u)) + { + if (!a68_is_coercible (MOID (u), SLICE (SUB (q)), context, deflex)) + { + len = strlen (txt); + if (len > BUFFER_SIZE / 2) + { + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " etcetera") < 0) + gcc_unreachable (); + } + else + { + if (len > 0) + { + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " and ") < 0) + gcc_unreachable (); + len = strlen (txt); + } + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%s", + a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0) + gcc_unreachable (); + } + } + } + len = strlen (txt); + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " cannot be coerced to %%<%s%%>", + a68_moid_to_string (SLICE (SUB (q)), MOID_ERROR_WIDTH, n)) < 0) + gcc_unreachable (); + } + } + else if (IS (p, STOWED_MODE) && IS (q, ROW_SYMBOL)) + { + PACK_T *u = PACK (p); + len = strlen (txt); + if (u == NO_PACK) + { + if (snprintf (txt, ACTUAL_SNPRINTF_SIZE, "empty mode-list") < 0) + gcc_unreachable (); + } + else + { + for (; u != NO_PACK; FORWARD (u)) + { + if (!a68_is_coercible (MOID (u), SLICE (q), context, deflex)) + { + len = strlen (txt); + if (len > BUFFER_SIZE / 2) + { + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " etcetera") < 0) + gcc_unreachable (); + } + else + { + if (len > 0) + { + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " and ") < 0) + gcc_unreachable (); + len = strlen (txt); + } + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%%<%s%%>", + a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0) + gcc_unreachable (); + } + } + } + len = strlen (txt); + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " cannot be coerced to %s", + a68_moid_to_string (SLICE (q), MOID_ERROR_WIDTH, n)) < 0) + gcc_unreachable (); + } + } + else if (IS (p, STOWED_MODE) && (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL))) + { + PACK_T *u = PACK (p), *v = PACK (q); + len = strlen (txt); + if (u == NO_PACK) + { + if (snprintf (txt, ACTUAL_SNPRINTF_SIZE, "empty mode-list") < 0) + gcc_unreachable (); + } + else + { + for (; u != NO_PACK && v != NO_PACK; FORWARD (u), FORWARD (v)) + { + if (!a68_is_coercible (MOID (u), MOID (v), context, deflex)) + { + len = strlen (txt); + if (len > BUFFER_SIZE / 2) + { + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " etcetera") < 0) + gcc_unreachable (); + } + else + { + if (len > 0) + { + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " and ") < 0) + gcc_unreachable (); + len = strlen (txt); + } + if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%%<%s%%> cannot be coerced to %%<%s%%>", + a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n), + a68_moid_to_string (MOID (v), MOID_ERROR_WIDTH, n)) < 0) + gcc_unreachable (); + } + } + } + } + } + return txt; +#undef TAIL +#undef ACTUAL_SNPRINTF_SIZE +} + +/* Cannot coerce error. */ + +void +a68_cannot_coerce (NODE_T *p, MOID_T *from, MOID_T *to, int context, int deflex, int att) +{ + const char *txt = a68_mode_error_text (p, from, to, context, deflex, 1); + + if (att == STOP) + { + if (strlen (txt) == 0) + a68_error (p, "M cannot be coerced to M in C context", from, to, context); + else + a68_error (p, "Y in C context", txt, context); + } + else + { + if (strlen (txt) == 0) + a68_error (p, "M cannot be coerced to M in C-A", from, to, context, att); + else + a68_error (p, "Y in C-A", txt, context, att); + } +} + +/* Give a warning when a value is silently discarded. */ + +void +a68_warn_for_voiding (NODE_T *p, SOID_T *x, SOID_T *y, int c) +{ + (void) c; + + if (CAST (x) == false) + { + if (MOID (x) == M_VOID && MOID (y) != M_ERROR && !(MOID (y) == M_VOID || !a68_is_nonproc (MOID (y)))) + { + if (IS (p, FORMULA)) + a68_warning (p, OPT_Wvoiding, "value of M @ will be voided", MOID (y)); + else + a68_warning (p, OPT_Wvoiding, "value of M @ will be voided", MOID (y)); + } + } +} + +/* Warn for things that are likely unintended. */ + +void +a68_semantic_pitfall (NODE_T *p, MOID_T *m, int c, int u) +{ + /* semantic_pitfall: warn for things that are likely unintended, for instance + REF INT i := LOC INT := 0, which should probably be + REF INT i = LOC INT := 0. */ + if (IS (p, u)) + a68_warning (p, 0, "possibly unintended M A in M A", + MOID (p), u, m, c); + else if (a68_is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) + a68_semantic_pitfall (SUB (p), m, c, u); +} diff --git a/gcc/algol68/a68-moids-misc.cc b/gcc/algol68/a68-moids-misc.cc new file mode 100644 index 000000000000..349c13fd6565 --- /dev/null +++ b/gcc/algol68/a68-moids-misc.cc @@ -0,0 +1,1396 @@ +/* Miscellaneous MOID routines. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" + +#include "a68.h" + +/* + * MODE checker routines. + */ + +/* Absorb nested series modes recursively. */ + +void +a68_absorb_series_pack (MOID_T **p) +{ + bool siga; + + do + { + PACK_T *z = NO_PACK; + + siga = false; + for (PACK_T *t = PACK (*p); t != NO_PACK; FORWARD (t)) + { + if (MOID (t) != NO_MOID && IS (MOID (t), SERIES_MODE)) + { + siga = true; + for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) + a68_add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s)); + } + else + a68_add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t)); + } + PACK (*p) = z; + } + while (siga); +} + +/* Make SERIES (u, v). */ + +MOID_T * +a68_make_series_from_moids (MOID_T *u, MOID_T *v) +{ + MOID_T *x = a68_new_moid (); + + ATTRIBUTE (x) = SERIES_MODE; + a68_add_mode_to_pack (&(PACK (x)), u, NO_TEXT, NODE (u)); + a68_add_mode_to_pack (&(PACK (x)), v, NO_TEXT, NODE (v)); + a68_absorb_series_pack (&x); + DIM (x) = a68_count_pack_members (PACK (x)); + (void) a68_register_extra_mode (&TOP_MOID (&A68_JOB), x); + if (DIM (x) == 1) + return MOID (PACK (x)); + else + return x; +} + +/* Absorb firmly related unions in mode. + + For instance invalid UNION (PROC REF UNION (A, B), A, B) -> valid + UNION (A, B), which is used in balancing conformity clauses. */ + +MOID_T * +a68_absorb_related_subsets (MOID_T * m) +{ + /* For instance invalid UNION (PROC REF UNION (A, B), A, B) -> valid UNION + (A, B), which is used in balancing conformity clauses. */ + bool siga; + + do + { + PACK_T *u = NO_PACK; + + siga = false; + for (PACK_T *v = PACK (m); v != NO_PACK; FORWARD (v)) + { + MOID_T *n = a68_depref_completely (MOID (v)); + + if (IS (n, UNION_SYMBOL) && a68_is_subset (n, m, SAFE_DEFLEXING)) + { + /* Unpack it. */ + for (PACK_T *w = PACK (n); w != NO_PACK; FORWARD (w)) + a68_add_mode_to_pack (&u, MOID (w), NO_TEXT, NODE (w)); + siga = true; + } + else + a68_add_mode_to_pack (&u, MOID (v), NO_TEXT, NODE (v)); + } + PACK (m) = a68_absorb_union_pack (u); + } + while (siga); + return m; +} + +/* Absorb nested series and united modes recursively. */ + +void +a68_absorb_series_union_pack (MOID_T **p) +{ + bool siga; + + do + { + PACK_T *z = NO_PACK; + + siga = false; + for (PACK_T *t = PACK (*p); t != NO_PACK; FORWARD (t)) + { + if (MOID (t) != NO_MOID && (IS (MOID (t), SERIES_MODE) || IS (MOID (t), UNION_SYMBOL))) + { + siga = true; + for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) + a68_add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s)); + } + else + a68_add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t)); + } + PACK (*p) = z; + } + while (siga); +} + +/* Make united mode, from mode that is a SERIES (..). */ + +MOID_T * +a68_make_united_mode (MOID_T *m) +{ + if (m == NO_MOID) + return M_ERROR; + else if (ATTRIBUTE (m) != SERIES_MODE) + return m; + + /* Do not unite a single UNION. */ + if (DIM (m) == 1 && IS (MOID (PACK (m)), UNION_SYMBOL)) + return MOID (PACK (m)); + + /* Straighten the series. */ + a68_absorb_series_union_pack (&m); + /* Copy the series into a UNION. */ + MOID_T *u = a68_new_moid (); + ATTRIBUTE (u) = UNION_SYMBOL; + PACK (u) = NO_PACK; + for (PACK_T *w = PACK (m); w != NO_PACK; FORWARD (w)) + a68_add_mode_to_pack (&(PACK (u)), MOID (w), NO_TEXT, NODE (m)); + + /* Absorb and contract the new UNION. */ + a68_absorb_series_union_pack (&u); + DIM (u) = a68_count_pack_members (PACK (u)); + PACK (u) = a68_absorb_union_pack (PACK (u)); + a68_contract_union (u); + DIM (u) = a68_count_pack_members (PACK (u)); + /* A UNION of one mode is that mode itself. */ + if (DIM (u) == 1) + return MOID (PACK (u)); + else + return a68_register_extra_mode (&TOP_MOID (&A68_JOB), u); +} + +/* Make SOID data structure. */ + +void +a68_make_soid (SOID_T *s, int sort, MOID_T *type, int attribute) +{ + ATTRIBUTE (s) = attribute; + SORT (s) = sort; + MOID (s) = type; + CAST (s) = false; +} + +/* Whether mode is not well defined. */ + +bool +a68_is_mode_isnt_well (MOID_T *p) +{ + if (p == NO_MOID) + return true; + else if (!A68_IF_MODE_IS_WELL (p)) + return true; + else if (PACK (p) != NO_PACK) + { + for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q)) + { + if (!A68_IF_MODE_IS_WELL (MOID (q))) + return true; + } + } + return false; +} + +/* Add SOID data to free chain. */ + +void +a68_free_soid_list (SOID_T *root) +{ + if (root != NO_SOID) + { + SOID_T *q = root; + + for (; NEXT (q) != NO_SOID; FORWARD (q)) + ; + NEXT (q) = A68 (top_soid_list); + A68 (top_soid_list) = root; + } +} + +/* Add SOID data structure to soid list. */ + +void +a68_add_to_soid_list (SOID_T **root, NODE_T *where, SOID_T *soid) +{ + if (*root != NO_SOID) + a68_add_to_soid_list (&(NEXT (*root)), where, soid); + else + { + SOID_T *new_one; + + if (A68 (top_soid_list) == NO_SOID) + new_one = (SOID_T *) ggc_cleared_alloc (); + else + { + new_one = A68 (top_soid_list); + FORWARD (A68 (top_soid_list)); + } + + a68_make_soid (new_one, SORT (soid), MOID (soid), 0); + NODE (new_one) = where; + NEXT (new_one) = NO_SOID; + *root = new_one; + } +} + +/* Pack soids in moid, gather resulting moids from terminators in a clause. */ + +MOID_T * +a68_pack_soids_in_moid (SOID_T *top_sl, int attribute) +{ + MOID_T *x = a68_new_moid (); + PACK_T *t, **p; + + ATTRIBUTE (x) = attribute; + DIM (x) = 0; + SUB (x) = NO_MOID; + EQUIVALENT (x) = NO_MOID; + SLICE (x) = NO_MOID; + DEFLEXED (x) = NO_MOID; + NAME (x) = NO_MOID; + NEXT (x) = NO_MOID; + PACK (x) = NO_PACK; + p = &(PACK (x)); + for (; top_sl != NO_SOID; FORWARD (top_sl)) + { + t = a68_new_pack (); + MOID (t) = MOID (top_sl); + TEXT (t) = NO_TEXT; + NODE (t) = NODE (top_sl); + NEXT (t) = NO_PACK; + DIM (x)++; + *p = t; + p = &NEXT (t); + } + (void) a68_register_extra_mode (&TOP_MOID (&A68_JOB), x); + return x; +} + +/* Whether P is compatible with Q. */ + +bool +a68_is_equal_modes (MOID_T *p, MOID_T *q, int deflex) +{ + if (deflex == FORCE_DEFLEXING) + return DEFLEX (p) == DEFLEX (q); + else if (deflex == ALIAS_DEFLEXING) + { + if (IS (p, REF_SYMBOL) && IS (q, REF_SYMBOL)) + return (p == q + || a68_prove_moid_equivalence (p, q) + || a68_prove_moid_equivalence (DEFLEX (p), q) + || DEFLEX (p) == q); + else if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL)) + return (DEFLEX (p) == DEFLEX (q) + || a68_prove_moid_equivalence (DEFLEX (p), DEFLEX (q))); + } + else if (deflex == SAFE_DEFLEXING) + { + if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL)) + return (DEFLEX (p) == DEFLEX (q) + || a68_prove_moid_equivalence (DEFLEX (p), DEFLEX (q))); + } + + return (p == q || a68_prove_moid_equivalence (p, q)); +} + +/* Whether mode is deprefable, i.e. whether it can be either deferred or + deprocedured. */ + +bool +a68_is_deprefable (MOID_T *p) +{ + if (IS_REF (p)) + return true; + else + return (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK); +} + +/* Deref or deproc the mode P once. */ + +MOID_T * +a68_depref_once (MOID_T *p) +{ + if (IS_REF_FLEX (p)) + return SUB_SUB (p); + else if (IS_REF (p)) + return SUB (p); + else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) + return SUB (p); + else + return NO_MOID; +} + +/* Depref mode completely. */ + +MOID_T * +a68_depref_completely (MOID_T *p) +{ + while (a68_is_deprefable (p)) + p = a68_depref_once (p); + return p; +} + +/* Deproc_completely. */ + +MOID_T * +a68_deproc_completely (MOID_T *p) +{ + while (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) + p = a68_depref_once (p); + return p; +} + +/* Depref rows. */ + +MOID_T * +a68_depref_rows (MOID_T *p, MOID_T *q) +{ + if (q == M_ROWS) + { + while (a68_is_deprefable (p)) + p = a68_depref_once (p); + return p; + } + else + return q; +} + +/* Derow mode, strip FLEX and BOUNDS. */ + +MOID_T * +a68_derow (MOID_T *p) +{ + if (IS_ROW (p) || IS_FLEX (p)) + return a68_derow (SUB (p)); + else + return p; +} + +/* Whether rows type. */ + +bool +a68_is_rows_type (MOID_T *p) +{ + switch (ATTRIBUTE (p)) + { + case ROW_SYMBOL: + case FLEX_SYMBOL: + return true; + case UNION_SYMBOL: + { + PACK_T *t = PACK (p); + bool siga = true; + while (t != NO_PACK && siga) + { + siga &= a68_is_rows_type (MOID (t)); + FORWARD (t); + } + return siga; + } + default: + return false; + } +} + +/* Whether mode is PROC (REF FILE) VOID or FORMAT. */ + +bool +a68_is_proc_ref_file_void_or_format (MOID_T *p) +{ + if (p == M_PROC_REF_FILE_VOID) + return true; + else if (p == M_FORMAT) + return true; + else + return false; +} + +/* Whether mode can be transput. */ + +bool +a68_is_transput_mode (MOID_T *p, char rw) +{ + if (p == M_INT) + return true; + else if (p == M_SHORT_INT) + return true; + else if (p == M_SHORT_SHORT_INT) + return true; + else if (p == M_LONG_INT) + return true; + else if (p == M_LONG_LONG_INT) + return true; + else if (p == M_REAL) + return true; + else if (p == M_LONG_REAL) + return true; + else if (p == M_LONG_LONG_REAL) + return true; + else if (p == M_BOOL) + return true; + else if (p == M_CHAR) + return true; + else if (p == M_BITS) + return true; + else if (p == M_SHORT_BITS) + return true; + else if (p == M_SHORT_SHORT_BITS) + return true; + else if (p == M_LONG_BITS) + return true; + else if (p == M_LONG_LONG_BITS) + return true; + else if (p == M_COMPLEX) + return true; + else if (p == M_LONG_COMPLEX) + return true; + else if (p == M_LONG_LONG_COMPLEX) + return true; + else if (p == M_ROW_CHAR) + return true; + else if (p == M_STRING) + return true; + else if (IS (p, UNION_SYMBOL) || IS (p, STRUCT_SYMBOL)) + { + for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q)) + { + if (!(a68_is_transput_mode (MOID (q), rw) + || a68_is_proc_ref_file_void_or_format (MOID (q)))) + return false; + } + return true; + } + else if (IS_FLEX (p)) + { + if (SUB (p) == M_ROW_CHAR) + return true; + else + return (rw == 'w' ? a68_is_transput_mode (SUB (p), rw) : false); + } + else if (IS_ROW (p)) + return (a68_is_transput_mode (SUB (p), rw) + || a68_is_proc_ref_file_void_or_format (SUB (p))); + else + return false; +} + +/* Whether mode is printable. */ + +bool +a68_is_printable_mode (MOID_T *p) +{ + if (a68_is_proc_ref_file_void_or_format (p)) + return true; + else + return a68_is_transput_mode (p, 'w'); +} + +/* Whether mode is readable. */ + +bool +a68_is_readable_mode (MOID_T *p) +{ + if (a68_is_proc_ref_file_void_or_format (p)) + return true; + else if (IS_REF (p)) + return a68_is_transput_mode (SUB (p), 'r'); + else if (IS_UNION (p)) + { + for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q)) + { + if (!IS_REF (MOID (q))) + return false; + else if (!a68_is_transput_mode (SUB (MOID (q)), 'r')) + return false; + } + return true; + } + else + return false; +} + +/* Whether name struct. */ + +bool +a68_is_name_struct (MOID_T *p) +{ + return (NAME (p) != NO_MOID ? IS (DEFLEX (SUB (p)), STRUCT_SYMBOL) : false); +} + +/* Yield mode to unite to. */ + +MOID_T * +a68_unites_to (MOID_T *m, MOID_T *u) +{ + /* Uniting U (m). */ + MOID_T *v = NO_MOID; + + if (u == M_SIMPLIN || u == M_SIMPLOUT) + return m; + + for (PACK_T *p = PACK (u); p != NO_PACK; FORWARD (p)) + { + /* Prefer []->[] over []->FLEX []. */ + if (m == MOID (p)) + v = MOID (p); + else if (v == NO_MOID && DEFLEX (m) == DEFLEX (MOID (p))) + v = MOID (p); + } + return v; +} + +/* Whether moid in pack. */ + +bool +a68_is_moid_in_pack (MOID_T *u, PACK_T *v, int deflex) +{ + for (; v != NO_PACK; FORWARD (v)) + { + if (a68_is_equal_modes (u, MOID (v), deflex)) + return true; + } + + return false; +} + +/* Whether a rows type in pack. */ + +bool +a68_is_rows_in_pack (PACK_T *v) +{ + for (; v != NO_PACK; FORWARD (v)) + { + if (a68_is_rows_type (MOID (v))) + return true; + } + + return false; +} + +/* Whether P is a subset of Q. */ + +bool +a68_is_subset (MOID_T *p, MOID_T *q, int deflex) +{ + bool j =true; + + for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u)) + j = (j && a68_is_moid_in_pack (MOID (u), PACK (q), deflex)); + + return j; +} + +/* Whether P can be united to UNION Q. */ + +bool +a68_is_unitable (MOID_T *p, MOID_T *q, int deflex) +{ + if (IS (q, UNION_SYMBOL)) + { + if (IS (p, UNION_SYMBOL)) + return a68_is_subset (p, q, deflex); + else if (p == M_ROWS) + return a68_is_rows_in_pack (PACK (q)); + else + return a68_is_moid_in_pack (p, PACK (q), deflex); + } + + return false; +} + +/* Whether all or some components of U can be firmly coerced to a component + mode of V.. */ + +void +a68_investigate_firm_relations (PACK_T *u, PACK_T *v, bool *all, bool *some) +{ + *all = true; + *some = true; + for (; v != NO_PACK; FORWARD (v)) + { + bool k = false; + + for (PACK_T *w = u; w != NO_PACK; FORWARD (w)) + k |= a68_is_coercible (MOID (w), MOID (v), FIRM, FORCE_DEFLEXING); + *some |= k; + *all &= k; + } +} + +/* Whether there is a soft path from P to Q. */ + +bool +a68_is_softly_coercible (MOID_T *p, MOID_T *q, int deflex) +{ + if (a68_is_equal_modes (p, q, deflex)) + return true; + else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) + return a68_is_softly_coercible (SUB (p), q, deflex); + else + return false; +} + +/* Whether there is a weak path from P to Q. */ + +bool +a68_is_weakly_coercible (MOID_T * p, MOID_T * q, int deflex) +{ + if (a68_is_equal_modes (p, q, deflex)) + return true; + else if (a68_is_deprefable (p)) + return a68_is_weakly_coercible (a68_depref_once (p), q, deflex); + else + return false; +} + +/* Whether there is a meek path from P to Q. */ + +bool +a68_is_meekly_coercible (MOID_T *p, MOID_T *q, int deflex) +{ + if (a68_is_equal_modes (p, q, deflex)) + return true; + else if (a68_is_deprefable (p)) + return a68_is_meekly_coercible (a68_depref_once (p), q, deflex); + else + return false; +} + +/* Whether there is a firm path from P to Q. */ + +bool +a68_is_firmly_coercible (MOID_T *p, MOID_T *q, int deflex) +{ + if (a68_is_equal_modes (p, q, deflex)) + return true; + else if (q == M_ROWS && a68_is_rows_type (p)) + return true; + else if (a68_is_unitable (p, q, deflex)) + return true; + else if (a68_is_deprefable (p)) + return a68_is_firmly_coercible (a68_depref_once (p), q, deflex); + else + return false; +} + +/* Whether firm. */ + +bool +a68_is_firm (MOID_T *p, MOID_T *q) +{ + return (a68_is_firmly_coercible (p, q, SAFE_DEFLEXING) + || a68_is_firmly_coercible (q, p, SAFE_DEFLEXING)); +} + +/* Whether P widens to Q. + + This function returns: + + The destination mode Q if P, or + Some other mode which is an intermediate step from P to Q, or + NO_MOID if P cannot be widened to Q. + + This means that if P is known to widen to Q (a68_is_widenable (P,Q) return + true) this function can be invoked repeteadly and it will eventually return + Q. */ + +MOID_T * +a68_widens_to (MOID_T *p, MOID_T *q) +{ + if (p == M_INT) + { + if (q == M_REAL || q == M_COMPLEX) + { + return M_REAL; + } + else + { + return NO_MOID; + } + } + else if (p == M_LONG_INT) + { + if (q == M_LONG_REAL) + { + return M_LONG_REAL; + } + else + { + return NO_MOID; + } + } + else if (p == M_LONG_LONG_INT) + { + if (q == M_LONG_LONG_REAL || q == M_LONG_LONG_COMPLEX) + return M_LONG_LONG_REAL; + else + return NO_MOID; + } + else if (p == M_REAL) + { + if (q == M_COMPLEX) + { + return M_COMPLEX; + } + else + { + return NO_MOID; + } + } + else if (p == M_LONG_REAL) + { + if (q == M_LONG_COMPLEX) + return M_LONG_COMPLEX; + else + return NO_MOID; + } + else if (p == M_LONG_LONG_REAL) + { + if (q == M_LONG_LONG_COMPLEX) + return M_LONG_LONG_COMPLEX; + else + return NO_MOID; + } + else if (p == M_BITS) + { + if (q == M_ROW_BOOL) + return M_ROW_BOOL; + else if (q == M_FLEX_ROW_BOOL) + return M_FLEX_ROW_BOOL; + else + return NO_MOID; + } + else if (p == M_SHORT_BITS) + { + if (q == M_ROW_BOOL) + return M_ROW_BOOL; + else if (q == M_FLEX_ROW_BOOL) + return M_FLEX_ROW_BOOL; + else + return NO_MOID; + } + else if (p == M_SHORT_SHORT_BITS) + { + if (q == M_ROW_BOOL) + return M_ROW_BOOL; + else if (q == M_FLEX_ROW_BOOL) + return M_FLEX_ROW_BOOL; + else + return NO_MOID; + } + else if (p == M_LONG_BITS) + { + if (q == M_ROW_BOOL) + return M_ROW_BOOL; + else if (q == M_FLEX_ROW_BOOL) + return M_FLEX_ROW_BOOL; + else + return NO_MOID; + } + else if (p == M_LONG_LONG_BITS) + { + if (q == M_ROW_BOOL) + return M_ROW_BOOL; + else if (q == M_FLEX_ROW_BOOL) + return M_FLEX_ROW_BOOL; + else + return NO_MOID; + } + else if (p == M_BYTES && q == M_ROW_CHAR) + return M_ROW_CHAR; + else if (p == M_LONG_BYTES && q == M_ROW_CHAR) + return M_ROW_CHAR; + else if (p == M_BYTES && q == M_FLEX_ROW_CHAR) + return M_FLEX_ROW_CHAR; + else if (p == M_LONG_BYTES && q == M_FLEX_ROW_CHAR) + return M_FLEX_ROW_CHAR; + else + return NO_MOID; +} + +/* Whether P widens to Q. */ + +bool +a68_is_widenable (MOID_T *p, MOID_T *q) +{ + MOID_T *z = a68_widens_to (p, q); + + if (z != NO_MOID) + return (z == q ? true : a68_is_widenable (z, q)); + else + return false; +} + +/* Whether P is a REF ROW. */ + +bool +a68_is_ref_row (MOID_T *p) +{ + return (NAME (p) != NO_MOID ? IS_ROW (DEFLEX (SUB (p))) : false); +} + +/* Whether strong name. */ + +bool +a68_is_strong_name (MOID_T *p, MOID_T *q) +{ + if (p == q) + return true; + else if (a68_is_ref_row (q)) + return a68_is_strong_name (p, NAME (q)); + else + return false; +} + +/* Whether strong slice. */ + +bool +a68_is_strong_slice (MOID_T *p, MOID_T *q) +{ + if (p == q || a68_is_widenable (p, q)) + return true; + else if (SLICE (q) != NO_MOID) + return a68_is_strong_slice (p, SLICE (q)); + else if (IS_FLEX (q)) + return a68_is_strong_slice (p, SUB (q)); + else if (a68_is_ref_row (q)) + return a68_is_strong_name (p, q); + else + return false; +} + +/* Whether strongly coercible. */ + +bool +a68_is_strongly_coercible (MOID_T *p, MOID_T *q, int deflex) +{ + /* Keep this sequence of statements. */ + if (a68_is_equal_modes (p, q, deflex)) + return true; + else if (q == M_VOID) + return true; + else if ((q == M_SIMPLIN || q == M_ROW_SIMPLIN) && a68_is_readable_mode (p)) + return true; + else if (q == M_ROWS && a68_is_rows_type (p)) + return true; + else if (a68_is_unitable (p, a68_derow (q), deflex)) + return true; + + if (a68_is_ref_row (q) && a68_is_strong_name (p, q)) + return true; + else if (SLICE (q) != NO_MOID && a68_is_strong_slice (p, q)) + return true; + else if (IS_FLEX (q) && a68_is_strong_slice (p, q)) + return true; + else if (a68_is_widenable (p, q)) + return true; + else if (a68_is_deprefable (p)) + return a68_is_strongly_coercible (a68_depref_once (p), q, deflex); + else if (q == M_SIMPLOUT || q == M_ROW_SIMPLOUT) + return a68_is_printable_mode (p); + else + return false; +} + +/* Basic coercions. */ + +bool +a68_basic_coercions (MOID_T *p, MOID_T *q, int c, int deflex) +{ + if (a68_is_equal_modes (p, q, deflex)) + return true; + else if (c == NO_SORT) + return (p == q); + else if (c == SOFT) + return a68_is_softly_coercible (p, q, deflex); + else if (c == WEAK) + return a68_is_weakly_coercible (p, q, deflex); + else if (c == MEEK) + return a68_is_meekly_coercible (p, q, deflex); + else if (c == FIRM) + return a68_is_firmly_coercible (p, q, deflex); + else if (c == STRONG) + return a68_is_strongly_coercible (p, q, deflex); + else + return false; +} + +/* Whether coercible stowed. */ + +bool +a68_is_coercible_stowed (MOID_T *p, MOID_T *q, int c, int deflex) +{ + if (c != STRONG) + /* Such construct is always in a strong position, is it not? */ + return false; + else if (q == M_VOID) + return true; + else if (IS_FLEX (q)) + { + bool j = true; + + for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u)) + j &= a68_is_coercible (MOID (u), SLICE (SUB (q)), c, deflex); + return j; + } + else if (IS_ROW (q)) + { + bool j = true; + + for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u)) + j &= a68_is_coercible (MOID (u), SLICE (q), c, deflex); + return j; + } + else if (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL)) + { + if (DIM (p) != DIM (q)) + return false; + else + { + PACK_T *u = PACK (p), *v = PACK (q); + bool j = true; + + while (u != NO_PACK && v != NO_PACK && j) + { + j &= a68_is_coercible (MOID (u), MOID (v), c, deflex); + FORWARD (u); + FORWARD (v); + } + return j; + } + } + else + return false; +} + +/* Whether coercible series. */ + +bool +a68_is_coercible_series (MOID_T *p, MOID_T *q, int c, int deflex) +{ + if (c == NO_SORT) + return false; + else if (p == NO_MOID || q == NO_MOID) + return false; + else if (IS (p, SERIES_MODE) && PACK (p) == NO_PACK) + return false; + else if (IS (q, SERIES_MODE) && PACK (q) == NO_PACK) + return false; + else if (PACK (p) == NO_PACK) + return a68_is_coercible (p, q, c, deflex); + else + { + bool j = true; + + for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u)) + { + if (MOID (u) != NO_MOID) + j &= a68_is_coercible (MOID (u), q, c, deflex); + } + return j; + } +} + +/* Whether P can be coerced to Q in a C context. + + If P is a STOWED modes serie (A, B, ...) and Q is a routine mode like `proc + (X, Y, ...)' then this routine determines whether A can be coerced to X, B + to Y, etc. */ + +bool +a68_is_coercible (MOID_T *p, MOID_T *q, int c, int deflex) +{ + if (a68_is_mode_isnt_well (p) || a68_is_mode_isnt_well (q)) + return true; + else if (a68_is_equal_modes (p, q, deflex)) + return true; + else if (p == M_HIP) + return true; + else if (IS (p, STOWED_MODE)) + return a68_is_coercible_stowed (p, q, c, deflex); + else if (IS (p, SERIES_MODE)) + return a68_is_coercible_series (p, q, c, deflex); + else if (p == M_VACUUM && IS_ROW (DEFLEX (q))) + return true; + else + return a68_basic_coercions (p, q, c, deflex); +} + +/* Whether coercible in context. */ + +bool +a68_is_coercible_in_context (SOID_T *p, SOID_T *q, int deflex) +{ + if (SORT (p) != SORT (q)) + return false; + else if (MOID (p) == MOID (q)) + return true; + else + return a68_is_coercible (MOID (p), MOID (q), SORT (q), deflex); +} + +/* Whether list Y is balanced. */ + +bool +a68_is_balanced (NODE_T *n, SOID_T *y, int sort) +{ + if (sort == STRONG) + return true; + else + { + bool k = false; + + for (; y != NO_SOID && !k; FORWARD (y)) + k = (!IS (MOID (y), STOWED_MODE)); + + if (k == false) + a68_error (n, "construct has no unique mode"); + return k; + } +} + +/* A moid from M to which all other members can be coerced. + If no fulcrum of the balance is found, return NO_MOID. */ + +MOID_T * +a68_get_balanced_mode_or_no_mode (MOID_T *m, int sort, bool return_depreffed, int deflex) +{ + MOID_T *common_moid = NO_MOID; + + if (m != NO_MOID && !a68_is_mode_isnt_well (m) && IS (m, UNION_SYMBOL)) + { + int depref_level; + bool siga = true; + /* Test for increasing depreffing. */ + for (depref_level = 0; siga; depref_level++) + { + siga = false; + /* Test the whole pack. */ + for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) + { + /* HIPs are not eligible of course. */ + if (MOID (p) != M_HIP) + { + MOID_T *candidate = MOID (p); + int k; + /* Depref as far as allowed. */ + for (k = depref_level; k > 0 && a68_is_deprefable (candidate); k--) + candidate = a68_depref_once (candidate); + /* Only need testing if all allowed deprefs succeeded. */ + if (k == 0) + { + MOID_T *to = (return_depreffed ? a68_depref_completely (candidate) : candidate); + bool all_coercible = true; + + siga = true; + for (PACK_T *q = PACK (m); q != NO_PACK && all_coercible; FORWARD (q)) + { + MOID_T *from = MOID (q); + if (p != q && from != to) + all_coercible &= a68_is_coercible (from, to, sort, deflex); + } + /* If the pack is coercible to the candidate, we mark the + candidate. We continue searching for longest series + of REF REF PROC REF. */ + if (all_coercible) + { + MOID_T *mark = (return_depreffed ? MOID (p) : candidate); + + if (common_moid == NO_MOID) + common_moid = mark; + else if (IS_FLEX (candidate) && DEFLEX (candidate) == common_moid) + /* We prefer FLEX. */ + common_moid = mark; + } + } + } + } + } + } + + return common_moid; +} + +/* A moid from M to which all other members can be coerced. + If no fulcrum of the balance is found, return M. */ + +MOID_T * +a68_get_balanced_mode (MOID_T *m, int sort, bool return_depreffed, int deflex) +{ + MOID_T *common_moid + = a68_get_balanced_mode_or_no_mode (m, sort, return_depreffed, deflex); + return common_moid == NO_MOID ? m : common_moid; +} + +/* Whether we can search a common mode from a clause or not. */ + +bool +a68_clause_allows_balancing (int att) +{ + switch (att) + { + case CLOSED_CLAUSE: + case CONDITIONAL_CLAUSE: + case CASE_CLAUSE: + case SERIAL_CLAUSE: + case CONFORMITY_CLAUSE: + return true; + } + return false; +} + +/* A unique mode from Z. */ + +MOID_T * +a68_determine_unique_mode (SOID_T *z, int deflex) +{ + if (z == NO_SOID) + return NO_MOID; + else + { + MOID_T *x = MOID (z); + + if (a68_is_mode_isnt_well (x)) + return M_ERROR; + + /* If X is a series containing one union, a68_make_united_mode will + return that union (because 'union (union (...))' is the same than + 'union (...)') and then a68_get_balanced_mode below will try to + balance the modes in that union. Not what we want. */ + if (ATTRIBUTE (x) == SERIES_MODE + && DIM (x) == 1 + && IS (MOID (PACK (x)), UNION_SYMBOL)) + return MOID (PACK (x)); + + x = a68_make_united_mode (x); + if (a68_clause_allows_balancing (ATTRIBUTE (z))) + return a68_get_balanced_mode (x, STRONG, A68_NO_DEPREF, deflex); + else + return x; + } +} + +/* Insert coercion A in the tree. */ + +void +a68_make_coercion (NODE_T *l, enum a68_attribute a, MOID_T *m) +{ + a68_make_sub (l, l, a); + MOID (l) = a68_depref_rows (MOID (l), m); +} + +/* Make widening coercion. */ + +static void +make_widening_coercion (NODE_T *n, MOID_T *p, MOID_T *q) +{ + MOID_T *z = a68_widens_to (p, q); + + a68_make_coercion (n, WIDENING, z); + if (z != q) + make_widening_coercion (n, z, q); +} + +/* Make ref rowing coercion. */ + +void +a68_make_ref_rowing_coercion (NODE_T *n, MOID_T *p, MOID_T *q) +{ + if (DEFLEX (p) != DEFLEX (q)) + { + if (a68_is_widenable (p, q)) + make_widening_coercion (n, p, q); + else if (a68_is_ref_row (q)) + { + a68_make_ref_rowing_coercion (n, p, NAME (q)); + a68_make_coercion (n, ROWING, q); + } + } +} + +/* Make rowing coercion. */ + +void +a68_make_rowing_coercion (NODE_T *n, MOID_T *p, MOID_T *q) +{ + if (DEFLEX (p) != DEFLEX (q)) + { + if (a68_is_widenable (p, q)) + make_widening_coercion (n, p, q); + else if (SLICE (q) != NO_MOID) + { + a68_make_rowing_coercion (n, p, SLICE (q)); + a68_make_coercion (n, ROWING, q); + } + else if (IS_FLEX (q)) + a68_make_rowing_coercion (n, p, SUB (q)); + else if (a68_is_ref_row (q)) + a68_make_ref_rowing_coercion (n, p, q); + } +} + +/* Make uniting coercion. */ + +void +a68_make_uniting_coercion (NODE_T *n, MOID_T *q) +{ + a68_make_coercion (n, UNITING, a68_derow (q)); + if (IS_ROW (q) || IS_FLEX (q)) + a68_make_rowing_coercion (n, a68_derow (q), q); +} + +/* Make depreffing coercion to coerce node N from mode P to mode Q in a strong + context. */ + +void +a68_make_depreffing_coercion (NODE_T *n, MOID_T *p, MOID_T *q) +{ + if (DEFLEX (p) == DEFLEX (q)) + return; + else if (q == M_SIMPLOUT && a68_is_printable_mode (p)) + a68_make_coercion (n, UNITING, q); + else if (q == M_ROW_SIMPLOUT && a68_is_printable_mode (p)) + { + a68_make_coercion (n, UNITING, M_SIMPLOUT); + a68_make_coercion (n, ROWING, M_ROW_SIMPLOUT); + } + else if (q == M_SIMPLIN && a68_is_readable_mode (p)) + a68_make_coercion (n, UNITING, q); + else if (q == M_ROW_SIMPLIN && a68_is_readable_mode (p)) + { + a68_make_coercion (n, UNITING, M_SIMPLIN); + a68_make_coercion (n, ROWING, M_ROW_SIMPLIN); + } + else if (q == M_ROWS && a68_is_rows_type (p)) + { + a68_make_coercion (n, UNITING, M_ROWS); + MOID (n) = M_ROWS; + } + else if (a68_is_widenable (p, q)) + make_widening_coercion (n, p, q); + else if (a68_is_unitable (p, a68_derow (q), SAFE_DEFLEXING)) + a68_make_uniting_coercion (n, q); + else if (a68_is_ref_row (q) && a68_is_strong_name (p, q)) + a68_make_ref_rowing_coercion (n, p, q); + else if (SLICE (q) != NO_MOID && a68_is_strong_slice (p, q)) + a68_make_rowing_coercion (n, p, q); + else if (IS_FLEX (q) && a68_is_strong_slice (p, q)) + a68_make_rowing_coercion (n, p, q); + else if (IS_REF (p)) + { + MOID_T *r = a68_depref_once (p); + a68_make_coercion (n, DEREFERENCING, r); + a68_make_depreffing_coercion (n, r, q); + } + else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) + { + MOID_T *r = SUB (p); + + a68_make_coercion (n, DEPROCEDURING, r); + a68_make_depreffing_coercion (n, r, q); + } + else if (p != q) + a68_cannot_coerce (n, p, q, NO_SORT, SKIP_DEFLEXING, 0); +} + +/* Whether p is a nonproc mode (that is voided directly). */ + +bool +a68_is_nonproc (MOID_T *p) +{ + if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) + return false; + else if (IS_REF (p)) + return a68_is_nonproc (SUB (p)); + else + return true; +} + +/* Voiden in an appropriate way. */ + +void +a68_make_void (NODE_T *p, MOID_T *q) +{ + switch (ATTRIBUTE (p)) + { + case ASSIGNATION: + case IDENTITY_RELATION: + case GENERATOR: + case CAST: + case DENOTATION: + a68_make_coercion (p, VOIDING, M_VOID); + return; + default: + break; + } + + /* MORFs are an involved case. */ + switch (ATTRIBUTE (p)) + { + case SELECTION: + case SLICE: + case ROUTINE_TEXT: + case FORMULA: + case CALL: + case IDENTIFIER: + /* A nonproc moid value is eliminated directly. */ + if (a68_is_nonproc (q)) + { + a68_make_coercion (p, VOIDING, M_VOID); + return; + } + else + { + /* Descend the chain of e.g. REF PROC .. until a nonproc moid + remains. */ + MOID_T *z = q; + + while (!a68_is_nonproc (z)) + { + if (IS_REF (z)) + a68_make_coercion (p, DEREFERENCING, SUB (z)); + if (IS (z, PROC_SYMBOL) && NODE_PACK (p) == NO_PACK) + a68_make_coercion (p, DEPROCEDURING, SUB (z)); + z = SUB (z); + } + if (z != M_VOID) + a68_make_coercion (p, VOIDING, M_VOID); + return; + } + default: + break; + } + + /* All other is voided straight away. */ + a68_make_coercion (p, VOIDING, M_VOID); +} + +/* Make strong coercion of node N from mode P to mode Q. */ + +void +a68_make_strong (NODE_T *n, MOID_T *p, MOID_T *q) +{ + if (q == M_VOID && p != M_VOID) + a68_make_void (n, p); + else + a68_make_depreffing_coercion (n, p, q); +} diff --git a/gcc/algol68/a68-moids-to-string.cc b/gcc/algol68/a68-moids-to-string.cc new file mode 100644 index 000000000000..9140329db8db --- /dev/null +++ b/gcc/algol68/a68-moids-to-string.cc @@ -0,0 +1,417 @@ +/* Pretty-print a MOID. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +/* + * A pretty printer for moids. + * + * For example "PROC (REF STRUCT (REF SELF, UNION (INT, VOID))) REF SELF" + * for a procedure yielding a pointer to an object of its own mode. + */ + +static void moid_to_string_2 (char *, MOID_T *, size_t *, NODE_T *, + bool indicant_value); + +/* Add string to MOID text. */ + +static void +add_to_moid_text (char *dst, const char *str, size_t *w) +{ + a68_bufcat (dst, str, BUFFER_SIZE); + (*w) -= strlen (str); +} + +/* Find a tag, searching symbol tables towards the root. */ + +static TAG_T * +find_indicant_global (TABLE_T * table, MOID_T * mode) +{ + if (table != NO_TABLE) + { + for (TAG_T *s = INDICANTS (table); s != NO_TAG; FORWARD (s)) + { + if (MOID (s) == mode) + return s; + } + return find_indicant_global (PREVIOUS (table), mode); + } + else + return NO_TAG; +} + +/* Pack to string. */ + +static void +pack_to_string (char *b, PACK_T *p, size_t *w, bool text, NODE_T *idf, + bool indicant_value) +{ + for (; p != NO_PACK; FORWARD (p)) + { + moid_to_string_2 (b, MOID (p), w, idf, indicant_value); + if (text) + { + if (TEXT (p) != NO_TEXT) + { + add_to_moid_text (b, " ", w); + add_to_moid_text (b, TEXT (p), w); + } + } + if (p != NO_PACK && NEXT (p) != NO_PACK) + add_to_moid_text (b, ", ", w); + } +} + +/* Moid to string 2. */ + +static void moid_to_string_2 (char *b, MOID_T *n, size_t *w, NODE_T *idf, + bool indicant_value) +{ + bool supper_stropping = (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING); + const char *strop_self = supper_stropping ? "self" : "SELF"; + const char *strop_hip = supper_stropping ? "hip" : "HIP"; + const char *strop_compl = supper_stropping ? "compl" : "COMPL"; + const char *strop_long_compl = supper_stropping ? "long compl" : "LONG COMPL"; + const char *strop_long_long_compl = supper_stropping ? "long long compl" : "LONG LONG COMPL"; + const char *strop_string = supper_stropping ? "string" : "STRING"; + const char *strop_collitem = supper_stropping ? "collitem" : "COLLITEM"; + const char *strop_simplin = supper_stropping ? "%%" : "%%"; + const char *strop_simplout = supper_stropping ? "%%" : "%%"; + const char *strop_rows = supper_stropping ? "%%" : "%%"; + const char *strop_vacuum = supper_stropping ? "%%" : "%%"; + const char *strop_long = supper_stropping ? "long" : "LONG"; + const char *strop_short = supper_stropping ? "short" : "SHORT"; + const char *strop_ref = supper_stropping ? "ref" : "REF"; + const char *strop_flex = supper_stropping ? "flex" : "FLEX"; + const char *strop_struct = supper_stropping ? "struct" : "STRUCT"; + const char *strop_union = supper_stropping ? "union" : "UNION"; + const char *strop_proc = supper_stropping ? "proc" : "PROC"; + + if (n == NO_MOID) + { + /* Oops. Should not happen. */ + add_to_moid_text (b, "null", w);; + return; + } + + /* Reference to self through REF or PROC. */ + if (a68_is_postulated (A68 (postulates), n)) + { + add_to_moid_text (b, strop_self, w); + return; + } + + /* If declared by a mode-declaration, present the indicant. */ + if (idf != NO_NODE && !IS (n, STANDARD)) + { + TAG_T *indy = find_indicant_global (TABLE (idf), n); + + if (indy != NO_TAG) + { + add_to_moid_text (b, NSYMBOL (NODE (indy)), w); + if (!indicant_value) + return; + else + add_to_moid_text (b, " = ", w); + } + } + + /* Write the standard modes. */ + if (n == M_HIP) + add_to_moid_text (b, strop_hip, w); + else if (n == M_ERROR) + add_to_moid_text (b, "ERROR", w); + else if (n == M_UNDEFINED) + add_to_moid_text (b, "unresolved mode", w); + else if (n == M_C_STRING) + add_to_moid_text (b, "C-STRING", w); + else if (n == M_COMPLEX) + add_to_moid_text (b, strop_compl, w); + else if (n == M_LONG_COMPLEX) + add_to_moid_text (b, strop_long_compl, w); + else if (n == M_LONG_LONG_COMPLEX) + add_to_moid_text (b, strop_long_long_compl, w); + else if (n == M_STRING) + add_to_moid_text (b, strop_string, w); + else if (n == M_COLLITEM) + add_to_moid_text (b, strop_collitem, w); + else if (IS (n, IN_TYPE_MODE)) + add_to_moid_text (b, strop_simplin, w); + else if (IS (n, OUT_TYPE_MODE)) + add_to_moid_text (b, strop_simplout, w); + else if (IS (n, ROWS_SYMBOL)) + add_to_moid_text (b, strop_rows, w); + else if (n == M_VACUUM) + add_to_moid_text (b, strop_vacuum, w); + else if (IS (n, VOID_SYMBOL) || IS (n, STANDARD) || IS (n, INDICANT)) + { + if (DIM (n) > 0) + { + size_t k = DIM (n); + + if ((*w) >= k * strlen ("LONG ") + strlen (NSYMBOL (NODE (n)))) + { + while (k--) + { + add_to_moid_text (b, strop_long, w); + add_to_moid_text (b, " ", w); + } + + const char *strop_symbol = a68_strop_keyword (NSYMBOL (NODE (n))); + add_to_moid_text (b, strop_symbol, w); + } + else + add_to_moid_text (b, "..", w); + } + else if (DIM (n) < 0) + { + size_t k = -DIM (n); + + if ((*w) >= k * strlen ("SHORT ") + strlen (NSYMBOL (NODE (n)))) + { + while (k--) + { + add_to_moid_text (b, strop_short, w); + add_to_moid_text (b, " ", w); + } + + const char *strop_symbol = a68_strop_keyword (NSYMBOL (NODE (n))); + add_to_moid_text (b, strop_symbol, w); + } + else + add_to_moid_text (b, "..", w); + } + else if (DIM (n) == 0) + { + const char *strop_symbol = a68_strop_keyword (NSYMBOL (NODE (n))); + add_to_moid_text (b, strop_symbol, w); + } + + /* Write compxounded modes. */ + } + else if (IS_REF (n)) + { + if ((*w) >= strlen ("REF ..")) + { + add_to_moid_text (b, strop_ref, w); + add_to_moid_text (b, " ", w); + moid_to_string_2 (b, SUB (n), w, idf, indicant_value); + } + else + { + add_to_moid_text (b, strop_ref, w); + add_to_moid_text (b, " ..", w); + } + } + else if (IS_FLEX (n)) + { + if ((*w) >= strlen ("FLEX ..")) + { + add_to_moid_text (b, strop_flex, w); + add_to_moid_text (b, " ", w); + moid_to_string_2 (b, SUB (n), w, idf, indicant_value); + } + else + { + add_to_moid_text (b, strop_flex, w); + add_to_moid_text (b, " ..", w); + } + } + else if (IS_ROW (n)) + { + size_t j = strlen ("[] ..") + (DIM (n) - 1) * strlen (","); + + if ((*w) >= j) + { + size_t k = DIM (n) - 1; + add_to_moid_text (b, "[", w); + while (k-- > 0) + add_to_moid_text (b, ",", w); + add_to_moid_text (b, "] ", w); + moid_to_string_2 (b, SUB (n), w, idf, indicant_value); + } + else if (DIM (n) == 1) + { + add_to_moid_text (b, "[] ..", w); + } + else + { + size_t k = DIM (n); + add_to_moid_text (b, "[", w); + while (k--) + add_to_moid_text (b, ",", w); + add_to_moid_text (b, "] ..", w); + } + } + else if (IS_STRUCT (n)) + { + size_t j = (strlen ("STRUCT ()") + (DIM (n) - 1) + * strlen (".., ") + strlen ("..")); + + if ((*w) >= j) + { + POSTULATE_T *save = A68 (postulates); + a68_make_postulate (&A68 (postulates), n, NO_MOID); + add_to_moid_text (b, strop_struct, w); + add_to_moid_text (b, " (", w); + pack_to_string (b, PACK (n), w, true, idf, indicant_value); + add_to_moid_text (b, ")", w); + a68_free_postulate_list (A68 (postulates), save); + A68 (postulates) = save; + } + else + { + size_t k = DIM (n); + add_to_moid_text (b, strop_struct, w); + add_to_moid_text (b, " (", w); + while (k-- > 0) + add_to_moid_text (b, ",", w); + add_to_moid_text (b, ")", w); + } + } + else if (IS_UNION (n)) + { + size_t j = (strlen ("UNION ()") + (DIM (n) - 1) + * strlen (".., ") + strlen ("..")); + + if ((*w) >= j) + { + POSTULATE_T *save = A68 (postulates); + a68_make_postulate (&A68 (postulates), n, NO_MOID); + add_to_moid_text (b, strop_union, w); + add_to_moid_text (b, " (", w); + pack_to_string (b, PACK (n), w, false, idf, indicant_value); + add_to_moid_text (b, ")", w); + a68_free_postulate_list (A68 (postulates), save); + A68 (postulates) = save; + } + else + { + size_t k = DIM (n); + add_to_moid_text (b, strop_union, w); + add_to_moid_text (b, " (", w); + while (k-- > 0) + add_to_moid_text (b, ",", w); + add_to_moid_text (b, ")", w); + } + } + else if (IS (n, PROC_SYMBOL) && DIM (n) == 0) + { + if ((*w) >= strlen ("PROC ..")) + { + add_to_moid_text (b, strop_proc, w); + add_to_moid_text (b, " ", w); + moid_to_string_2 (b, SUB (n), w, idf, indicant_value); + } + else + { + add_to_moid_text (b, strop_proc, w); + add_to_moid_text (b, " ..", w); + } + } + else if (IS (n, PROC_SYMBOL) && DIM (n) > 0) + { + size_t j = (strlen ("PROC () ..") + (DIM (n) - 1) + * strlen (".., ") + strlen ("..")); + + if ((*w) >= j) + { + POSTULATE_T *save = A68 (postulates); + a68_make_postulate (&A68 (postulates), n, NO_MOID); + add_to_moid_text (b, strop_proc, w); + add_to_moid_text (b, " (", w); + pack_to_string (b, PACK (n), w, false, idf, indicant_value); + add_to_moid_text (b, ") ", w); + moid_to_string_2 (b, SUB (n), w, idf, indicant_value); + a68_free_postulate_list (A68 (postulates), save); + A68 (postulates) = save; + } + else + { + size_t k = DIM (n); + + add_to_moid_text (b, strop_proc, w); + add_to_moid_text (b, " (", w); + while (k-- > 0) + add_to_moid_text (b, ",", w); + add_to_moid_text (b, ") ..", w); + } + } + else if (IS (n, SERIES_MODE) || IS (n, STOWED_MODE)) + { + size_t j = (strlen ("()") + (DIM (n) - 1) + * strlen (".., ") + strlen ("..")); + + if ((*w) >= j) + { + add_to_moid_text (b, "(", w); + pack_to_string (b, PACK (n), w, false, idf, indicant_value); + add_to_moid_text (b, ")", w); + } + else + { + size_t k = DIM (n); + + add_to_moid_text (b, "(", w); + while (k-- > 0) + add_to_moid_text (b, ",", w); + add_to_moid_text (b, ")", w); + } + } + else + { + char str[SMALL_BUFFER_SIZE]; + if (snprintf (str, (size_t) SMALL_BUFFER_SIZE, "\\%d", ATTRIBUTE (n)) < 0) + gcc_unreachable (); + add_to_moid_text (b, str, w); + } +} + +/* Pretty-formatted mode N; W is a measure of width. */ + +const char * +a68_moid_to_string (MOID_T *n, size_t w, NODE_T *idf, bool indicant_value) +{ +#define MAX_MTS 8 + /* We use a static buffer of MAX_MTS strings. This value 8 should be safe. + No more than MAX_MTS calls can be pending in for instance printf. Instead + we could allocate each string on the heap but that leaks memory. */ + static int mts_buff_ptr = 0; + static char mts_buff[8][BUFFER_SIZE]; + char *a = &(mts_buff[mts_buff_ptr][0]); + mts_buff_ptr++; + if (mts_buff_ptr >= MAX_MTS) + mts_buff_ptr = 0; + a[0] = '\0'; + if (w >= BUFFER_SIZE) + w = BUFFER_SIZE - 1; + A68 (postulates) = NO_POSTULATE; + if (n != NO_MOID) + moid_to_string_2 (a, n, &w, idf, indicant_value); + else + a68_bufcat (a, "null", BUFFER_SIZE); + return a; +#undef MAX_MTS +} diff --git a/gcc/algol68/a68-parser-attrs.def b/gcc/algol68/a68-parser-attrs.def new file mode 100644 index 000000000000..31fc0d91f7db --- /dev/null +++ b/gcc/algol68/a68-parser-attrs.def @@ -0,0 +1,387 @@ +/* This file contains the definitions and documentation for all the different + kind/attributes of Algol 68 parse tree nodes. + Copyright (C) 2025 Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation; either version 3, or (at your option) any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along with + GCC; see the file COPYING3. If not see . */ + +/* Please keep the entries in this file sorted alphabetically. */ + +/* Note that the textual descriptions for the nodes are used in diagnostic + messages and debug dumps. Please make sure to write them in a way you would + expect to be used in statements like "[...] near ATT". */ + +A68_ATTR(A68_PATTERN, "transput pattern") +A68_ATTR(ACCESS_CLAUSE, "access clause") +A68_ATTR(ACCESS_SYMBOL, "access-symbol") +A68_ATTR(ACTUAL_DECLARER_MARK, "actual declarer mark") +A68_ATTR(ALT_ACCESS_SYMBOL, "alt-access-symbol") +A68_ATTR(ALT_DO_PART, "alt do part") +A68_ATTR(ALT_DO_SYMBOL, "alt do symbol") +A68_ATTR(ALT_EQUALS_SYMBOL, "alt equals symbol") +A68_ATTR(ALT_FORMAL_BOUNDS_LIST, "alt formal bounds list") +A68_ATTR(ANDF_SYMBOL, "andf symbol") +A68_ATTR(AND_FUNCTION, "andf pseudo-operator") +A68_ATTR(ANONYMOUS, "anonymous") +A68_ATTR(ARGUMENT, "argument") +A68_ATTR(ARGUMENT_LIST, "argument list") +A68_ATTR(ASSERTION, "assertion") +A68_ATTR(ASSERT_SYMBOL, "assert symbol") +A68_ATTR(ASSIGNATION, "assignation") +A68_ATTR(ASSIGN_SYMBOL, "assignation symbol") +A68_ATTR(ASSIGN_TO_SYMBOL, "assign-to symbol") +A68_ATTR(AT_SYMBOL, "at symbol") +A68_ATTR(BEGIN_SYMBOL, "begin symbol") +A68_ATTR(BITS_C_PATTERN, "bits-c-pattern") +A68_ATTR(BITS_DENOTATION, "bits-denotation") +A68_ATTR(BITS_PATTERN, "bits pattern") +A68_ATTR(BITS_SYMBOL, "bits-symbol") +A68_ATTR(BOLD_COMMENT_SYMBOL, "comment delimiter") +A68_ATTR(BOLD_COMMENT_BEGIN_SYMBOL, "comment opening delimiter") +A68_ATTR(BOLD_COMMENT_END_SYMBOL, "comment closing delimiter") +A68_ATTR(BOLD_PRAGMAT_SYMBOL, "pragmat-symbol") +A68_ATTR(BOLD_TAG, "bold tag") +A68_ATTR(BOOLEAN_PATTERN, "boolean pattern") +A68_ATTR(BOOL_SYMBOL, "bool-symbol") +A68_ATTR(BOUND, "actual declarer bound") +A68_ATTR(BOUNDS, "actual declarer bounds") +A68_ATTR(BOUNDS_LIST, "actual declarer bounds list") +A68_ATTR(BRIEF_COMMENT_BEGIN_SYMBOL, "comment opening delimiter") +A68_ATTR(BRIEF_COMMENT_END_SYMBOL, "comment closing delimiter") +A68_ATTR(BRIEF_OUSE_PART, "ouse-part") +A68_ATTR(BRIEF_CONFORMITY_OUSE_PART, "ouse-part") +A68_ATTR(BRIEF_ELIF_PART, "elif-part") +A68_ATTR(BRIEF_OPERATOR_DECLARATION, "operator declaration") +A68_ATTR(BUS_SYMBOL, "bus-symbol") +A68_ATTR(BYTES_SYMBOL, "bytes-symbol") +A68_ATTR(BY_PART, "by-part") +A68_ATTR(BY_SYMBOL, "by-symbol") +A68_ATTR(CALL, "call") +A68_ATTR(CASE_CHOICE_CLAUSE, "case choice clause") +A68_ATTR(CASE_CLAUSE, "case clause") +A68_ATTR(CASE_IN_PART, "case-in-part") +A68_ATTR(CASE_OUSE_PART, "case-ouse-part") +A68_ATTR(CASE_PART, "case-part") +A68_ATTR(CASE_SYMBOL, "case-symbol") +A68_ATTR(CAST, "cast") +A68_ATTR(CHANNEL_SYMBOL, "channel-symbol") +A68_ATTR(CHAR_C_PATTERN, "char C-like pattern") +A68_ATTR(CHAR_SYMBOL, "char-symbol") +A68_ATTR(CHOICE, "choice") +A68_ATTR(CHOICE_PATTERN, "choice pattern") +A68_ATTR(CLOSED_CLAUSE, "closed clause") +A68_ATTR(CLOSE_SYMBOL, "close symbol") +A68_ATTR(COLLATERAL_CLAUSE, "collateral clause") +A68_ATTR(COLLECTION, "collection") +A68_ATTR(COLON_SYMBOL, "colon-symbol") +A68_ATTR(COMMA_SYMBOL, "comma-symbol") +A68_ATTR(COMPLEX_PATTERN, "complex pattern") +A68_ATTR(COMPLEX_SYMBOL, "complex-symbol") +A68_ATTR(COMPL_SYMBOL, "compl-symbol") +A68_ATTR(CONDITIONAL_CLAUSE, "conditional clause") +A68_ATTR(CONFORMITY_CHOICE, "conformity clause choice") +A68_ATTR(CONFORMITY_CLAUSE, "conformity clause") +A68_ATTR(CONFORMITY_IN_PART, "conformity clause in-part") +A68_ATTR(CONFORMITY_OUSE_PART, "conformity clause ouse-part") +A68_ATTR(CONSTRUCT, "construct") +A68_ATTR(DECLARATION_LIST, "list of declarations") +A68_ATTR(DECLARER, "declarer") +A68_ATTR(DEF_PART, "def-part") +A68_ATTR(DEF_SYMBOL, "def-symbol") +A68_ATTR(DEFINING_IDENTIFIER, "defining identifier") +A68_ATTR(DEFINING_INDICANT, "defining mode") +A68_ATTR(DEFINING_OPERATOR, "defining operator") +A68_ATTR(DEFINING_MODULE_INDICANT, "defining module indicant") +A68_ATTR(DENOTATION, "denotation") +A68_ATTR(DEPROCEDURING, "deproceduring coercion") +A68_ATTR(DEREFERENCING, "dereferencing coercion") +A68_ATTR(DO_PART, "do-part") +A68_ATTR(DO_SYMBOL, "do-symbol") +A68_ATTR(DYNAMIC_REPLICATOR, "format dynamic replicator") +A68_ATTR(EGG_SYMBOL, "egg-symbol") +A68_ATTR(ELIF_IF_PART, "elif if-part") +A68_ATTR(ELIF_PART, "elif-part") +A68_ATTR(ELIF_SYMBOL, "elif-symbol") +A68_ATTR(ELSE_BAR_SYMBOL, "else-bar-symbol") +A68_ATTR(ELSE_OPEN_PART, "else-open-part") +A68_ATTR(ELSE_PART, "else-part") +A68_ATTR(ELSE_SYMBOL, "else-symbol") +A68_ATTR(EMPTY_SYMBOL, "empty-symbol") +A68_ATTR(ENCLOSED_CLAUSE, "enclosed clause") +A68_ATTR(END_SYMBOL, "end-symbol") +A68_ATTR(ENQUIRY_CLAUSE, "enquiry clause") +A68_ATTR(EQUALS_SYMBOL, "equals-symbol") +A68_ATTR(ERROR, "error node") +A68_ATTR(ERROR_IDENTIFIER, "error-identifier") +A68_ATTR(ESAC_SYMBOL, "esac-symbol") +A68_ATTR(EXIT_SYMBOL, "exit-symbol") +A68_ATTR(EXPONENT_FRAME, "exponent-frame") +A68_ATTR(FALSE_SYMBOL, "false-symbol") +A68_ATTR(FED_SYMBOL, "fed-symbol") +A68_ATTR(FIELD, "struct field") +A68_ATTR(FIELD_IDENTIFIER, "field-identifier") +A68_ATTR(FILE_SYMBOL, "file-symbol") +A68_ATTR(FIRM, "firm context") +A68_ATTR(FIXED_C_PATTERN, "fixed-c-pattern") +A68_ATTR(FI_SYMBOL, "fi-symbol") +A68_ATTR(FLEX_SYMBOL, "flex-symbol") +A68_ATTR(FLOAT_C_PATTERN, "float C format pattern") +A68_ATTR(FORMAL_BOUNDS, "formal declarer bounds") +A68_ATTR(FORMAL_BOUNDS_LIST, "list of formal declarer bounds") +A68_ATTR(FORMAL_DECLARERS, "formal declarers") +A68_ATTR(FORMAL_DECLARERS_LIST, "list of formal declarers") +A68_ATTR(FORMAL_DECLARER_MARK, "formal declarer mark") +A68_ATTR(FORMAL_NEST_SYMBOL, "formal-nest-symbol") +A68_ATTR(FORMULA, "formula") +A68_ATTR(FOR_PART, "for-part") +A68_ATTR(FOR_SYMBOL, "for-symbol") +A68_ATTR(FORMAT_CLOSE_SYMBOL, "format-close-symbol") +A68_ATTR(FORMAT_DELIMITER_SYMBOL, "format-delimiter-symbol") +A68_ATTR(FORMAT_IDENTIFIER, "format identifier") +A68_ATTR(FORMAT_A_FRAME, "format A-frame") +A68_ATTR(FORMAT_D_FRAME, "format D-frame") +A68_ATTR(FORMAT_E_FRAME, "format E-frame") +A68_ATTR(FORMAT_I_FRAME, "format I-frame") +A68_ATTR(FORMAT_ITEM_A, "format item-A") +A68_ATTR(FORMAT_ITEM_B, "format item-B") +A68_ATTR(FORMAT_ITEM_C, "format item-C") +A68_ATTR(FORMAT_ITEM_D, "format item-D") +A68_ATTR(FORMAT_ITEM_E, "format item-E") +A68_ATTR(FORMAT_ITEM_F, "format item-F") +A68_ATTR(FORMAT_ITEM_G, "format item-G") +A68_ATTR(FORMAT_ITEM_H, "format item-H") +A68_ATTR(FORMAT_ITEM_I, "format item-I") +A68_ATTR(FORMAT_ITEM_J, "format item-J") +A68_ATTR(FORMAT_ITEM_K, "format item-K") +A68_ATTR(FORMAT_ITEM_L, "format item-L") +A68_ATTR(FORMAT_ITEM_M, "format item-M") +A68_ATTR(FORMAT_ITEM_N, "format item-N") +A68_ATTR(FORMAT_ITEM_O, "format item-O") +A68_ATTR(FORMAT_ITEM_P, "format item-P") +A68_ATTR(FORMAT_ITEM_Q, "format item-Q") +A68_ATTR(FORMAT_ITEM_R, "format item-R") +A68_ATTR(FORMAT_ITEM_S, "format item-S") +A68_ATTR(FORMAT_ITEM_T, "format item-T") +A68_ATTR(FORMAT_ITEM_U, "format item-U") +A68_ATTR(FORMAT_ITEM_V, "format item-V") +A68_ATTR(FORMAT_ITEM_W, "format item-W") +A68_ATTR(FORMAT_ITEM_X, "format item-X") +A68_ATTR(FORMAT_ITEM_Y, "format item-Y") +A68_ATTR(FORMAT_ITEM_Z, "format item-Z") +A68_ATTR(FORMAT_ITEM_ESCAPE, "format item escape") +A68_ATTR(FORMAT_ITEM_MINUS, "format item -") +A68_ATTR(FORMAT_ITEM_PLUS, "format item +") +A68_ATTR(FORMAT_ITEM_POINT, "format item .") +A68_ATTR(FORMAT_OPEN_SYMBOL, "format-open-symbol") +A68_ATTR(FORMAT_PATTERN, "format pattern") +A68_ATTR(FORMAT_POINT_FRAME, "format point frame") +A68_ATTR(FORMAT_SYMBOL, "format-symbol") +A68_ATTR(FORMAT_TEXT, "format text") +A68_ATTR(FORMAT_Z_FRAME, "format Z frame") +A68_ATTR(FROM_PART, "from-part") +A68_ATTR(FROM_SYMBOL, "from-symbol") +A68_ATTR(GENERAL_C_PATTERN, "general C-like pattern") +A68_ATTR(GENERAL_PATTERN, "general pattern") +A68_ATTR(GENERATOR, "generator") +A68_ATTR(GENERIC_ARGUMENT, "generic argument") +A68_ATTR(GENERIC_ARGUMENT_LIST, "generic argument list") +A68_ATTR(GOTO_SYMBOL, "goto-symbol") +A68_ATTR(GO_SYMBOL, "go-symbol") +A68_ATTR(GUARDED_CONDITIONAL_CLAUSE, "guarded conditional clause") +A68_ATTR(GUARDED_LOOP_CLAUSE, "guarded loop clause") +A68_ATTR(HEAP_SYMBOL, "heap-symbol") +A68_ATTR(IDENTIFIER, "identifier") +A68_ATTR(IDENTIFIER_WITH_UNDERSCORES, "identifier with underscores") +A68_ATTR(IDENTITY_DECLARATION, "identity declaration") +A68_ATTR(IDENTITY_RELATION, "identity relation") +A68_ATTR(IF_PART, "if-part") +A68_ATTR(IF_SYMBOL, "if-symbol") +A68_ATTR(INDICANT, "indicant") +A68_ATTR(INITIALISER_SERIES, "initialiser series") +A68_ATTR(INSERTION, "insertion") +A68_ATTR(INTEGRAL_C_PATTERN, "integral C-like pattern") +A68_ATTR(INTEGRAL_MOULD, "integral mould") +A68_ATTR(INTEGRAL_PATTERN, "integral pattern") +A68_ATTR(INT_DENOTATION, "integral denotation") +A68_ATTR(INT_SYMBOL, "int-symbol") +A68_ATTR(IN_SYMBOL, "in-symbol") +A68_ATTR(IN_TYPE_MODE, "in type mode") +A68_ATTR(ISNT_SYMBOL, "isnt-symbol") +A68_ATTR(IS_SYMBOL, "is-symbol") +A68_ATTR(JUMP, "jump") +A68_ATTR(KEYWORD, "keyword") +A68_ATTR(LABEL, "label") +A68_ATTR(LABELED_UNIT, "labeled unit") +A68_ATTR(LABEL_IDENTIFIER, "label identifier") +A68_ATTR(LABEL_SEQUENCE, "label sequence") +A68_ATTR(LITERAL, "literal") +A68_ATTR(LOCAL_LABEL, "local label") +A68_ATTR(LOC_SYMBOL, "loc-symbol") +A68_ATTR(LONGETY, "longsety") +A68_ATTR(LONG_SYMBOL, "long-symbol") +A68_ATTR(LOOP_CLAUSE, "loop clause") +A68_ATTR(LOOP_IDENTIFIER, "loop identifier") +A68_ATTR(MAIN_SYMBOL, "main-symbol") +A68_ATTR(MEEK, "meek context") +A68_ATTR(MODE_BITS, "mode bits") +A68_ATTR(MODE_BOOL, "mode bool") +A68_ATTR(MODE_BYTES, "mode bytes") +A68_ATTR(MODE_CHAR, "mode char") +A68_ATTR(MODE_COMPLEX, "mode complex") +A68_ATTR(MODE_DECLARATION, "mode declaration") +A68_ATTR(MODE_FILE, "mode file") +A68_ATTR(MODE_FORMAT, "mode format") +A68_ATTR(A68_MODE_INT, "mode int") +A68_ATTR(MODE_LONG_LONG_BITS, "mode long long bits") +A68_ATTR(MODE_LONG_LONG_COMPLEX, "mode long long complex") +A68_ATTR(MODE_LONG_LONG_INT, "mode long long int") +A68_ATTR(MODE_LONG_LONG_REAL, "mode long long real") +A68_ATTR(MODE_LONG_BITS, "mode long bits") +A68_ATTR(MODE_LONG_BYTES, "mode long bytes") +A68_ATTR(MODE_LONG_COMPLEX, "mode long complex") +A68_ATTR(MODE_LONG_INT, "mode long int") +A68_ATTR(MODE_LONG_REAL, "mode long real") +A68_ATTR(MODE_NO_CHECK, "mode no check") +A68_ATTR(MODE_REAL, "mode real") +A68_ATTR(MODE_SYMBOL, "mode-symbol") +A68_ATTR(MODULE_INDICANT, "module indicant") +A68_ATTR(MODULE_DECLARATION, "module-declaration") +A68_ATTR(MODULE_SYMBOL, "module-symbol") +A68_ATTR(MODULE_TEXT, "module text") +A68_ATTR(MONADIC_FORMULA, "monadic formula") +A68_ATTR(MONAD_SEQUENCE, "monad sequence") +A68_ATTR(NIHIL, "nihil") +A68_ATTR(NIL_SYMBOL, "nil-symbol") +A68_ATTR(NORMAL_IDENTIFIER, "normal identifier") +A68_ATTR(NO_SORT, "no sort") +A68_ATTR(OD_SYMBOL, "od-symbol") +A68_ATTR(OF_SYMBOL, "of-symbol") +A68_ATTR(OPEN_PART, "open part") +A68_ATTR(OPEN_SYMBOL, "open-symbol") +A68_ATTR(OPERATOR, "operator") +A68_ATTR(OPERATOR_DECLARATION, "operator declaration") +A68_ATTR(OPERATOR_PLAN, "operator plan") +A68_ATTR(OP_SYMBOL, "op-symbol") +A68_ATTR(ORF_SYMBOL, "orf-symbol") +A68_ATTR(OR_FUNCTION, "orel pseudo-operator") +A68_ATTR(OUSE_PART, "ouse-part") +A68_ATTR(OUSE_SYMBOL, "ouse-symbol") +A68_ATTR(OUT_PART, "out-part") +A68_ATTR(OUT_SYMBOL, "out-symbol") +A68_ATTR(OUT_TYPE_MODE, "out type mode") +A68_ATTR(PACKET, "packet") +A68_ATTR(PARALLEL_CLAUSE, "parallel clause") +A68_ATTR(PARAMETER, "parameter") +A68_ATTR(PARAMETER_IDENTIFIER, "parameter identifier") +A68_ATTR(PARAMETER_LIST, "parameter list") +A68_ATTR(PARAMETER_PACK, "parameter pack") +A68_ATTR(PARTICULAR_PROGRAM, "particular program") +A68_ATTR(PAR_SYMBOL, "par-symbol") +A68_ATTR(PICTURE, "format picture") +A68_ATTR(PICTURE_LIST, "format picture list") +A68_ATTR(PIPE_SYMBOL, "pipe-symbol") +A68_ATTR(POINT_SYMBOL, "point-symbol") +A68_ATTR(POSTLUDE_PART, "postlude-part") +A68_ATTR(POSTLUDE_SYMBOL, "postlude-symbol") +A68_ATTR(PRELUDE_PACKET, "prelude-packet") +A68_ATTR(PRIMARY, "primary") +A68_ATTR(PRIORITY, "operator priority") +A68_ATTR(PRIORITY_DECLARATION, "operator priority declaration") +A68_ATTR(PRIO_SYMBOL, "prio-symbol") +A68_ATTR(PROCEDURE_DECLARATION, "procedure declaration") +A68_ATTR(PROCEDURE_VARIABLE_DECLARATION, "procedure variable declaration") +A68_ATTR(PROCEDURING, "proceduring coercion") +A68_ATTR(PROC_SYMBOL, "proc-symbol") +A68_ATTR(PUBLIC_SYMBOL, "public-symbol") +A68_ATTR(QUALIFIER, "qualifier") +A68_ATTR(RADIX_FRAME, "radix frame") +A68_ATTR(REAL_DENOTATION, "real denotation") +A68_ATTR(REAL_PATTERN, "real pattern") +A68_ATTR(REAL_SYMBOL, "real-symbol") +A68_ATTR(REF_SYMBOL, "ref-symbol") +A68_ATTR(REPLICATOR, "format replicator") +A68_ATTR(REVELATION, "revelation") +A68_ATTR(REVELATION_PART, "revelation-part") +A68_ATTR(ROUTINE_TEXT, "routine text") +A68_ATTR(ROUTINE_UNIT, "routine unit") +A68_ATTR(ROWING, "rowing coercion") +A68_ATTR(ROWS_SYMBOL, "rows-symbol") +A68_ATTR(ROW_CHAR_DENOTATION, "row of chars denotation") +A68_ATTR(ROW_SYMBOL, "row-symbol") +A68_ATTR(SECONDARY, "secondary") +A68_ATTR(SELECTION, "selection") +A68_ATTR(SELECTOR, "selector") +A68_ATTR(SEMA_SYMBOL, "sema-symbol") +A68_ATTR(SEMI_SYMBOL, "semi-symbol") +A68_ATTR(SERIAL_CLAUSE, "serial clause") +A68_ATTR(SERIES_MODE, "series mode") +A68_ATTR(SHORTETY, "shortsety") +A68_ATTR(SHORT_SYMBOL, "short-symbol") +A68_ATTR(SIGN_MOULD, "sign mould") +A68_ATTR(SKIP, "skip unit") +A68_ATTR(SKIP_SYMBOL, "skip-symbol") +A68_ATTR(SLICE, "slice") +A68_ATTR(SOFT, "soft context") +A68_ATTR(SOME_CLAUSE, "some clause") +A68_ATTR(SPECIFICATION, "specification") +A68_ATTR(SPECIFIED_UNIT, "specified unit") +A68_ATTR(SPECIFIED_UNIT_LIST, "specified unit list") +A68_ATTR(SPECIFIED_UNIT_UNIT, "specified unit unit") +A68_ATTR(SPECIFIER, "specifier") +A68_ATTR(SPECIFIER_IDENTIFIER, "specifier identifier") +A68_ATTR(STANDARD, "standard") +A68_ATTR(STATIC_REPLICATOR, "static replicator") +A68_ATTR(STATIC_SYMBOL, "static-symbol") +A68_ATTR(STOWED_MODE, "stowed mode") +A68_ATTR(STRING_C_PATTERN, "string C-like pattern") +A68_ATTR(STRING_PATTERN, "string pattern") +A68_ATTR(STRING_SYMBOL, "string-symbol") +A68_ATTR(STRONG, "strong context") +A68_ATTR(STRUCTURED_FIELD, "structured field") +A68_ATTR(STRUCTURED_FIELD_LIST, "structured field list") +A68_ATTR(STRUCTURE_PACK, "structure pack") +A68_ATTR(STRUCT_SYMBOL, "struct-symbol") +A68_ATTR(STYLE_II_COMMENT_SYMBOL, "comment delimiter") +A68_ATTR(STYLE_I_COMMENT_SYMBOL, "comment delimiter") +A68_ATTR(STYLE_I_PRAGMAT_SYMBOL, "pragmat-symbol") +A68_ATTR(SUB_SYMBOL, "sub-symbol") +A68_ATTR(SUB_UNIT, "sub unit") +A68_ATTR(TERTIARY, "tertiary") +A68_ATTR(THEN_BAR_SYMBOL, "then-bar-symbol") +A68_ATTR(THEN_PART, "then-part") +A68_ATTR(THEN_SYMBOL, "then-symbol") +A68_ATTR(TO_PART, "to-part") +A68_ATTR(TO_SYMBOL, "to-symbol") +A68_ATTR(TRIMMER, "trimmer") +A68_ATTR(TRUE_SYMBOL, "true-symbol") +A68_ATTR(UNION_DECLARER_LIST, "union declarer list") +A68_ATTR(UNION_PACK, "union pack") +A68_ATTR(UNION_SYMBOL, "union-symbol") +A68_ATTR(UNIT, "unit") +A68_ATTR(UNITING, "uniting coercion") +A68_ATTR(UNIT_LIST, "unit list") +A68_ATTR(UNIT_SERIES, "unit series") +A68_ATTR(VARIABLE_DECLARATION, "variable declaration") +A68_ATTR(VIRTUAL_DECLARER_MARK, "virtual declarer mark") +A68_ATTR(VOIDING, "voiding coercion") +A68_ATTR(VOID_SYMBOL, "void-symbol") +A68_ATTR(WEAK, "weak context") +A68_ATTR(WHILE_PART, "while-part") +A68_ATTR(WHILE_SYMBOL, "while-symbol") +A68_ATTR(WIDENING, "widening coercion") +A68_ATTR(WILDCARD, "wildcard") + +/* +Local variables: +mode:c +End: +*/ diff --git a/gcc/algol68/a68-parser-bottom-up.cc b/gcc/algol68/a68-parser-bottom-up.cc new file mode 100644 index 000000000000..a87a94007b77 --- /dev/null +++ b/gcc/algol68/a68-parser-bottom-up.cc @@ -0,0 +1,3026 @@ +/* Hand-coded bottom-up parser for Algol 68. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* This is a Mailloux-type parser, in the sense that it scans a "phrase" for + definitions needed for parsing, and therefore allows for tags to be used + before they are defined, which gives some freedom in top-down programming. + + B. J. Mailloux. On the implementation of Algol 68. + Thesis, Universiteit van Amsterdam (Mathematisch Centrum) [1968]. + + Technically, Mailloux's approach renders the two-level grammar LALR. This + is the bottom-up parser that resolves the structure of the program. */ + +/* *** Thou who adventure here, please read this *** + + On parse trees, phrases and branches + ------------------------------------ + + The Algol 68 parser operates on parse trees in which sibling nodes are + linked together in "phrases" via NEXT and PREVIOUS pointers, and sub-trees + or "branches" start at SUB pointers. For example, in the parse tree + + a + | + b - c - d - e + | + f - g - h - i + | + j + + 'a' is the root of the tree. + 'a', 'b - c - d - e', 'f - g - h -i' and 'j' are phrases. + 'a', 'c' and 'i' introduce branches to sub trees via their SUB pointer. + + From the scanner to the bottom-up parser + ---------------------------------------- + + The lexical analyzer transforms the textual input programs into a single + phrase with all the tokens. For example, the program text + + begin if A then B fi; + C + end; + D + + will be turned by the lexical analyzer into the following parse tree, which + in fact is a list conforming a single phrase: + + begin - if - A - then - B - fi - semi - C - end - semi - D + + This parse tree is then handed over to the top-down parser, which provides + some initial structure and turns the single phrase into an actual tree: + + begin - semi - D + | + begin - if - then - fi - end - semi - C - end + | | + | then - B + if - A + + Note how branches have been created for the closed clause and for the + different parts of the conditional clause. The same would have happened for + loop parts and case parts as well, but it is important to note that the role + of the top-down parser doesn't handle the conditional, loop or case clauses + themselves: it just branches the parts of these clauses that introduce + ranges. Taking care of structuring the clauses is precisely the main role of + the bottom-up parser. + + The bottom-up parser + -------------------- + + The bottom-up parser is given a parse tree like the one above, partially + structured in phrases by the top-down parser. The bottom-up parser then + proceeds from the root-node using two basic operations: + + - reduce a phrase, implemented by 'reduce'. + - reduce a sub-phrase starting at a branch, implemented by 'reduce_branch'. +*/ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" + +#include "a68.h" + +/* Bottom-up parser, reduces all constructs. */ + + +/* Maximum number of errors the bottom-up parser will try to recover from and + save diagnostics for. */ + +#define MAX_ERRORS 5 + +/* Forward declarations of some of the functions defined below. */ + +static void reduce_branch (NODE_T *q, a68_attribute expect); +static void recover_from_error (NODE_T * p, enum a68_attribute expect, bool suppress); +static void reduce_declarers (NODE_T *p, enum a68_attribute expect); +static void reduce_primary_parts (NODE_T *p, enum a68_attribute expect); +static void reduce_primaries (NODE_T *p, enum a68_attribute expect); +static void reduce_format_texts (NODE_T *p); +static void reduce_secondaries (NODE_T *p); +static void reduce_formulae (NODE_T * p); +static void reduce_tertiaries (NODE_T *p); +static void reduce_right_to_left_constructs (NODE_T *p); +static void reduce_units (NODE_T * p); +static void reduce_erroneous_units (NODE_T *p); +static void reduce_generic_arguments (NODE_T *p); +static void reduce_bounds (NODE_T *p); +static void reduce_serial_clauses (NODE_T *p); +static void reduce_enquiry_clauses (NODE_T *p); +static void reduce_collateral_clauses (NODE_T *p); +static void reduce_arguments (NODE_T *p); +static void reduce_enclosed_clauses (NODE_T *q, enum a68_attribute expect); +static void reduce_basic_declarations (NODE_T *p); +static void reduce_declaration_lists (NODE_T *p); +static void reduce_module_texts (NODE_T *p); +static void reduce_module_text_parts (NODE_T *p); +static NODE_T *reduce_dyadic (NODE_T *p, int u); + +/* Whether a series is serial or collateral. */ + +static enum a68_attribute +serial_or_collateral (NODE_T *p) +{ + int semis = 0, commas = 0, exits = 0; + for (NODE_T *q = p; q != NO_NODE; q = NEXT (q)) + { + if (IS (q, COMMA_SYMBOL)) + commas++; + else if (IS (q, SEMI_SYMBOL)) + semis++; + else if (IS (q, EXIT_SYMBOL)) + exits++; + } + + if (semis == 0 && exits == 0 && commas > 0) + return COLLATERAL_CLAUSE; + else if ((semis > 0 || exits > 0) && commas == 0) + return SERIAL_CLAUSE; + else if (semis == 0 && exits == 0 && commas == 0) + return SERIAL_CLAUSE; + else + /* Heuristic guess to give intelligible error message. */ + return (semis + exits >= commas) ? SERIAL_CLAUSE : COLLATERAL_CLAUSE; +} + +/* Insert a node with attribute "a" after "p". */ + +static void +pad_node (NODE_T *p, enum a68_attribute a) +{ + /* This is used to fill information that Algol 68 does not require to be + present. Filling in gives one format for such construct; this helps later + passes. */ + NODE_T *z = a68_new_node (); + *z = *p; + if (GINFO (p) != NO_GINFO) + GINFO (z) = a68_new_genie_info (); + PREVIOUS (z) = p; + SUB (z) = NO_NODE; + ATTRIBUTE (z) = a; + MOID (z) = NO_MOID; + if (NEXT (z) != NO_NODE) + PREVIOUS (NEXT (z)) = z; + NEXT (p) = z; +} + +/* Diagnose extensions. */ + +static void +a68_extension (NODE_T *p) +{ + a68_warning (p, OPT_Wextensions, "ast node is an extension"); +} + +/* Diagnose for clauses not yielding a value. */ + +static void +empty_clause (NODE_T *p) +{ + a68_error (p, "clause does not yield a value"); +} + +/* Diagnose for missing symbol. */ + +static void +strange_tokens (NODE_T *p) +{ + NODE_T *q = ((p != NO_NODE && NEXT (p) != NO_NODE) ? NEXT (p) : p); + a68_error (q, "possibly a missing or erroneous symbol nearby"); +} + +/* Diagnose for strange separator. */ + +static void +strange_separator (NODE_T *p) +{ + NODE_T *q = ((p != NO_NODE && NEXT (p) != NO_NODE) ? NEXT (p) : p); + a68_error (q, "possibly a missing or erroneous separator nearby"); +} + +/* If match then reduce a sentence, the core bottom-up parser routine. The + reduction of a sequence of nodes stating at P: + + P - A - B - C - D - E - F + + where the attributes passed to this function are Z P A B C, the result of + the reduction is: + + Z - D - E - F + | + P - A - B - C + + Note how the node pointed by P gets changed after a reduction gets + performed. + + P is the AST node from where start matching. + + ATTRS is a sequence of node attributes. The first of these attributes is + the kind of node resulting from the reduction. The rest of attributes are + the matched in order starting at P, then a reduction is performed. Two node + attributes exist that convey special meaning when passing to "reduce": + + STOP marks the end of the variable-length sequence of attributes to match. + + WILDCARD will match any non terminal, with the exception of a keyword. It + is used to recover from errors. + + A is a "noting" function that is invoked and passed P right before doing the + reduction. If A is NO_NOTE then it is not used. + + The boolean Z is set to "true" if the reduction has been performed, and is + left untouched otherwise. If Z is NO_TICK then it is not used. + + It is common to invoke "reduce" in a row in order to try the reduction of + several alternatives, which are mutually exclusive. For example: + + reduce (p, NO_NOTE, NO_TICK, PARTICULAR_PROGRAM, LABEL, ENCLOSED_CLAUSE, STOP); + reduce (p, NO_NOTE, NO_TICK, PARTICULAR_PROGRAM, ENCLOSED_CLAUSE, STOP); + + We know that at much only one of these reductions will succeed, becuase if + the first reduction succeeds, then P gets changed to LABEL which cannot + match ENCLOSED_CLAUSE. + + Sometimes, however, "reduce" is invoked in a row in a way the second + reduction is intended to succeed if the first one succeeds. For example: + + reduce (p, NO_NOTE, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); + reduce (p, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, PARALLEL_CLAUSE, STOP); + + In this case if the first reduction succeeds, then the resulting + PARALLEL_CLAUSE will be itself reduced to an ENCLOSED_CLAUSE. + + Another typical usage of "reduce" is to put it in a loop in order to reduce + matches of a left-recursive rule. This is where Z comes to play. For + example, consider the rules: + + label : defining identifier, colon symbol ; + label, defining identifier, colon symbol. + + The second alternative is left-recursive, and along with the first rule + defines a sequence of one or more labels, each label consisting on a + defining identifier followed by a colon symbol. We could match these rules + using the following loop: + + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP); + reduce (q, NO_NOTE, &siga, LABEL, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP); + } + + Note how, when presented with a sequence of labels like `l1: l2: l3: ...', + the first call to "reduce" will succeed, turning Q into a LABEL. Then the + second call to "reduce" will also succed, reducing to another LABEL and + setting SIGA to "true". In subsequent iterations of the loop the first call + will always fail, and the second call will keep succeeding as more sequences + of DEFINING_IDENTIFIER, COLON_SYMBOL get matched. */ + +static void +reduce (NODE_T *p, void (*a) (NODE_T *), bool *z, /* attrs */...) +{ + va_list list; + va_start (list, z); + enum a68_attribute expect; + enum a68_attribute result = (enum a68_attribute) va_arg (list, int); + NODE_T *head = p, *tail = NO_NODE; + + while ((expect = (enum a68_attribute) va_arg (list, int)) != STOP) + { + bool keep_matching; + + if (p == NO_NODE) + keep_matching = false; + else if (expect == WILDCARD) + /* WILDCARD matches any non terminal, but no keyword. */ + keep_matching = (a68_attribute_name (ATTRIBUTE (p)) != NO_TEXT); + else + { + if (expect == SKIP) + { + /* Stray "~" matches expected SKIP. */ + if (IS (p, OPERATOR) && IS_LITERALLY (p, "~")) + ATTRIBUTE (p) = SKIP; + } + + if (expect >= 0) + keep_matching = (expect == ATTRIBUTE (p)); + else + keep_matching = (expect != ATTRIBUTE (p)); + } + + if (keep_matching) + { + tail = p; + FORWARD (p); + } + else + { + va_end (list); + return; + } + } + + /* Make reduction. */ + if (a != NO_NOTE) + a (head); + + a68_make_sub (head, tail, result); + va_end (list); + if (z != NO_TICK) + *z = true; +} + +/* Graciously ignore extra semicolons. */ + +static void +ignore_superfluous_semicolons (NODE_T *p) +{ + /* This routine relaxes the parser a bit with respect to superfluous + semicolons, for instance "FI; OD". These provoke only a warning. */ + for (; p != NO_NODE; FORWARD (p)) + { + ignore_superfluous_semicolons (SUB (p)); + + if (NEXT (p) != NO_NODE && IS (NEXT (p), SEMI_SYMBOL) && NEXT_NEXT (p) == NO_NODE) + { + a68_warning (NEXT (p), 0, + "skipped superfluous A", ATTRIBUTE (NEXT (p))); + NEXT (p) = NO_NODE; + } + else if (IS (p, SEMI_SYMBOL) && a68_is_semicolon_less (NEXT (p))) + { + a68_warning (p, 0, + "skipped superfluous A", ATTRIBUTE (p)); + if (PREVIOUS (p) != NO_NODE) + NEXT (PREVIOUS (p)) = NEXT (p); + PREVIOUS (NEXT (p)) = PREVIOUS (p); + } + } +} + +/* Reduce a particular program. */ + +void +reduce_particular_program (NODE_T *p) +{ + /* A program is "label sequence; particular program". */ + a68_extract_labels (p, SERIAL_CLAUSE); + + NODE_T *q = p; + /* Parse the program itself. */ + for (; q != NO_NODE; FORWARD (q)) + { + bool siga = true; + + if (SUB (q) != NO_NODE) + reduce_branch (q, SOME_CLAUSE); + + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP); + reduce (q, NO_NOTE, &siga, LABEL, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP); + } + } + /* Determine the encompassing enclosed clause. */ + for (q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, PARALLEL_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CLOSED_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, COLLATERAL_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONDITIONAL_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CASE_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONFORMITY_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, LOOP_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, ACCESS_CLAUSE, STOP); + } + + /* Try reducing a particular program. */ + q = p; + reduce (q, NO_NOTE, NO_TICK, PARTICULAR_PROGRAM, LABEL, ENCLOSED_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, PARTICULAR_PROGRAM, ENCLOSED_CLAUSE, STOP); +} + +/* Reduce a prelude packet. */ + +void +reduce_prelude_packet (NODE_T *p) +{ + /* Extract the module indicants. */ + a68_extract_indicants (p); + + /* Reduce MODULE_TEXTs */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, ALT_ACCESS_SYMBOL)) + reduce_branch (q, MODULE_TEXT); + else if (IS (q, DEF_SYMBOL)) + { + for (NODE_T *v = q; v != NO_NODE; FORWARD (v)) + { + if (IS (v, DEF_SYMBOL)) + reduce_branch (v, DEF_PART); + else if (IS (v, POSTLUDE_SYMBOL)) + reduce_branch (v, POSTLUDE_PART); + } + reduce_module_texts (q); + } + } + + /* Single module declaration. */ + reduce (p, NO_NOTE, NO_TICK, + MODULE_DECLARATION, MODULE_SYMBOL, DEFINING_MODULE_INDICANT, EQUALS_SYMBOL, MODULE_TEXT, STOP); + reduce (p, strange_tokens, NO_TICK, + MODULE_DECLARATION, MODULE_SYMBOL, DEFINING_MODULE_INDICANT, EQUALS_SYMBOL, -MODULE_TEXT, STOP); + + /* Joined module declarations. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + bool siga; + do + { + siga = false; + reduce (q, NO_NOTE, &siga, + MODULE_DECLARATION, MODULE_DECLARATION, + COMMA_SYMBOL, DEFINING_MODULE_INDICANT, EQUALS_SYMBOL, MODULE_TEXT, STOP); + } + while (siga); + } + + /* Try reducing a prelude packet. */ + reduce (p, NO_NOTE, NO_TICK, PRELUDE_PACKET, MODULE_DECLARATION, STOP); +} + +/* Driver for the bottom-up parser. */ + +void +a68_bottom_up_parser (NODE_T *p) +{ + if (p != NO_NODE) + { + if (!setjmp (A68_PARSER (bottom_up_crash_exit))) + { + NODE_T *q; + int error_count_0 = ERROR_COUNT (&A68_JOB); + + ignore_superfluous_semicolons (p); + + /* A compilation unit is a packet, which can be either a particular + program or a prelude packet. */ + if (IS (p, MODULE_SYMBOL)) + reduce_prelude_packet (p); + else + reduce_particular_program (p); + + /* Try reducing the packet. */ + q = p; + reduce (q, NO_NOTE, NO_TICK, PACKET, PARTICULAR_PROGRAM, STOP); + reduce (q, NO_NOTE, NO_TICK, PACKET, PRELUDE_PACKET, STOP); + if (SUB (p) == NO_NODE || NEXT (p) != NO_NODE) + recover_from_error (p, PACKET, + ((ERROR_COUNT (&A68_JOB) - error_count_0) > MAX_ERRORS)); + } + } +} + +/* Reduce the sub-phrase that starts one level down. + + EXPECT is the expected construct for the sub-phrase, and it is used to guide + the parsing by determining what reductions to try. This can be SOME_CLAUSE, + which means either a serial or a collateral clause. + + This is a recursive process. Let's suppose we have the parse tree below and + we call `reduce_branch (b, EXPECT)': + + a - b - c - d - e + | + b - x - y - z + | + v - w + + The first thing this function does is to traverse the 'b' branch + + b - x - y - z + + looking for declarations of indicants, priorities and operators + (a68_extract_{indicants,priorities,operators}). Using this information , it + determines the nature of bold tags occuring in the branch, by turning + BOLD_TAG nodes into either INDICANT nodes or OPERATOR nodes + (a68_elaborate_bold_tags). + + At this point it is possible to try reduce the declarers within the 'b' + subtree, so reduce_declarers is invoked on it. This function is recursive + and performs reductions of several kinds: sequences of 'long' and 'short' + symbols into sizeties, symbols like 'int' and 'real' into indicants, + declarers, declarer lists, etc. + + Once that is done, the 'p' branch is traversed and reduce_branch is invoked + recursively in certain nodes that start a sub-branch: + + | Recursing in branch | with expect | + |--------------------------------------------------+-------------------| + | FORMAT_DELIMITER_SYMBOL, FORMAT_OPEN_SYMBOL | FORMAT_TEXT | + |--------------------------------------------------+-------------------| + | OPEN_SYMBOL, IN_SYMBOL | COLLATERAL_CLAUSE | + |--------------------------------------------------+-------------------| + | IF_SYMBOL, ELIF_SYMBOL, CASE_SYMBOL, OUSE_SYMBOL | ENQUIRY_CLAUSE | + | WHILE_SYMBOL, ELSE_BAR_SYMBOL, DEF_SYMBOL | | + |--------------------------------------------------+-------------------| + | BEGIN_SYMBOL, THEN_BAR_SYMBOL | SOME_CLAUSE | + |--------------------------------------------------+-------------------| + | THEN_SYMBOL, ELSE_SYMBOL, OUT_SYMBOL | SERIAL_CLAUSE | + | DO_SYMBOL, ALT_DO_SYMBOL, POSTLUDE_SYMBOL | | + |--------------------------------------------------+-------------------| + | LOOP_CLAUSE, ACCESS_SYMBOL | ENCLOSED_CLAUSE | + |--------------------------------------------------+-------------------| + | FOR_SYMBOL, FROM_SYMBOL, BY_SYMBOL, TO_SYMBOL | UNIT | + + Once all the sub-branches are reduced, the final step is to finally reduce + the 'b' branch, trying different possibilities: basic declarations, units, + bounds, declaration lists, clauses, module texts, etc. + + Note that reducing a branch requires knowing the kind of resulting subtree. + So if you find yourself wanting to call reduce_branch and don't know what to + pass in EXPECT, you are probably doing something wrong.. very likely you + want to make reduce_branch aware of a new sort of branch. */ + +static void +reduce_branch (NODE_T *q, enum a68_attribute expect) +{ + /* If unsuccessful then the routine will at least copy the resulting + attribute as the parser can repair some faults. This gives less spurious + diagnostics. */ + if (q != NO_NODE && SUB (q) != NO_NODE) + { + NODE_T *p = SUB (q), *u = NO_NODE; + int error_count_0 = ERROR_COUNT (&A68_JOB), error_count_02; + bool declarer_pack = false, no_error; + + switch (expect) + { + case STRUCTURE_PACK: + case PARAMETER_PACK: + case FORMAL_DECLARERS: + case UNION_PACK: + case SPECIFIER: + declarer_pack = true; + break; + default: + declarer_pack = false; + } + + /* Sample all info needed to decide whether a bold tag is operator or + indicant. Find the meaning of bold tags and quit in case of extra + errors. */ + a68_extract_indicants (p); + if (!declarer_pack) + { + a68_extract_priorities (p); + a68_extract_operators (p); + } + + error_count_02 = ERROR_COUNT (&A68_JOB); + a68_elaborate_bold_tags (p); + if ((ERROR_COUNT (&A68_JOB) - error_count_02) > 0) + longjmp (A68_PARSER (bottom_up_crash_exit), 1); + + /* Now we can reduce declarers, knowing which bold tags are indicants. */ + reduce_declarers (p, expect); + /* Parse the phrase, as appropriate. */ + if (declarer_pack == false) + { + error_count_02 = ERROR_COUNT (&A68_JOB); + a68_extract_declarations (p); + if ((ERROR_COUNT (&A68_JOB) - error_count_02) > 0) + longjmp (A68_PARSER (bottom_up_crash_exit), 1); + a68_extract_labels (p, expect); + for (u = p; u != NO_NODE; FORWARD (u)) + { + if (SUB (u) != NO_NODE) + { + if (IS (u, FORMAT_DELIMITER_SYMBOL)) + reduce_branch (u, FORMAT_TEXT); + else if (IS (u, FORMAT_OPEN_SYMBOL)) + reduce_branch (u, FORMAT_TEXT); + else if (IS (u, OPEN_SYMBOL)) + { + if (NEXT (u) != NO_NODE && IS (NEXT (u), THEN_BAR_SYMBOL)) + reduce_branch (u, ENQUIRY_CLAUSE); + else if (PREVIOUS (u) != NO_NODE && IS (PREVIOUS (u), PAR_SYMBOL)) + reduce_branch (u, COLLATERAL_CLAUSE); + } + else if (a68_is_one_of (u, IF_SYMBOL, ELIF_SYMBOL, CASE_SYMBOL, + OUSE_SYMBOL, WHILE_SYMBOL, + ELSE_BAR_SYMBOL, DEF_PART, STOP)) + reduce_branch (u, ENQUIRY_CLAUSE); + else if (IS (u, BEGIN_SYMBOL)) + reduce_branch (u, SOME_CLAUSE); + else if (a68_is_one_of (u, THEN_SYMBOL, ELSE_SYMBOL, OUT_SYMBOL, + DO_SYMBOL, ALT_DO_SYMBOL, + POSTLUDE_PART, STOP)) + reduce_branch (u, SERIAL_CLAUSE); + else if (IS (u, IN_SYMBOL)) + reduce_branch (u, COLLATERAL_CLAUSE); + else if (IS (u, THEN_BAR_SYMBOL)) + reduce_branch (u, SOME_CLAUSE); + else if (IS (u, ACCESS_SYMBOL)) + reduce_branch (u, ENCLOSED_CLAUSE); + else if (IS (u, DEF_SYMBOL)) + reduce_branch (u, DEF_PART); + else if (IS (u, POSTLUDE_SYMBOL)) + reduce_branch (u, POSTLUDE_PART); + else if (IS (u, LOOP_CLAUSE)) + reduce_branch (u, ENCLOSED_CLAUSE); + else if (a68_is_one_of (u, FOR_SYMBOL, FROM_SYMBOL, BY_SYMBOL, TO_SYMBOL, + STOP)) + reduce_branch (u, UNIT); + } + } + + reduce_primary_parts (p, expect); + if (expect != ENCLOSED_CLAUSE) + { + reduce_primaries (p, expect); + if (expect == FORMAT_TEXT) + reduce_format_texts (p); + else + { + reduce_secondaries (p); + reduce_formulae (p); + reduce_tertiaries (p); + } + } + + reduce_right_to_left_constructs (p); + /* Reduce units and declarations. */ + reduce_basic_declarations (p); + reduce_units (p); + reduce_erroneous_units (p); + if (expect != UNIT) + { + if (expect == GENERIC_ARGUMENT) + reduce_generic_arguments (p); + else if (expect == BOUNDS) + reduce_bounds (p); + else + { + reduce_declaration_lists (p); + if (expect != DECLARATION_LIST) + { + for (u = p; u != NO_NODE; FORWARD (u)) + { + reduce (u, NO_NOTE, NO_TICK, LABELED_UNIT, LABEL, UNIT, STOP); + reduce (u, NO_NOTE, NO_TICK, SPECIFIED_UNIT, SPECIFIER, + COLON_SYMBOL, UNIT, STOP); + } + if (expect == SOME_CLAUSE) + expect = serial_or_collateral (p); + if (expect == SERIAL_CLAUSE) + reduce_serial_clauses (p); + else if (expect == ENQUIRY_CLAUSE) + reduce_enquiry_clauses (p); + else if (expect == COLLATERAL_CLAUSE) + reduce_collateral_clauses (p); + else if (expect == ARGUMENT) + reduce_arguments (p); + } + } + } + reduce_enclosed_clauses (p, expect); + if (expect == DEF_PART || expect == POSTLUDE_PART) + reduce_module_text_parts (p); + if (expect == MODULE_TEXT) + reduce_module_texts (p); + } + + /* Do something if parsing failed. */ + if (SUB (p) == NO_NODE || NEXT (p) != NO_NODE) + { + recover_from_error (p, expect, + ((ERROR_COUNT (&A68_JOB) - error_count_0) > MAX_ERRORS)); + no_error = false; + } + else + no_error = true; + ATTRIBUTE (q) = ATTRIBUTE (p); + if (no_error) + SUB (q) = SUB (p); + } +} + +/* Driver for reducing declarers. */ + +static void +reduce_declarers (NODE_T *p, enum a68_attribute expect) +{ + NODE_T *q; bool siga; /* Must be in this scope. */ + + /* Reduce lengtheties. */ + for (q = p; q != NO_NODE; FORWARD (q)) + { + siga = true; + reduce (q, NO_NOTE, NO_TICK, LONGETY, LONG_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, SHORTETY, SHORT_SYMBOL, STOP); + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, LONGETY, LONGETY, LONG_SYMBOL, STOP); + reduce (q, NO_NOTE, &siga, SHORTETY, SHORTETY, SHORT_SYMBOL, STOP); + } + } + + /* Reduce indicants. */ + for (q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, INDICANT, INT_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, REAL_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, BITS_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, BYTES_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, COMPLEX_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, COMPL_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, BOOL_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, CHAR_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, FORMAT_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, STRING_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, FILE_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, CHANNEL_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, INDICANT, SEMA_SYMBOL, STOP); + } + + /* Reduce standard stuff. */ + for (q = p; q != NO_NODE; FORWARD (q)) + { + if (a68_whether (q, LONGETY, INDICANT, STOP)) + { + int a; + + if (SUB_NEXT (q) == NO_NODE) + { + a68_error (NEXT (q), + "Y expected", "appropriate declarer"); + reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP); + } + else + { + a = ATTRIBUTE (SUB_NEXT (q)); + + if (a == INT_SYMBOL || a == REAL_SYMBOL || a == BITS_SYMBOL + || a == BYTES_SYMBOL || a == COMPLEX_SYMBOL + || a == COMPL_SYMBOL) + { + reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP); + } + else + { + a68_error (NEXT (q), + "Y expected", "appropriate declarer"); + reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP); + } + } + } + else if (a68_whether (q, SHORTETY, INDICANT, STOP)) + { + int a; + + if (SUB_NEXT (q) == NO_NODE) + { + a68_error (NEXT (q), + "Y expected", "appropriate declarer"); + reduce (q, NO_NOTE, NO_TICK, DECLARER, SHORTETY, INDICANT, STOP); + } + else + { + a = ATTRIBUTE (SUB_NEXT (q)); + if (a == INT_SYMBOL || a == REAL_SYMBOL || a == BITS_SYMBOL + || a == BYTES_SYMBOL || a == COMPLEX_SYMBOL || a == COMPL_SYMBOL) + { + reduce (q, NO_NOTE, NO_TICK, DECLARER, SHORTETY, INDICANT, STOP); + } + else + { + a68_error (NEXT (q), + "Y expected", "appropriate declarer"); + reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP); + } + } + } + } + + for (q = p; q != NO_NODE; FORWARD (q)) + reduce (q, NO_NOTE, NO_TICK, DECLARER, INDICANT, STOP); + + /* Reduce declarer lists. */ + for (q = p; q != NO_NODE; FORWARD (q)) + { + if (NEXT (q) != NO_NODE && SUB_NEXT (q) != NO_NODE) + { + if (IS (q, STRUCT_SYMBOL)) + { + reduce_branch (NEXT (q), STRUCTURE_PACK); + reduce (q, NO_NOTE, NO_TICK, DECLARER, STRUCT_SYMBOL, STRUCTURE_PACK, STOP); + } + else if (IS (q, UNION_SYMBOL)) + { + reduce_branch (NEXT (q), UNION_PACK); + reduce (q, NO_NOTE, NO_TICK, DECLARER, UNION_SYMBOL, UNION_PACK, STOP); + } + else if (IS (q, PROC_SYMBOL)) + { + if (a68_whether (q, PROC_SYMBOL, OPEN_SYMBOL, STOP)) + { + if (!a68_is_formal_bounds (SUB_NEXT (q))) + reduce_branch (NEXT (q), FORMAL_DECLARERS); + } + } + else if (IS (q, OP_SYMBOL)) + { + if (a68_whether (q, OP_SYMBOL, OPEN_SYMBOL, STOP)) + { + if (!a68_is_formal_bounds (SUB_NEXT (q))) + reduce_branch (NEXT (q), FORMAL_DECLARERS); + } + } + } + } + + /* Reduce row, proc or op declarers. */ + siga = true; + while (siga) + { + siga = false; + + for (q = p; q != NO_NODE; FORWARD (q)) + { + /* FLEX DECL. */ + if (a68_whether (q, FLEX_SYMBOL, DECLARER, STOP)) + reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, DECLARER, STOP); + + /* FLEX [] DECL. */ + if (a68_whether (q, FLEX_SYMBOL, SUB_SYMBOL, DECLARER, STOP) && SUB_NEXT (q) != NO_NODE) + { + reduce_branch (NEXT (q), BOUNDS); + reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, BOUNDS, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, FORMAL_BOUNDS, DECLARER, STOP); + } + + /* FLEX () DECL. */ + if (a68_whether (q, FLEX_SYMBOL, OPEN_SYMBOL, DECLARER, STOP) && SUB_NEXT (q) != NO_NODE) + { + if (!a68_whether (q, FLEX_SYMBOL, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP)) + { + reduce_branch (NEXT (q), BOUNDS); + reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, BOUNDS, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, FORMAL_BOUNDS, DECLARER, STOP); + } + } + + /* [] DECL. */ + if (a68_whether (q, SUB_SYMBOL, DECLARER, STOP) && SUB (q) != NO_NODE) + { + reduce_branch (q, BOUNDS); + reduce (q, NO_NOTE, &siga, DECLARER, BOUNDS, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, DECLARER, FORMAL_BOUNDS, DECLARER, STOP); + } + + /* () DECL. */ + if (a68_whether (q, OPEN_SYMBOL, DECLARER, STOP) && SUB (q) != NO_NODE) + { + if (a68_whether (q, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP)) + { + /* Catch e.g. (INT i) () INT:. */ + if (a68_is_formal_bounds (SUB (q))) + { + reduce_branch (q, BOUNDS); + reduce (q, NO_NOTE, &siga, DECLARER, BOUNDS, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, DECLARER, FORMAL_BOUNDS, DECLARER, STOP); + } + } + else + { + reduce_branch (q, BOUNDS); + reduce (q, NO_NOTE, &siga, DECLARER, BOUNDS, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, DECLARER, FORMAL_BOUNDS, DECLARER, STOP); + } + } + } + + /* PROC DECL, PROC () DECL, OP () DECL. */ + for (q = p; q != NO_NODE; FORWARD (q)) + { + int a = ATTRIBUTE (q); + if (a == REF_SYMBOL) + reduce (q, NO_NOTE, &siga, DECLARER, REF_SYMBOL, DECLARER, STOP); + else if (a == PROC_SYMBOL) + { + reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, FORMAL_DECLARERS, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, VOID_SYMBOL, STOP); + reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, FORMAL_DECLARERS, VOID_SYMBOL, STOP); + } + else if (a == OP_SYMBOL) + { + reduce (q, NO_NOTE, &siga, OPERATOR_PLAN, OP_SYMBOL, FORMAL_DECLARERS, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, OPERATOR_PLAN, OP_SYMBOL, FORMAL_DECLARERS, VOID_SYMBOL, STOP); + } + } + } + + /* Reduce packs etcetera. */ + if (expect == STRUCTURE_PACK) + { + for (q = p; q != NO_NODE; FORWARD (q)) + { + siga = true; + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD, DECLARER, IDENTIFIER, STOP); + reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD, STRUCTURED_FIELD, COMMA_SYMBOL, IDENTIFIER, STOP); + } + } + + for (q = p; q != NO_NODE; FORWARD (q)) + { + siga = true; + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD, STOP); + reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD_LIST, + COMMA_SYMBOL, STRUCTURED_FIELD, STOP); + reduce (q, strange_separator, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD_LIST, + STRUCTURED_FIELD, STOP); + reduce (q, strange_separator, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD_LIST, + SEMI_SYMBOL, STRUCTURED_FIELD, STOP); + } + } + q = p; + reduce (q, NO_NOTE, NO_TICK, STRUCTURE_PACK, OPEN_SYMBOL, STRUCTURED_FIELD_LIST, + CLOSE_SYMBOL, STOP); + } + else if (expect == PARAMETER_PACK) + { + for (q = p; q != NO_NODE; FORWARD (q)) + { + siga = true; + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, PARAMETER, DECLARER, IDENTIFIER, STOP); + reduce (q, NO_NOTE, &siga, PARAMETER, PARAMETER, COMMA_SYMBOL, IDENTIFIER, STOP); + } + } + + for (q = p; q != NO_NODE; FORWARD (q)) + { + siga = true; + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, PARAMETER_LIST, PARAMETER, STOP); + reduce (q, NO_NOTE, &siga, PARAMETER_LIST, PARAMETER_LIST, COMMA_SYMBOL, PARAMETER, STOP); + } + } + q = p; + reduce (q, NO_NOTE, NO_TICK, PARAMETER_PACK, OPEN_SYMBOL, PARAMETER_LIST, + CLOSE_SYMBOL, STOP); + } + else if (expect == FORMAL_DECLARERS) + { + for (q = p; q != NO_NODE; FORWARD (q)) + { + siga = true; + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, FORMAL_DECLARERS_LIST, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, FORMAL_DECLARERS_LIST, FORMAL_DECLARERS_LIST, + COMMA_SYMBOL, DECLARER, STOP); + reduce (q, strange_separator, &siga, FORMAL_DECLARERS_LIST, FORMAL_DECLARERS_LIST, + SEMI_SYMBOL, DECLARER, STOP); + reduce (q, strange_separator, &siga, FORMAL_DECLARERS_LIST, FORMAL_DECLARERS_LIST, + DECLARER, STOP); + } + } + q = p; + reduce (q, NO_NOTE, NO_TICK, FORMAL_DECLARERS, OPEN_SYMBOL, FORMAL_DECLARERS_LIST, + CLOSE_SYMBOL, STOP); + } + else if (expect == UNION_PACK) + { + for (q = p; q != NO_NODE; FORWARD (q)) + { + siga = true; + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, VOID_SYMBOL, STOP); + reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, + COMMA_SYMBOL, DECLARER, STOP); + reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, + COMMA_SYMBOL, VOID_SYMBOL, STOP); + reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, + SEMI_SYMBOL, DECLARER, STOP); + reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, + SEMI_SYMBOL, VOID_SYMBOL, STOP); + reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, + DECLARER, STOP); + reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST, + VOID_SYMBOL, STOP); + } + } + q = p; + reduce (q, NO_NOTE, NO_TICK, UNION_PACK, OPEN_SYMBOL, UNION_DECLARER_LIST, + CLOSE_SYMBOL, STOP); + } + else if (expect == SPECIFIER) + { + reduce (p, NO_NOTE, NO_TICK, SPECIFIER, OPEN_SYMBOL, DECLARER, IDENTIFIER, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, SPECIFIER, OPEN_SYMBOL, DECLARER, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, SPECIFIER, OPEN_SYMBOL, VOID_SYMBOL, CLOSE_SYMBOL, STOP); + } + else + { + for (q = p; q != NO_NODE; FORWARD (q)) + { + if (a68_whether (q, OPEN_SYMBOL, COLON_SYMBOL, STOP) + && !(expect == GENERIC_ARGUMENT || expect == BOUNDS)) + { + if (a68_is_one_of (p, IN_SYMBOL, THEN_BAR_SYMBOL, STOP)) + reduce_branch (q, SPECIFIER); + } + if (a68_whether (q, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP)) + reduce_branch (q, PARAMETER_PACK); + if (a68_whether (q, OPEN_SYMBOL, VOID_SYMBOL, COLON_SYMBOL, STOP)) + reduce_branch (q, PARAMETER_PACK); + } + } +} + +/* Handle cases that need reducing from right-to-left. */ + +static void +reduce_right_to_left_constructs (NODE_T *p) +{ + /* Here are cases that need reducing from right-to-left whereas many things + can be reduced left-to-right. Assignations are a notable example; one + could discuss whether it would not be more natural to write 1 =: k instead + of k := 1. (jemarch: MARY did just that.) The latter is said to be more + natural, or it could be just computing history. Meanwhile we use this + routine. */ + + if (p != NO_NODE) + { + reduce_right_to_left_constructs (NEXT (p)); + /* Assignations. */ + if (IS (p, TERTIARY)) + { + reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, TERTIARY, STOP); + reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, IDENTITY_RELATION, STOP); + reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, AND_FUNCTION, STOP); + reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, OR_FUNCTION, STOP); + reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, ROUTINE_TEXT, STOP); + reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, JUMP, STOP); + reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, SKIP, STOP); + reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, ASSIGNATION, STOP); + } + + /* Routine texts with parameter pack. */ + else if (IS (p, PARAMETER_PACK)) + { + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, ASSIGNATION, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, IDENTITY_RELATION, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL,AND_FUNCTION, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, OR_FUNCTION, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, JUMP, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, SKIP, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, TERTIARY, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, ROUTINE_TEXT, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, ASSIGNATION, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, IDENTITY_RELATION, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, AND_FUNCTION, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, OR_FUNCTION, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, JUMP, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, SKIP, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, TERTIARY, STOP); + reduce (p, NO_NOTE, NO_TICK, + ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, ROUTINE_TEXT, STOP); + } + /* Routine texts without parameter pack. */ + else if (IS (p, DECLARER)) + { + if (!(PREVIOUS (p) != NO_NODE && IS (PREVIOUS (p), PARAMETER_PACK))) + { + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, ASSIGNATION, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, IDENTITY_RELATION, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, AND_FUNCTION, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, OR_FUNCTION, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, JUMP, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, SKIP, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, TERTIARY, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, ROUTINE_TEXT, STOP); + } + } + else if (IS (p, VOID_SYMBOL)) + { + if (!(PREVIOUS (p) != NO_NODE && IS (PREVIOUS (p), PARAMETER_PACK))) + { + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, ASSIGNATION, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, IDENTITY_RELATION, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, AND_FUNCTION, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, OR_FUNCTION, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, JUMP, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, SKIP, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, TERTIARY, STOP); + reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, ROUTINE_TEXT, STOP); + } + } + } +} + +/* Reduce primary elements. */ + +static void +reduce_primary_parts (NODE_T *p, enum a68_attribute expect) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (a68_whether (q, IDENTIFIER, OF_SYMBOL, STOP)) + ATTRIBUTE (q) = FIELD_IDENTIFIER; + + reduce (q, NO_NOTE, NO_TICK, NIHIL, NIL_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, SKIP, SKIP_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, SELECTOR, FIELD_IDENTIFIER, OF_SYMBOL, STOP); + /* JUMPs without GOTO are resolved later. */ + reduce (q, NO_NOTE, NO_TICK, JUMP, GOTO_SYMBOL, IDENTIFIER, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, LONGETY, INT_DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, LONGETY, REAL_DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, LONGETY, BITS_DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, SHORTETY, INT_DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, SHORTETY, REAL_DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, SHORTETY, BITS_DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, INT_DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, REAL_DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, BITS_DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, ROW_CHAR_DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, TRUE_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, FALSE_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, DENOTATION, EMPTY_SYMBOL, STOP); + if (expect == SERIAL_CLAUSE || expect == ENQUIRY_CLAUSE || expect == SOME_CLAUSE) + { + bool siga = true; + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP); + reduce (q, NO_NOTE, &siga, LABEL, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP); + } + } + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, ACCESS_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, PARALLEL_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CLOSED_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, COLLATERAL_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONDITIONAL_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CASE_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONFORMITY_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, LOOP_CLAUSE, STOP); + } +} + +/* Reduce primaries completely. */ + +static void +reduce_primaries (NODE_T *p, enum a68_attribute expect) +{ + NODE_T *q = p; + while (q != NO_NODE) + { + bool fwd = true, siga; + /* Primaries excepts call and slice. */ + reduce (q, NO_NOTE, NO_TICK, PRIMARY, IDENTIFIER, STOP); + reduce (q, NO_NOTE, NO_TICK, PRIMARY, DENOTATION, STOP); + reduce (q, NO_NOTE, NO_TICK, CAST, DECLARER, ENCLOSED_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, CAST, VOID_SYMBOL, ENCLOSED_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ASSERTION, ASSERT_SYMBOL, ENCLOSED_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, PRIMARY, CAST, STOP); + reduce (q, NO_NOTE, NO_TICK, PRIMARY, ENCLOSED_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, PRIMARY, FORMAT_TEXT, STOP); + /* Call and slice. */ + siga = true; + while (siga) + { + NODE_T *x = NEXT (q); + + siga = false; + if (IS (q, PRIMARY) && x != NO_NODE) + { + if (IS (x, OPEN_SYMBOL)) + { + reduce_branch (NEXT (q), GENERIC_ARGUMENT); + reduce (q, NO_NOTE, &siga, SPECIFICATION, PRIMARY, GENERIC_ARGUMENT, STOP); + reduce (q, NO_NOTE, &siga, PRIMARY, SPECIFICATION, STOP); + } + else if (IS (x, SUB_SYMBOL)) + { + reduce_branch (NEXT (q), GENERIC_ARGUMENT); + reduce (q, NO_NOTE, &siga, SPECIFICATION, PRIMARY, GENERIC_ARGUMENT, STOP); + reduce (q, NO_NOTE, &siga, PRIMARY, SPECIFICATION, STOP); + } + } + } + + /* Now that call and slice are known, reduce remaining ( .. ). */ + if (IS (q, OPEN_SYMBOL) && SUB (q) != NO_NODE) + { + reduce_branch (q, SOME_CLAUSE); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CLOSED_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, COLLATERAL_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONDITIONAL_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CASE_CLAUSE, STOP); + reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONFORMITY_CLAUSE, STOP); + if (PREVIOUS (q) != NO_NODE) + { + BACKWARD (q); + fwd = false; + } + } + + /* Format text items. */ + if (expect == FORMAT_TEXT) + { + NODE_T *r; + + for (r = p; r != NO_NODE; FORWARD (r)) + { + reduce (r, NO_NOTE, NO_TICK, DYNAMIC_REPLICATOR, FORMAT_ITEM_N, ENCLOSED_CLAUSE, STOP); + reduce (r, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_G, ENCLOSED_CLAUSE, STOP); + reduce (r, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_H, ENCLOSED_CLAUSE, STOP); + reduce (r, NO_NOTE, NO_TICK, FORMAT_PATTERN, FORMAT_ITEM_F, ENCLOSED_CLAUSE, STOP); + } + } + if (fwd) + FORWARD (q); + } +} + +/* Enforce that ambiguous patterns are separated by commas. */ + +static void +ambiguous_patterns (NODE_T *p) +{ + /* Example: printf (($+d.2d +d.2d$, 1, 2)) can produce either "+1.00 +2.00" + or "+1+002.00". A comma must be supplied to resolve the ambiguity. + + The obvious thing would be to weave this into the syntax, letting the BU + parser sort it out. But the C-style patterns do not suffer from Algol 68 + pattern ambiguity, so by solving it this way we maximise freedom in + writing the patterns as we want without introducing two "kinds" of + patterns, and so we have shorter routines for implementing formatted + transput. This is a pragmatic system. */ + NODE_T *q, *last_pat = NO_NODE; + + for (q = p; q != NO_NODE; FORWARD (q)) + { + switch (ATTRIBUTE (q)) + { + /* These are the potentially ambiguous patterns. */ + case INTEGRAL_PATTERN: + case REAL_PATTERN: + case COMPLEX_PATTERN: + case BITS_PATTERN: + if (last_pat != NO_NODE) + a68_error (q, "A and A must be separated by a comma-symbol", + ATTRIBUTE (last_pat), ATTRIBUTE (q)); + last_pat = q; + break; + case COMMA_SYMBOL: + last_pat = NO_NODE; + break; + default: + break; + } + } +} + +/* Reduce C format texts completely. */ + +static void +reduce_c_pattern (NODE_T *p, int pr, int let) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, REPLICATOR, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, REPLICATOR, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, REPLICATOR, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, REPLICATOR, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, REPLICATOR, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, REPLICATOR, FORMAT_ITEM_POINT, REPLICATOR, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, FORMAT_ITEM_POINT, REPLICATOR, + let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, REPLICATOR, let, STOP); + reduce (q, NO_NOTE, NO_TICK, pr, + FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, REPLICATOR, FORMAT_ITEM_POINT, + REPLICATOR, let, STOP); + } +} + +/* Reduce format texts completely. */ + +static void +reduce_format_texts (NODE_T *p) +{ + /* Replicators. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, REPLICATOR, STATIC_REPLICATOR, STOP); + reduce (q, NO_NOTE, NO_TICK, REPLICATOR, DYNAMIC_REPLICATOR, STOP); + } + + /* "OTHER" patterns. */ + reduce_c_pattern (p, BITS_C_PATTERN, FORMAT_ITEM_B); + reduce_c_pattern (p, BITS_C_PATTERN, FORMAT_ITEM_O); + reduce_c_pattern (p, BITS_C_PATTERN, FORMAT_ITEM_X); + reduce_c_pattern (p, CHAR_C_PATTERN, FORMAT_ITEM_C); + reduce_c_pattern (p, FIXED_C_PATTERN, FORMAT_ITEM_F); + reduce_c_pattern (p, FLOAT_C_PATTERN, FORMAT_ITEM_E); + reduce_c_pattern (p, GENERAL_C_PATTERN, FORMAT_ITEM_G); + reduce_c_pattern (p, INTEGRAL_C_PATTERN, FORMAT_ITEM_D); + reduce_c_pattern (p, INTEGRAL_C_PATTERN, FORMAT_ITEM_I); + reduce_c_pattern (p, STRING_C_PATTERN, FORMAT_ITEM_S); + /* Radix frames. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + reduce (q, NO_NOTE, NO_TICK, RADIX_FRAME, REPLICATOR, FORMAT_ITEM_R, STOP); + + /* Insertions. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_X, STOP); + reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_Y, STOP); + reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_L, STOP); + reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_P, STOP); + reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_Q, STOP); + reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_K, STOP); + reduce (q, NO_NOTE, NO_TICK, INSERTION, LITERAL, STOP); + } + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, INSERTION, REPLICATOR, INSERTION, STOP); + } + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + bool siga = true; + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, INSERTION, INSERTION, INSERTION, STOP); + } + } + + /* Replicated suppressible frames. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, REPLICATOR, FORMAT_ITEM_S, FORMAT_ITEM_A, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, REPLICATOR, FORMAT_ITEM_S, FORMAT_ITEM_Z, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, REPLICATOR, FORMAT_ITEM_S, FORMAT_ITEM_D, STOP); + } + + /* Suppressible frames. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_A, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_Z, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_D, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_E_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_E, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_POINT_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_POINT, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_I_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_I, STOP); + } + + /* Replicated frames. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, REPLICATOR, FORMAT_ITEM_A, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, REPLICATOR, FORMAT_ITEM_Z, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, REPLICATOR, FORMAT_ITEM_D, STOP); + } + + /* Frames. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, FORMAT_ITEM_A, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, FORMAT_ITEM_Z, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, FORMAT_ITEM_D, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_E_FRAME, FORMAT_ITEM_E, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_I_FRAME, FORMAT_ITEM_I, STOP); + } + + /* Frames with an insertion. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, INSERTION, FORMAT_A_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, INSERTION, FORMAT_Z_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, INSERTION, FORMAT_D_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_E_FRAME, INSERTION, FORMAT_E_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_POINT_FRAME, INSERTION, FORMAT_POINT_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAT_I_FRAME, INSERTION, FORMAT_I_FRAME, STOP); + } + + /* String patterns. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + reduce (q, NO_NOTE, NO_TICK, STRING_PATTERN, REPLICATOR, FORMAT_A_FRAME, STOP); + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + reduce (q, NO_NOTE, NO_TICK, STRING_PATTERN, FORMAT_A_FRAME, STOP); + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + bool siga = true; + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, STRING_PATTERN, STRING_PATTERN, STRING_PATTERN, STOP); + reduce (q, NO_NOTE, &siga, STRING_PATTERN, STRING_PATTERN, INSERTION, STRING_PATTERN, STOP); + } + } + + /* Integral moulds. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, INTEGRAL_MOULD, FORMAT_Z_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, INTEGRAL_MOULD, FORMAT_D_FRAME, STOP); + } + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + bool siga = true; + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, INTEGRAL_MOULD, INTEGRAL_MOULD, INTEGRAL_MOULD, STOP); + reduce (q, NO_NOTE, &siga, INTEGRAL_MOULD, INTEGRAL_MOULD, INSERTION, STOP); + } + } + + /* Sign moulds. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_ITEM_PLUS, STOP); + reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_ITEM_MINUS, STOP); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, FORMAT_ITEM_PLUS, STOP); + reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, FORMAT_ITEM_MINUS, STOP); + } + + /* Exponent frames. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, EXPONENT_FRAME, FORMAT_E_FRAME, SIGN_MOULD, INTEGRAL_MOULD, STOP); + reduce (q, NO_NOTE, NO_TICK, EXPONENT_FRAME, FORMAT_E_FRAME, INTEGRAL_MOULD, STOP); + } + + /* Real patterns. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, + STOP); + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP); + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, EXPONENT_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, STOP); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP); + reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, EXPONENT_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, STOP); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP); + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, EXPONENT_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, + REAL_PATTERN, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); + reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, INTEGRAL_MOULD, EXPONENT_FRAME, STOP); + } + + /* Complex patterns. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + reduce (q, NO_NOTE, NO_TICK, COMPLEX_PATTERN, REAL_PATTERN, FORMAT_I_FRAME, REAL_PATTERN, STOP); + + /* Bits patterns. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + reduce (q, NO_NOTE, NO_TICK, BITS_PATTERN, RADIX_FRAME, INTEGRAL_MOULD, STOP); + + /* Integral patterns. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, INTEGRAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, STOP); + reduce (q, NO_NOTE, NO_TICK, INTEGRAL_PATTERN, INTEGRAL_MOULD, STOP); + } + + /* Patterns. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, BOOLEAN_PATTERN, FORMAT_ITEM_B, COLLECTION, STOP); + reduce (q, NO_NOTE, NO_TICK, CHOICE_PATTERN, FORMAT_ITEM_C, COLLECTION, STOP); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, BOOLEAN_PATTERN, FORMAT_ITEM_B, STOP); + reduce (q, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_G, STOP); + reduce (q, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_H, STOP); + } + + ambiguous_patterns (p); + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, a68_extension, NO_TICK, A68_PATTERN, BITS_C_PATTERN, STOP); + reduce (q, a68_extension, NO_TICK, A68_PATTERN, CHAR_C_PATTERN, STOP); + reduce (q, a68_extension, NO_TICK, A68_PATTERN, FIXED_C_PATTERN, STOP); + reduce (q, a68_extension, NO_TICK, A68_PATTERN, FLOAT_C_PATTERN, STOP); + reduce (q, a68_extension, NO_TICK, A68_PATTERN, GENERAL_C_PATTERN, STOP); + reduce (q, a68_extension, NO_TICK, A68_PATTERN, INTEGRAL_C_PATTERN, STOP); + reduce (q, a68_extension, NO_TICK, A68_PATTERN, STRING_C_PATTERN, STOP); + reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, BITS_PATTERN, STOP); + reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, BOOLEAN_PATTERN, STOP); + reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, CHOICE_PATTERN, STOP); + reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, COMPLEX_PATTERN, STOP); + reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, FORMAT_PATTERN, STOP); + reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, GENERAL_PATTERN, STOP); + reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, INTEGRAL_PATTERN, STOP); + reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, REAL_PATTERN, STOP); + reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, STRING_PATTERN, STOP); + } + + /* Pictures. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, PICTURE, INSERTION, STOP); + reduce (q, NO_NOTE, NO_TICK, PICTURE, A68_PATTERN, STOP); + reduce (q, NO_NOTE, NO_TICK, PICTURE, COLLECTION, STOP); + reduce (q, NO_NOTE, NO_TICK, PICTURE, REPLICATOR, COLLECTION, STOP); + } + + /* Picture lists. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, PICTURE)) + { + bool siga = true; + reduce (q, NO_NOTE, NO_TICK, PICTURE_LIST, PICTURE, STOP); + while (siga) + { + siga = false; + reduce (q, NO_NOTE, &siga, PICTURE_LIST, PICTURE_LIST, COMMA_SYMBOL, PICTURE, STOP); + /* We filtered ambiguous patterns, so commas may be omitted */ + reduce (q, NO_NOTE, &siga, PICTURE_LIST, PICTURE_LIST, PICTURE, STOP); + } + } + } +} + +/* Reduce secondaries completely. */ + +static void +reduce_secondaries (NODE_T *p) +{ + NODE_T *q; bool siga; + + for (q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, SECONDARY, PRIMARY, STOP); + reduce (q, NO_NOTE, NO_TICK, GENERATOR, LOC_SYMBOL, DECLARER, STOP); + reduce (q, NO_NOTE, NO_TICK, GENERATOR, HEAP_SYMBOL, DECLARER, STOP); + reduce (q, NO_NOTE, NO_TICK, SECONDARY, GENERATOR, STOP); + } + siga = true; + while (siga) + { + siga = false; + for (q = p; NEXT (q) != NO_NODE; FORWARD (q)) + ; + for (; q != NO_NODE; BACKWARD (q)) + { + reduce (q, NO_NOTE, &siga, SELECTION, SELECTOR, SECONDARY, STOP); + reduce (q, NO_NOTE, &siga, SECONDARY, SELECTION, STOP); + } + } +} + +/* Whether Q is an operator with priority K. */ + +static int +operator_with_priority (NODE_T *q, int k) +{ + return NEXT (q) != NO_NODE + && ATTRIBUTE (NEXT (q)) == OPERATOR && PRIO (INFO (NEXT (q))) == k; +} + +/* Reduce formulae. */ + +static void +reduce_formulae (NODE_T * p) +{ + NODE_T *q = p; + + while (q != NO_NODE) + { + if (a68_is_one_of (q, OPERATOR, SECONDARY, STOP)) + q = reduce_dyadic (q, STOP); + else + FORWARD (q); + } + + /* Reduce the expression. */ + for (int prio = MAX_PRIORITY; prio >= 0; prio--) + { + for (q = p; q != NO_NODE; FORWARD (q)) + { + if (operator_with_priority (q, prio)) + { + bool siga = false; + NODE_T *op = NEXT (q); + if (IS (q, SECONDARY)) + { + reduce (q, NO_NOTE, &siga, FORMULA, SECONDARY, OPERATOR, SECONDARY, STOP); + reduce (q, NO_NOTE, &siga, FORMULA, SECONDARY, OPERATOR, MONADIC_FORMULA, STOP); + reduce (q, NO_NOTE, &siga, FORMULA, SECONDARY, OPERATOR, FORMULA, STOP); + } + else if (IS (q, MONADIC_FORMULA)) + { + reduce (q, NO_NOTE, &siga, FORMULA, MONADIC_FORMULA, OPERATOR, SECONDARY, STOP); + reduce (q, NO_NOTE, &siga, FORMULA, MONADIC_FORMULA, OPERATOR, MONADIC_FORMULA, STOP); + reduce (q, NO_NOTE, &siga, FORMULA, MONADIC_FORMULA, OPERATOR, FORMULA, STOP); + } + if (prio == 0 && siga) + a68_error (op, "S has no priority declaration"); + siga = true; + while (siga) + { + NODE_T *op2 = NEXT (q); + siga = false; + if (operator_with_priority (q, prio)) + reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, SECONDARY, STOP); + if (operator_with_priority (q, prio)) + reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, MONADIC_FORMULA, STOP); + if (operator_with_priority (q, prio)) + reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, FORMULA, STOP); + if (prio == 0 && siga) + a68_error (op2, "S has no priority declaration"); + } + } + } + } +} + +/* Reduce dyadic expressions. */ + +static NODE_T * +reduce_dyadic (NODE_T *p, int u) +{ + /* We work inside out - higher priority expressions get reduced first. */ + if (u > MAX_PRIORITY) + { + if (p == NO_NODE) + return NO_NODE; + else if (IS (p, OPERATOR)) + { + /* Reduce monadic formulas. */ + NODE_T *q = p; + bool siga; + do + { + PRIO (INFO (q)) = 10; + siga = ((NEXT (q) != NO_NODE) && (IS (NEXT (q), OPERATOR))); + if (siga) + FORWARD (q); + } + while (siga); + reduce (q, NO_NOTE, NO_TICK, MONADIC_FORMULA, OPERATOR, SECONDARY, STOP); + while (q != p) + { + BACKWARD (q); + reduce (q, NO_NOTE, NO_TICK, MONADIC_FORMULA, OPERATOR, MONADIC_FORMULA, STOP); + } + } + FORWARD (p); + } + else + { + p = reduce_dyadic (p, u + 1); + while (p != NO_NODE && IS (p, OPERATOR) && PRIO (INFO (p)) == u) + { + FORWARD (p); + p = reduce_dyadic (p, u + 1); + } + } + return p; +} + +/* Reduce tertiaries completely. */ + +static void +reduce_tertiaries (NODE_T *p) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, TERTIARY, NIHIL, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMULA, MONADIC_FORMULA, STOP); + reduce (q, NO_NOTE, NO_TICK, TERTIARY, FORMULA, STOP); + reduce (q, NO_NOTE, NO_TICK, TERTIARY, SECONDARY, STOP); + } + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, IDENTITY_RELATION, TERTIARY, IS_SYMBOL, TERTIARY, STOP); + reduce (q, NO_NOTE, NO_TICK, IDENTITY_RELATION, TERTIARY, ISNT_SYMBOL, TERTIARY, STOP); + } + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, AND_FUNCTION, TERTIARY, ANDF_SYMBOL, TERTIARY, STOP); + reduce (q, NO_NOTE, NO_TICK, OR_FUNCTION, TERTIARY, ORF_SYMBOL, TERTIARY, STOP); + } +} + +/* Reduce units. */ + +static void +reduce_units (NODE_T * p) +{ + /* Stray ~ is a SKIP. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, OPERATOR) && IS_LITERALLY (q, "~")) + ATTRIBUTE (q) = SKIP; + } + + /* Reduce units. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, UNIT, ASSIGNATION, STOP); + reduce (q, NO_NOTE, NO_TICK, UNIT, IDENTITY_RELATION, STOP); + reduce (q, a68_extension, NO_TICK, UNIT, AND_FUNCTION, STOP); + reduce (q, a68_extension, NO_TICK, UNIT, OR_FUNCTION, STOP); + reduce (q, NO_NOTE, NO_TICK, UNIT, ROUTINE_TEXT, STOP); + reduce (q, NO_NOTE, NO_TICK, UNIT, JUMP, STOP); + reduce (q, NO_NOTE, NO_TICK, UNIT, SKIP, STOP); + reduce (q, NO_NOTE, NO_TICK, UNIT, TERTIARY, STOP); + reduce (q, NO_NOTE, NO_TICK, UNIT, ASSERTION, STOP); + } +} + +/* Reduce_generic arguments. */ + +static void +reduce_generic_arguments (NODE_T *p) +{ + NODE_T *q; bool siga; /* In this scope. */ + + for (q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, UNIT)) + { + reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, UNIT, AT_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, AT_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, STOP); + } + else if (IS (q, COLON_SYMBOL)) + { + reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, UNIT, AT_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, AT_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, STOP); + } + } + + for (q = p; q != NO_NODE; FORWARD (q)) + reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, AT_SYMBOL, UNIT, STOP); + for (q = p; q != NO_NODE; FORWARD (q)) + reduce (q, NO_NOTE, NO_TICK, TRIMMER, AT_SYMBOL, UNIT, STOP); + for (q = p; q && NEXT (q); FORWARD (q)) + { + if (IS (q, COMMA_SYMBOL)) + { + if (!(ATTRIBUTE (NEXT (q)) == UNIT || ATTRIBUTE (NEXT (q)) == TRIMMER)) + pad_node (q, TRIMMER); + } + else + { + if (IS (NEXT (q), COMMA_SYMBOL)) + { + if (!IS (q, UNIT) && !IS (q, TRIMMER)) + pad_node (q, TRIMMER); + } + } + } + + q = NEXT (p); + if (q == NO_NODE) + gcc_unreachable (); + reduce (q, NO_NOTE, NO_TICK, GENERIC_ARGUMENT_LIST, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, GENERIC_ARGUMENT_LIST, TRIMMER, STOP); + do + { + siga = false; + reduce (q, NO_NOTE, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, COMMA_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, COMMA_SYMBOL, TRIMMER, STOP); + reduce (q, strange_separator, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, UNIT, STOP); + reduce (q, strange_separator, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, TRIMMER, STOP); + } + while (siga); +} + +/* Reduce bounds. */ + +static void +reduce_bounds (NODE_T *p) +{ + NODE_T *q; bool siga; + + for (q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, BOUND, UNIT, COLON_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, BOUND, UNIT, STOP); + } + q = NEXT (p); + reduce (q, NO_NOTE, NO_TICK, BOUNDS_LIST, BOUND, STOP); + reduce (q, NO_NOTE, NO_TICK, FORMAL_BOUNDS_LIST, COMMA_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, ALT_FORMAL_BOUNDS_LIST, COLON_SYMBOL, STOP); + do + { + siga = false; + reduce (q, NO_NOTE, &siga, BOUNDS_LIST, BOUNDS_LIST, COMMA_SYMBOL, BOUND, STOP); + reduce (q, NO_NOTE, &siga, FORMAL_BOUNDS_LIST, FORMAL_BOUNDS_LIST, COMMA_SYMBOL, STOP); + reduce (q, NO_NOTE, &siga, ALT_FORMAL_BOUNDS_LIST, FORMAL_BOUNDS_LIST, COLON_SYMBOL, STOP); + reduce (q, NO_NOTE, &siga, FORMAL_BOUNDS_LIST, ALT_FORMAL_BOUNDS_LIST, COMMA_SYMBOL, STOP); + reduce (q, strange_separator, &siga, BOUNDS_LIST, BOUNDS_LIST, BOUND, STOP); + } + while (siga); +} + +/* Reduce argument packs. */ + +static void +reduce_arguments (NODE_T *p) +{ + if (NEXT (p) != NO_NODE) + { + NODE_T *q = NEXT (p); + bool siga; + reduce (q, NO_NOTE, NO_TICK, ARGUMENT_LIST, UNIT, STOP); + do + { + siga = false; + reduce (q, NO_NOTE, &siga, ARGUMENT_LIST, ARGUMENT_LIST, COMMA_SYMBOL, UNIT, STOP); + reduce (q, strange_separator, &siga, ARGUMENT_LIST, ARGUMENT_LIST, UNIT, STOP); + } + while (siga); + } +} + +/* Reduce declarations. */ + +static void +reduce_basic_declarations (NODE_T *p) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + /* Publicized declarations. */ + reduce (q, NO_NOTE, NO_TICK, + PRIORITY_DECLARATION, PUBLIC_SYMBOL, + PRIO_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, PRIORITY, STOP); + reduce (q, NO_NOTE, NO_TICK, + MODE_DECLARATION, PUBLIC_SYMBOL, + MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, DECLARER, STOP); + reduce (q, NO_NOTE, NO_TICK, + MODE_DECLARATION, PUBLIC_SYMBOL, + MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, VOID_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, + PROCEDURE_DECLARATION, PUBLIC_SYMBOL, + PROC_SYMBOL, DEFINING_IDENTIFIER, EQUALS_SYMBOL, ROUTINE_TEXT, STOP); + reduce (q, NO_NOTE, NO_TICK, + PROCEDURE_VARIABLE_DECLARATION, PUBLIC_SYMBOL, + PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, ROUTINE_TEXT, + STOP); + reduce (q, NO_NOTE, NO_TICK, + PROCEDURE_VARIABLE_DECLARATION, PUBLIC_SYMBOL, + QUALIFIER, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, + ROUTINE_TEXT, STOP); + reduce (q, NO_NOTE, NO_TICK, + BRIEF_OPERATOR_DECLARATION, PUBLIC_SYMBOL, + OP_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, ROUTINE_TEXT, STOP); + + reduce (q, NO_NOTE, NO_TICK, + PRIORITY_DECLARATION, PRIO_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, PRIORITY, STOP); + reduce (q, NO_NOTE, NO_TICK, + MODE_DECLARATION, MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, DECLARER, STOP); + reduce (q, NO_NOTE, NO_TICK, + MODE_DECLARATION, MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, VOID_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, + PROCEDURE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, EQUALS_SYMBOL, ROUTINE_TEXT, STOP); + reduce (q, NO_NOTE, NO_TICK, + PROCEDURE_VARIABLE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, ROUTINE_TEXT, + STOP); + reduce (q, NO_NOTE, NO_TICK, + PROCEDURE_VARIABLE_DECLARATION, QUALIFIER, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, + ROUTINE_TEXT, STOP); + reduce (q, NO_NOTE, NO_TICK, + BRIEF_OPERATOR_DECLARATION, OP_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, ROUTINE_TEXT, STOP); +#if 0 + /* XXX for local module definitions */ + reduce (q, NO_NOTE, NO_TICK, + MODULE_DECLARATION, MODULE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, MODULE_TEXT, STOP); +#endif + /* Errors. */ + reduce (q, strange_tokens, NO_TICK, + PRIORITY_DECLARATION, PRIO_SYMBOL, -DEFINING_OPERATOR, -EQUALS_SYMBOL, -PRIORITY, STOP); + reduce (q, strange_tokens, NO_TICK, + MODE_DECLARATION, MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, -DECLARER, STOP); + reduce (q, strange_tokens, NO_TICK, + PROCEDURE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, EQUALS_SYMBOL, -ROUTINE_TEXT, STOP); + reduce (q, strange_tokens, NO_TICK, + PROCEDURE_VARIABLE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, -ROUTINE_TEXT, + STOP); + reduce (q, strange_tokens, NO_TICK, + PROCEDURE_VARIABLE_DECLARATION, QUALIFIER, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, + -ROUTINE_TEXT, STOP); + reduce (q, strange_tokens, NO_TICK, + BRIEF_OPERATOR_DECLARATION, OP_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, -ROUTINE_TEXT, STOP); +#if 0 + /* XXX for local module definitions */ + reduce (q, strange_tokens, NO_TICK, + MODULE_DECLARATION, MODULE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, -MODULE_TEXT, STOP); +#endif + /* Errors. WILDCARD catches TERTIARY which catches IDENTIFIER. */ + reduce (q, strange_tokens, NO_TICK, PROCEDURE_DECLARATION, PROC_SYMBOL, WILDCARD, ROUTINE_TEXT, STOP); + } + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + bool siga; + do + { + siga = false; + reduce (q, NO_NOTE, &siga, + PRIORITY_DECLARATION, PRIORITY_DECLARATION, COMMA_SYMBOL, DEFINING_OPERATOR, + EQUALS_SYMBOL, PRIORITY, STOP); + reduce (q, NO_NOTE, &siga, + MODE_DECLARATION, MODE_DECLARATION, COMMA_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, + DECLARER, STOP); + reduce (q, NO_NOTE, &siga, + MODE_DECLARATION, MODE_DECLARATION, COMMA_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, + VOID_SYMBOL, STOP); + reduce (q, NO_NOTE, &siga, + PROCEDURE_DECLARATION, PROCEDURE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, + EQUALS_SYMBOL, ROUTINE_TEXT, STOP); + reduce (q, NO_NOTE, &siga, + PROCEDURE_VARIABLE_DECLARATION, PROCEDURE_VARIABLE_DECLARATION, COMMA_SYMBOL, + DEFINING_IDENTIFIER, ASSIGN_SYMBOL, ROUTINE_TEXT, STOP); + reduce (q, NO_NOTE, &siga, + BRIEF_OPERATOR_DECLARATION, BRIEF_OPERATOR_DECLARATION, COMMA_SYMBOL, + DEFINING_OPERATOR, EQUALS_SYMBOL, ROUTINE_TEXT, STOP); +#if 0 + /* XXX for local module definitions */ + reduce (q, NO_NOTE, &siga, + MODULE_DECLARATION, MODULE_DECLARATION, COMMA_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, + MODULE_TEXT, STOP); +#endif + /* Errors. WILDCARD catches TERTIARY which catches IDENTIFIER. */ + reduce (q, strange_tokens, &siga, + PROCEDURE_DECLARATION, PROCEDURE_DECLARATION, COMMA_SYMBOL, WILDCARD, ROUTINE_TEXT, STOP); + } + while (siga); + } +} + +/* Reduce declaration lists. */ + +static void +reduce_declaration_lists (NODE_T *p) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, + IDENTITY_DECLARATION, PUBLIC_SYMBOL, + DECLARER, DEFINING_IDENTIFIER, EQUALS_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, + VARIABLE_DECLARATION, PUBLIC_SYMBOL, + QUALIFIER, DECLARER, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, + VARIABLE_DECLARATION, PUBLIC_SYMBOL, + QUALIFIER, DECLARER, DEFINING_IDENTIFIER, STOP); + reduce (q, NO_NOTE, NO_TICK, + VARIABLE_DECLARATION, PUBLIC_SYMBOL, + DECLARER, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, + VARIABLE_DECLARATION, PUBLIC_SYMBOL, + DECLARER, DEFINING_IDENTIFIER, STOP); + + reduce (q, NO_NOTE, NO_TICK, + IDENTITY_DECLARATION, DECLARER, DEFINING_IDENTIFIER, EQUALS_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, + VARIABLE_DECLARATION, QUALIFIER, DECLARER, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, + VARIABLE_DECLARATION, QUALIFIER, DECLARER, DEFINING_IDENTIFIER, STOP); + reduce (q, NO_NOTE, NO_TICK, + VARIABLE_DECLARATION, DECLARER, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, + VARIABLE_DECLARATION, DECLARER, DEFINING_IDENTIFIER, STOP); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + bool siga; + do + { + siga = false; + reduce (q, NO_NOTE, &siga, + IDENTITY_DECLARATION, IDENTITY_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, + EQUALS_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, &siga, + VARIABLE_DECLARATION, VARIABLE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, + ASSIGN_SYMBOL, UNIT, STOP); + if (!a68_whether (q, VARIABLE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, + ASSIGN_SYMBOL, UNIT, STOP)) + reduce (q, NO_NOTE, &siga, + VARIABLE_DECLARATION, VARIABLE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, STOP); + } + while (siga); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, + OPERATOR_DECLARATION, PUBLIC_SYMBOL, + OPERATOR_PLAN, DEFINING_OPERATOR, EQUALS_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, + OPERATOR_DECLARATION, OPERATOR_PLAN, DEFINING_OPERATOR, EQUALS_SYMBOL, UNIT, STOP); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + bool siga; + do + { + siga = false; + reduce (q, NO_NOTE, &siga, + OPERATOR_DECLARATION, OPERATOR_DECLARATION, COMMA_SYMBOL, DEFINING_OPERATOR, + EQUALS_SYMBOL, UNIT, STOP); + } + while (siga); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, MODE_DECLARATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, PRIORITY_DECLARATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, BRIEF_OPERATOR_DECLARATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, OPERATOR_DECLARATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, IDENTITY_DECLARATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, PROCEDURE_DECLARATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, PROCEDURE_VARIABLE_DECLARATION, STOP); + reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, VARIABLE_DECLARATION, STOP); +#if 0 + /* XXX for local module definitions */ + reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, MODULE_DECLARATION, STOP); +#endif + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + bool siga; + do + { + siga = false; + reduce (q, NO_NOTE, &siga, + DECLARATION_LIST, DECLARATION_LIST, COMMA_SYMBOL, DECLARATION_LIST, STOP); + } + while (siga); + } +} + +/* Reduce module text. */ + +static void +reduce_module_texts (NODE_T *p) +{ + if (IS (p, ALT_ACCESS_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, + REVELATION, ALT_ACCESS_SYMBOL, PUBLIC_SYMBOL, MODULE_INDICANT, STOP); + reduce (p, NO_NOTE, NO_TICK, + REVELATION, ALT_ACCESS_SYMBOL, MODULE_INDICANT, STOP); + bool siga; + do + { + siga = false; + reduce (p, NO_NOTE, &siga, + REVELATION, REVELATION, COMMA_SYMBOL, PUBLIC_SYMBOL, MODULE_INDICANT, STOP); + reduce (p, NO_NOTE, &siga, + REVELATION, REVELATION, COMMA_SYMBOL, MODULE_INDICANT, STOP); + } + while (siga); + reduce (p, NO_NOTE, NO_TICK, REVELATION_PART, REVELATION, STOP); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + reduce (q, NO_NOTE, NO_TICK, MODULE_TEXT, REVELATION_PART, DEF_PART, POSTLUDE_PART, FED_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, MODULE_TEXT, REVELATION_PART, DEF_PART, FED_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, MODULE_TEXT, DEF_PART, POSTLUDE_PART, FED_SYMBOL, STOP); + reduce (q, NO_NOTE, NO_TICK, MODULE_TEXT, DEF_PART, FED_SYMBOL, STOP); + } +} + +/* Reduce def-parts and postlude-parts. + Note that revelations are reduced in reduce_module_texts. */ + +static void +reduce_module_text_parts (NODE_T *p) +{ + if (IS (p, DEF_SYMBOL)) + { + reduce_enquiry_clauses (p); + reduce (p, NO_NOTE, NO_TICK, DEF_PART, DEF_SYMBOL, ENQUIRY_CLAUSE, STOP); + } + else if (IS (p, POSTLUDE_SYMBOL)) + { + reduce_serial_clauses (p); + reduce (p, NO_NOTE, NO_TICK, POSTLUDE_PART, POSTLUDE_SYMBOL, SERIAL_CLAUSE, STOP); + } +} + +/* Reduce serial clauses. */ + +static void +reduce_serial_clauses (NODE_T *p) +{ + if (NEXT (p) != NO_NODE) + { + NODE_T *q = NEXT (p), *u; + bool siga, label_seen; + /* Check wrong exits. */ + for (u = q; u != NO_NODE; FORWARD (u)) + { + if (IS (u, EXIT_SYMBOL)) + { + if (NEXT (u) == NO_NODE || !IS (NEXT (u), LABELED_UNIT)) + a68_error (u, "S must be followed by a labeled unit"); + } + } + + /* Check wrong jumps and declarations. */ + for (u = q, label_seen = false; u != NO_NODE; FORWARD (u)) + { + if (IS (u, LABELED_UNIT)) + label_seen = true; + else if (IS (u, DECLARATION_LIST)) + { + if (label_seen) + a68_error (u, "declaration cannot follow a labeled unit"); + } + } + + /* Reduce serial clauses. */ + reduce (q, NO_NOTE, NO_TICK, SERIAL_CLAUSE, LABELED_UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, SERIAL_CLAUSE, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, INITIALISER_SERIES, DECLARATION_LIST, STOP); + do + { + siga = false; + if (IS (q, SERIAL_CLAUSE)) + { + reduce (q, NO_NOTE, &siga, + SERIAL_CLAUSE, SERIAL_CLAUSE, SEMI_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, &siga, + SERIAL_CLAUSE, SERIAL_CLAUSE, EXIT_SYMBOL, LABELED_UNIT, STOP); + reduce (q, NO_NOTE, &siga, + SERIAL_CLAUSE, SERIAL_CLAUSE, SEMI_SYMBOL, LABELED_UNIT, STOP); + reduce (q, NO_NOTE, &siga, + INITIALISER_SERIES, SERIAL_CLAUSE, SEMI_SYMBOL, DECLARATION_LIST, STOP); + /* Errors */ + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, SERIAL_CLAUSE, COMMA_SYMBOL, UNIT, STOP); + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, SERIAL_CLAUSE, COMMA_SYMBOL, LABELED_UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, SERIAL_CLAUSE, COMMA_SYMBOL, DECLARATION_LIST, STOP); + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, SERIAL_CLAUSE, COLON_SYMBOL, UNIT, STOP); + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, SERIAL_CLAUSE, COLON_SYMBOL, LABELED_UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, SERIAL_CLAUSE, COLON_SYMBOL, DECLARATION_LIST, STOP); + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, SERIAL_CLAUSE, UNIT, STOP); + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, SERIAL_CLAUSE, LABELED_UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, SERIAL_CLAUSE, DECLARATION_LIST, STOP); + } + else if (IS (q, INITIALISER_SERIES)) + { + reduce (q, NO_NOTE, &siga, + SERIAL_CLAUSE, INITIALISER_SERIES, SEMI_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, &siga, + SERIAL_CLAUSE, INITIALISER_SERIES, SEMI_SYMBOL, LABELED_UNIT, STOP); + reduce (q, NO_NOTE, &siga, + INITIALISER_SERIES, INITIALISER_SERIES, SEMI_SYMBOL, DECLARATION_LIST, STOP); + /* Errors */ + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, INITIALISER_SERIES, COMMA_SYMBOL, UNIT, STOP); + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, INITIALISER_SERIES, COMMA_SYMBOL, LABELED_UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, INITIALISER_SERIES, COMMA_SYMBOL, DECLARATION_LIST, STOP); + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, INITIALISER_SERIES, COLON_SYMBOL, UNIT, STOP); + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, INITIALISER_SERIES, COLON_SYMBOL, LABELED_UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, INITIALISER_SERIES, COLON_SYMBOL, DECLARATION_LIST, STOP); + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, INITIALISER_SERIES, UNIT, STOP); + reduce (q, strange_separator, &siga, + SERIAL_CLAUSE, INITIALISER_SERIES, LABELED_UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, INITIALISER_SERIES, DECLARATION_LIST, STOP); + } + } + while (siga); + } +} + +/* Reduce enquiry clauses. */ + +static void +reduce_enquiry_clauses (NODE_T *p) +{ + if (NEXT (p) != NO_NODE) + { + NODE_T *q = NEXT (p); + bool siga; + reduce (q, NO_NOTE, NO_TICK, ENQUIRY_CLAUSE, UNIT, STOP); + reduce (q, NO_NOTE, NO_TICK, INITIALISER_SERIES, DECLARATION_LIST, STOP); + do + { + siga = false; + if (IS (q, ENQUIRY_CLAUSE)) + { + reduce (q, NO_NOTE, &siga, + ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, SEMI_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, &siga, + INITIALISER_SERIES, ENQUIRY_CLAUSE, SEMI_SYMBOL, DECLARATION_LIST, STOP); + reduce (q, strange_separator, &siga, + ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, COMMA_SYMBOL, UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, ENQUIRY_CLAUSE, COMMA_SYMBOL, DECLARATION_LIST, STOP); + reduce (q, strange_separator, &siga, + ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, COLON_SYMBOL, UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, ENQUIRY_CLAUSE, COLON_SYMBOL, DECLARATION_LIST, STOP); + reduce (q, strange_separator, &siga, + ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, ENQUIRY_CLAUSE, DECLARATION_LIST, STOP); + } + else if (IS (q, INITIALISER_SERIES)) + { + reduce (q, NO_NOTE, &siga, + ENQUIRY_CLAUSE, INITIALISER_SERIES, SEMI_SYMBOL, UNIT, STOP); + reduce (q, NO_NOTE, &siga, + INITIALISER_SERIES, INITIALISER_SERIES, SEMI_SYMBOL, DECLARATION_LIST, STOP); + reduce (q, strange_separator, &siga, + ENQUIRY_CLAUSE, INITIALISER_SERIES, COMMA_SYMBOL, UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, INITIALISER_SERIES, COMMA_SYMBOL, DECLARATION_LIST, STOP); + reduce (q, strange_separator, &siga, + ENQUIRY_CLAUSE, INITIALISER_SERIES, COLON_SYMBOL, UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, INITIALISER_SERIES, COLON_SYMBOL, DECLARATION_LIST, STOP); + reduce (q, strange_separator, &siga, + ENQUIRY_CLAUSE, INITIALISER_SERIES, UNIT, STOP); + reduce (q, strange_separator, &siga, + INITIALISER_SERIES, INITIALISER_SERIES, DECLARATION_LIST, STOP); + } + } + while (siga); + } +} + +/* Reduce collateral clauses. */ + +static void +reduce_collateral_clauses (NODE_T *p) +{ + if (NEXT (p) != NO_NODE) + { + NODE_T *q = NEXT (p); + if (IS (q, UNIT)) + { + bool siga; + reduce (q, NO_NOTE, NO_TICK, UNIT_LIST, UNIT, STOP); + do + { + siga = false; + reduce (q, NO_NOTE, &siga, UNIT_LIST, UNIT_LIST, COMMA_SYMBOL, UNIT, STOP); + reduce (q, strange_separator, &siga, UNIT_LIST, UNIT_LIST, UNIT, STOP); + } + while (siga); + } + else if (IS (q, SPECIFIED_UNIT)) + { + bool siga; + reduce (q, NO_NOTE, NO_TICK, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP); + do + { + siga = false; + reduce (q, NO_NOTE, &siga, + SPECIFIED_UNIT_LIST, SPECIFIED_UNIT_LIST, COMMA_SYMBOL, SPECIFIED_UNIT, STOP); + reduce (q, strange_separator, &siga, + SPECIFIED_UNIT_LIST, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP); + } + while (siga); + } + } +} + +/* Reduces enclosed clauses. */ + +static void +reduce_enclosed_clauses (NODE_T *q, enum a68_attribute expect) +{ + NODE_T *p = q; + + if (SUB (p) == NO_NODE) + { + if (IS (p, FOR_SYMBOL)) + reduce (p, NO_NOTE, NO_TICK, FOR_PART, FOR_SYMBOL, DEFINING_IDENTIFIER, STOP); + else if (IS (p, OPEN_SYMBOL)) + { + if (expect == ENQUIRY_CLAUSE) + reduce (p, NO_NOTE, NO_TICK, OPEN_PART, OPEN_SYMBOL, ENQUIRY_CLAUSE, STOP); + else if (expect == ARGUMENT) + { + reduce (p, NO_NOTE, NO_TICK, ARGUMENT, OPEN_SYMBOL, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, ARGUMENT, OPEN_SYMBOL, ARGUMENT_LIST, CLOSE_SYMBOL, STOP); + reduce (p, empty_clause, NO_TICK, ARGUMENT, OPEN_SYMBOL, INITIALISER_SERIES, CLOSE_SYMBOL, STOP); + } + else if (expect == GENERIC_ARGUMENT) + { + if (a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP)) + { + pad_node (p, TRIMMER); + reduce (p, NO_NOTE, NO_TICK, GENERIC_ARGUMENT, OPEN_SYMBOL, TRIMMER, CLOSE_SYMBOL, STOP); + } + reduce (p, NO_NOTE, NO_TICK, + GENERIC_ARGUMENT, OPEN_SYMBOL, GENERIC_ARGUMENT_LIST, CLOSE_SYMBOL, STOP); + } + else if (expect == BOUNDS) + { + reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, OPEN_SYMBOL, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, BOUNDS, OPEN_SYMBOL, BOUNDS_LIST, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, OPEN_SYMBOL, FORMAL_BOUNDS_LIST, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + FORMAL_BOUNDS, OPEN_SYMBOL, ALT_FORMAL_BOUNDS_LIST, CLOSE_SYMBOL, STOP); + } + else + { + reduce (p, NO_NOTE, NO_TICK, CLOSED_CLAUSE, OPEN_SYMBOL, SERIAL_CLAUSE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, OPEN_SYMBOL, UNIT_LIST, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, OPEN_SYMBOL, CLOSE_SYMBOL, STOP); + reduce (p, empty_clause, NO_TICK, + CLOSED_CLAUSE, OPEN_SYMBOL, INITIALISER_SERIES, CLOSE_SYMBOL, STOP); + } + } + else if (IS (p, SUB_SYMBOL)) + { + if (expect == GENERIC_ARGUMENT) + { + if (a68_whether (p, SUB_SYMBOL, BUS_SYMBOL, STOP)) + { + pad_node (p, TRIMMER); + reduce (p, NO_NOTE, NO_TICK, GENERIC_ARGUMENT, SUB_SYMBOL, TRIMMER, BUS_SYMBOL, STOP); + } + reduce (p, NO_NOTE, NO_TICK, + GENERIC_ARGUMENT, SUB_SYMBOL, GENERIC_ARGUMENT_LIST, BUS_SYMBOL, STOP); + } + else if (expect == BOUNDS) + { + reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, SUB_SYMBOL, BUS_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, BOUNDS, SUB_SYMBOL, BOUNDS_LIST, BUS_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, SUB_SYMBOL, FORMAL_BOUNDS_LIST, BUS_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, SUB_SYMBOL, ALT_FORMAL_BOUNDS_LIST, BUS_SYMBOL, STOP); + } + } + else if (IS (p, BEGIN_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, BEGIN_SYMBOL, UNIT_LIST, END_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, BEGIN_SYMBOL, END_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, CLOSED_CLAUSE, BEGIN_SYMBOL, SERIAL_CLAUSE, END_SYMBOL, STOP); + reduce (p, empty_clause, NO_TICK, CLOSED_CLAUSE, BEGIN_SYMBOL, INITIALISER_SERIES, END_SYMBOL, STOP); + } + else if (IS (p, FORMAT_DELIMITER_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, + FORMAT_TEXT, FORMAT_DELIMITER_SYMBOL, PICTURE_LIST, FORMAT_DELIMITER_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + FORMAT_TEXT, FORMAT_DELIMITER_SYMBOL, FORMAT_DELIMITER_SYMBOL, STOP); + } + else if (IS (p, FORMAT_OPEN_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, + COLLECTION, FORMAT_OPEN_SYMBOL, PICTURE_LIST, FORMAT_CLOSE_SYMBOL, STOP); + } + else if (IS (p, ACCESS_SYMBOL)) + { + NODE_T *s; + for (s = p; s != NO_NODE; FORWARD (s)) + { + if (SUB (s) != NO_NODE) + { + // XXX why + if (IS (SUB (s), OPEN_SYMBOL)) + reduce_branch (s, SOME_CLAUSE); + else + reduce_branch (s, ENCLOSED_CLAUSE); + } + reduce (s, NO_NOTE, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); + reduce (s, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, PARALLEL_CLAUSE, STOP); + reduce (s, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CLOSED_CLAUSE, STOP); + reduce (s, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, COLLATERAL_CLAUSE, STOP); + reduce (s, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONDITIONAL_CLAUSE, STOP); + reduce (s, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CASE_CLAUSE, STOP); + reduce (s, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONFORMITY_CLAUSE, STOP); + reduce (s, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, LOOP_CLAUSE, STOP); + reduce (s, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, ACCESS_CLAUSE, STOP); + } + // XXX reduce revelations + reduce (p, NO_NOTE, NO_TICK, + ACCESS_CLAUSE, ACCESS_SYMBOL, MODULE_INDICANT, ENCLOSED_CLAUSE, STOP); + } + else if (IS (p, IF_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, IF_PART, IF_SYMBOL, ENQUIRY_CLAUSE, STOP); + reduce (p, empty_clause, NO_TICK, IF_PART, IF_SYMBOL, INITIALISER_SERIES, STOP); + } + else if (IS (p, THEN_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, THEN_PART, THEN_SYMBOL, SERIAL_CLAUSE, STOP); + reduce (p, empty_clause, NO_TICK, THEN_PART, THEN_SYMBOL, INITIALISER_SERIES, STOP); + } + else if (IS (p, ELSE_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, ELSE_PART, ELSE_SYMBOL, SERIAL_CLAUSE, STOP); + reduce (p, empty_clause, NO_TICK, ELSE_PART, ELSE_SYMBOL, INITIALISER_SERIES, STOP); + } + else if (IS (p, ELIF_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, ELIF_IF_PART, ELIF_SYMBOL, ENQUIRY_CLAUSE, STOP); + } + else if (IS (p, CASE_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, CASE_PART, CASE_SYMBOL, ENQUIRY_CLAUSE, STOP); + reduce (p, empty_clause, NO_TICK, CASE_PART, CASE_SYMBOL, INITIALISER_SERIES, STOP); + } + else if (IS (p, IN_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, CASE_IN_PART, IN_SYMBOL, UNIT_LIST, STOP); + reduce (p, NO_NOTE, NO_TICK, CONFORMITY_IN_PART, IN_SYMBOL, SPECIFIED_UNIT_LIST, STOP); + } + else if (IS (p, OUT_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, OUT_PART, OUT_SYMBOL, SERIAL_CLAUSE, STOP); + reduce (p, empty_clause, NO_TICK, OUT_PART, OUT_SYMBOL, INITIALISER_SERIES, STOP); + } + else if (IS (p, OUSE_SYMBOL)) + reduce (p, NO_NOTE, NO_TICK, OUSE_PART, OUSE_SYMBOL, ENQUIRY_CLAUSE, STOP); + else if (IS (p, THEN_BAR_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, CHOICE, THEN_BAR_SYMBOL, SERIAL_CLAUSE, STOP); + reduce (p, NO_NOTE, NO_TICK, CASE_CHOICE_CLAUSE, THEN_BAR_SYMBOL, UNIT_LIST, STOP); + reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CHOICE, THEN_BAR_SYMBOL, SPECIFIED_UNIT_LIST, STOP); + reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CHOICE, THEN_BAR_SYMBOL, SPECIFIED_UNIT, STOP); + reduce (p, empty_clause, NO_TICK, CHOICE, THEN_BAR_SYMBOL, INITIALISER_SERIES, STOP); + } + else if (IS (p, ELSE_BAR_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, ELSE_OPEN_PART, ELSE_BAR_SYMBOL, ENQUIRY_CLAUSE, STOP); + reduce (p, empty_clause, NO_TICK, ELSE_OPEN_PART, ELSE_BAR_SYMBOL, INITIALISER_SERIES, STOP); + } + else if (IS (p, FROM_SYMBOL)) + reduce (p, NO_NOTE, NO_TICK, FROM_PART, FROM_SYMBOL, UNIT, STOP); + else if (IS (p, BY_SYMBOL)) + reduce (p, NO_NOTE, NO_TICK, BY_PART, BY_SYMBOL, UNIT, STOP); + else if (IS (p, TO_SYMBOL)) + reduce (p, NO_NOTE, NO_TICK, TO_PART, TO_SYMBOL, UNIT, STOP); + else if (IS (p, WHILE_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, WHILE_PART, WHILE_SYMBOL, ENQUIRY_CLAUSE, STOP); + reduce (p, empty_clause, NO_TICK, WHILE_PART, WHILE_SYMBOL, INITIALISER_SERIES, STOP); + } + else if (IS (p, DO_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, DO_PART, DO_SYMBOL, SERIAL_CLAUSE, OD_SYMBOL, STOP); + } + else if (IS (p, ALT_DO_SYMBOL)) + { + reduce (p, NO_NOTE, NO_TICK, ALT_DO_PART, ALT_DO_SYMBOL, SERIAL_CLAUSE, OD_SYMBOL, STOP); + } + } + p = q; + if (SUB (p) != NO_NODE) + { + if (IS (p, OPEN_PART)) + { + reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, OPEN_PART, CHOICE, CHOICE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, OPEN_PART, CHOICE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, OPEN_PART, CHOICE, BRIEF_ELIF_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, OPEN_PART, CASE_CHOICE_CLAUSE, CHOICE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, OPEN_PART, CASE_CHOICE_CLAUSE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, OPEN_PART, CASE_CHOICE_CLAUSE, BRIEF_OUSE_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, + CONFORMITY_CLAUSE, OPEN_PART, CONFORMITY_CHOICE, CHOICE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + CONFORMITY_CLAUSE, OPEN_PART, CONFORMITY_CHOICE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + CONFORMITY_CLAUSE, OPEN_PART, CONFORMITY_CHOICE, BRIEF_CONFORMITY_OUSE_PART, STOP); + } + else if (IS (p, ELSE_OPEN_PART)) + { + reduce (p, NO_NOTE, NO_TICK, BRIEF_ELIF_PART, ELSE_OPEN_PART, CHOICE, CHOICE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, BRIEF_ELIF_PART, ELSE_OPEN_PART, CHOICE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, BRIEF_ELIF_PART, ELSE_OPEN_PART, CHOICE, BRIEF_ELIF_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, + BRIEF_OUSE_PART, ELSE_OPEN_PART, CASE_CHOICE_CLAUSE, CHOICE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, BRIEF_OUSE_PART, ELSE_OPEN_PART, CASE_CHOICE_CLAUSE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + BRIEF_OUSE_PART, ELSE_OPEN_PART, CASE_CHOICE_CLAUSE, BRIEF_OUSE_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, + BRIEF_CONFORMITY_OUSE_PART, ELSE_OPEN_PART, CONFORMITY_CHOICE, CHOICE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + BRIEF_CONFORMITY_OUSE_PART, ELSE_OPEN_PART, CONFORMITY_CHOICE, CLOSE_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + BRIEF_CONFORMITY_OUSE_PART, ELSE_OPEN_PART, CONFORMITY_CHOICE, BRIEF_CONFORMITY_OUSE_PART, + STOP); + } + else if (IS (p, IF_PART)) + { + reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, IF_PART, THEN_PART, ELSE_PART, FI_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, IF_PART, THEN_PART, ELIF_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, IF_PART, THEN_PART, FI_SYMBOL, STOP); + } + else if (IS (p, ELIF_IF_PART)) + { + reduce (p, NO_NOTE, NO_TICK, ELIF_PART, ELIF_IF_PART, THEN_PART, ELSE_PART, FI_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, ELIF_PART, ELIF_IF_PART, THEN_PART, FI_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, ELIF_PART, ELIF_IF_PART, THEN_PART, ELIF_PART, STOP); + } + else if (IS (p, CASE_PART)) + { + reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, CASE_PART, CASE_IN_PART, OUT_PART, ESAC_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, CASE_PART, CASE_IN_PART, ESAC_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, CASE_PART, CASE_IN_PART, CASE_OUSE_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, + CONFORMITY_CLAUSE, CASE_PART, CONFORMITY_IN_PART, OUT_PART, ESAC_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + CONFORMITY_CLAUSE, CASE_PART, CONFORMITY_IN_PART, ESAC_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + CONFORMITY_CLAUSE, CASE_PART, CONFORMITY_IN_PART, CONFORMITY_OUSE_PART, STOP); + } + else if (IS (p, OUSE_PART)) + { + reduce (p, NO_NOTE, NO_TICK, CASE_OUSE_PART, OUSE_PART, CASE_IN_PART, OUT_PART, ESAC_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, CASE_OUSE_PART, OUSE_PART, CASE_IN_PART, ESAC_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, CASE_OUSE_PART, OUSE_PART, CASE_IN_PART, CASE_OUSE_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, + CONFORMITY_OUSE_PART, OUSE_PART, CONFORMITY_IN_PART, OUT_PART, ESAC_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + CONFORMITY_OUSE_PART, OUSE_PART, CONFORMITY_IN_PART, ESAC_SYMBOL, STOP); + reduce (p, NO_NOTE, NO_TICK, + CONFORMITY_OUSE_PART, OUSE_PART, CONFORMITY_IN_PART, CONFORMITY_OUSE_PART, STOP); + } + else if (IS (p, FOR_PART)) + { + reduce (p, NO_NOTE, NO_TICK, + LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, TO_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, TO_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, TO_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, TO_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, ALT_DO_PART, STOP); + } + else if (IS (p, FROM_PART)) + { + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, TO_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, TO_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, ALT_DO_PART, STOP); + } + else if (IS (p, BY_PART)) + { + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, TO_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, ALT_DO_PART, STOP); + } + else if (IS (p, TO_PART)) + { + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, TO_PART, WHILE_PART, ALT_DO_PART, STOP); + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, TO_PART, ALT_DO_PART, STOP); + } + else if (IS (p, WHILE_PART)) + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, WHILE_PART, ALT_DO_PART, STOP); + else if (IS (p, DO_PART)) + reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, DO_PART, STOP); + } +} + +/* Substitute reduction when a phrase could not be parsed. */ + +static void +recover_from_error (NODE_T * p, enum a68_attribute expect, bool suppress) +{ + /* This routine does not do fancy things as that might introduce more + errors. */ + NODE_T *q = p; + if (p == NO_NODE) + return; + + if (expect == SOME_CLAUSE) + expect = serial_or_collateral (p); + + if (!suppress) + { + /* Give an error message. */ + NODE_T *w = p; + const char *seq = a68_phrase_to_text (p, &w); + if (strlen (seq) == 0) + { + if (ERROR_COUNT (&A68_JOB) == 0) + a68_error (w, "expected A", expect); + } + else + a68_error (w, "Y is an invalid A", seq, expect); + + if (ERROR_COUNT (&A68_JOB) >= MAX_ERRORS) + longjmp (A68_PARSER (bottom_up_crash_exit), 1); + } + + /* Try to prevent spurious diagnostics by guessing what was expected. */ + while (NEXT (q) != NO_NODE) + FORWARD (q); + + if (a68_is_one_of (p, BEGIN_SYMBOL, OPEN_SYMBOL, STOP)) + { + if (expect == ARGUMENT || expect == COLLATERAL_CLAUSE + || expect == PARAMETER_PACK || expect == STRUCTURE_PACK + || expect == UNION_PACK) + a68_make_sub (p, q, expect); + else if (expect == ENQUIRY_CLAUSE) + a68_make_sub (p, q, OPEN_PART); + else if (expect == FORMAL_DECLARERS) + a68_make_sub (p, q, FORMAL_DECLARERS); + else + a68_make_sub (p, q, CLOSED_CLAUSE); + } + else if (IS (p, FORMAT_DELIMITER_SYMBOL) && expect == FORMAT_TEXT) + a68_make_sub (p, q, FORMAT_TEXT); + else if (a68_is_one_of (p, THEN_BAR_SYMBOL, CHOICE, STOP)) + a68_make_sub (p, q, CHOICE); + else if (a68_is_one_of (p, IF_SYMBOL, IF_PART, STOP)) + a68_make_sub (p, q, IF_PART); + else if (a68_is_one_of (p, THEN_SYMBOL, THEN_PART, STOP)) + a68_make_sub (p, q, THEN_PART); + else if (a68_is_one_of (p, ELSE_SYMBOL, ELSE_PART, STOP)) + a68_make_sub (p, q, ELSE_PART); + else if (a68_is_one_of (p, ELIF_SYMBOL, ELIF_IF_PART, STOP)) + a68_make_sub (p, q, ELIF_IF_PART); + else if (a68_is_one_of (p, CASE_SYMBOL, CASE_PART, STOP)) + a68_make_sub (p, q, CASE_PART); + else if (a68_is_one_of (p, OUT_SYMBOL, OUT_PART, STOP)) + a68_make_sub (p, q, OUT_PART); + else if (a68_is_one_of (p, OUSE_SYMBOL, OUSE_PART, STOP)) + a68_make_sub (p, q, OUSE_PART); + else if (a68_is_one_of (p, FOR_SYMBOL, FOR_PART, STOP)) + a68_make_sub (p, q, FOR_PART); + else if (a68_is_one_of (p, FROM_SYMBOL, FROM_PART, STOP)) + a68_make_sub (p, q, FROM_PART); + else if (a68_is_one_of (p, BY_SYMBOL, BY_PART, STOP)) + a68_make_sub (p, q, BY_PART); + else if (a68_is_one_of (p, TO_SYMBOL, TO_PART, STOP)) + a68_make_sub (p, q, TO_PART); + else if (a68_is_one_of (p, WHILE_SYMBOL, WHILE_PART, STOP)) + a68_make_sub (p, q, WHILE_PART); + else if (a68_is_one_of (p, DO_SYMBOL, DO_PART, STOP)) + a68_make_sub (p, q, DO_PART); + else if (a68_is_one_of (p, ALT_DO_SYMBOL, ALT_DO_PART, STOP)) + a68_make_sub (p, q, ALT_DO_PART); + else if (a68_attribute_name (expect) != NO_TEXT) + a68_make_sub (p, q, expect); +} + +/* Heuristic aid in pinpointing errors. */ + +static void +reduce_erroneous_units (NODE_T *p) +{ + /* Constructs are reduced to units in an attempt to limit spurious + diagnostics. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + /* Some implementations allow selection from a tertiary, when there is no + risk of ambiguity. GCC follows RR, so some extra attention here to + guide an unsuspecting user. */ + if (a68_whether (q, SELECTOR, -SECONDARY, STOP)) + { + a68_error (NEXT (q), "expected A", SECONDARY); + reduce (q, NO_NOTE, NO_TICK, UNIT, SELECTOR, WILDCARD, STOP); + } + + /* Attention for identity relations that require tertiaries. */ + if (a68_whether (q, -TERTIARY, IS_SYMBOL, TERTIARY, STOP) + || a68_whether (q, TERTIARY, IS_SYMBOL, -TERTIARY, STOP) + || a68_whether (q, -TERTIARY, IS_SYMBOL, -TERTIARY, STOP)) + { + a68_error (NEXT (q), "expected A", TERTIARY); + reduce (q, NO_NOTE, NO_TICK, UNIT, WILDCARD, IS_SYMBOL, WILDCARD, STOP); + } + else if (a68_whether (q, -TERTIARY, ISNT_SYMBOL, TERTIARY, STOP) + || a68_whether (q, TERTIARY, ISNT_SYMBOL, -TERTIARY, STOP) + || a68_whether (q, -TERTIARY, ISNT_SYMBOL, -TERTIARY, STOP)) + { + a68_error (NEXT (q), "expected A", TERTIARY); + reduce (q, NO_NOTE, NO_TICK, UNIT, WILDCARD, ISNT_SYMBOL, WILDCARD, STOP); + } + } +} + +/* + * A posteriori checks of the syntax tree built by the BU parser. + */ + +/* Driver for a posteriori error checking. */ + +void +a68_bottom_up_error_check (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, BOOLEAN_PATTERN)) + { + int k = 0; + a68_count_pictures (SUB (p), &k); + if (!(k == 0 || k == 2)) + a68_error (p, "incorrect number of pictures for A", + ATTRIBUTE (p)); + } + else if (IS (p, PUBLIC_SYMBOL)) + { + /* These should have been removed by a68_bottom_up_coalesce_pub. */ + gcc_unreachable (); + } + else if (a68_is_one_of (p, DEFINING_INDICANT, DEFINING_IDENTIFIER, DEFINING_OPERATOR, STOP)) + { + if (PUBLICIZED (p) && !PUBLIC_RANGE (TABLE (p))) + a68_error (p, + "%licized declaration not in a module definition"); + } + else + a68_bottom_up_error_check (SUB (p)); + } +} + +/* + * Next part rearranges and checks the tree after the symbol tables are finished. + */ + +/* Transfer IDENTIFIER to JUMP where appropriate. */ + +void +a68_rearrange_goto_less_jumps (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + { + NODE_T *q = SUB (p); + if (IS (q, TERTIARY)) + { + NODE_T *tertiary = q; + q = SUB (q); + if (q != NO_NODE && IS (q, SECONDARY)) + { + q = SUB (q); + if (q != NO_NODE && IS (q, PRIMARY)) + { + q = SUB (q); + if (q != NO_NODE && IS (q, IDENTIFIER)) + { + if (a68_is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL) + { + ATTRIBUTE (tertiary) = JUMP; + SUB (tertiary) = q; + } + } + } + } + } + } + else if (IS (p, TERTIARY)) + { + NODE_T *q = SUB (p); + if (q != NO_NODE && IS (q, SECONDARY)) + { + NODE_T *secondary = q; + q = SUB (q); + if (q != NO_NODE && IS (q, PRIMARY)) + { + q = SUB (q); + if (q != NO_NODE && IS (q, IDENTIFIER)) + { + if (a68_is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL) + { + ATTRIBUTE (secondary) = JUMP; + SUB (secondary) = q; + } + } + } + } + } + else if (IS (p, SECONDARY)) + { + NODE_T *q = SUB (p); + if (q != NO_NODE && IS (q, PRIMARY)) + { + NODE_T *primary = q; + q = SUB (q); + if (q != NO_NODE && IS (q, IDENTIFIER)) + { + if (a68_is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL) + { + ATTRIBUTE (primary) = JUMP; + SUB (primary) = q; + } + } + } + } + else if (IS (p, PRIMARY)) + { + NODE_T *q = SUB (p); + if (q != NO_NODE && IS (q, IDENTIFIER)) + { + if (a68_is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL) + a68_make_sub (q, q, JUMP); + } + } + a68_rearrange_goto_less_jumps (SUB (p)); + } +} + +/* + * Coalesce PUBLIC_SYMBOLs resulting from reductions, annotating the + * corresponding defining identifiers, indicators, operators and prios as + * publicized. + */ + +void +a68_bottom_up_coalesce_pub (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (a68_is_one_of (p, + MODE_DECLARATION, PROCEDURE_DECLARATION, PRIORITY_DECLARATION, + PROCEDURE_VARIABLE_DECLARATION, BRIEF_OPERATOR_DECLARATION, + OPERATOR_DECLARATION, IDENTITY_DECLARATION, + VARIABLE_DECLARATION, STOP)) + { + if (SUB (p) != NO_NODE && IS (SUB (p), PUBLIC_SYMBOL)) + { + NODE_T *public_symbol = SUB (p); + + /* Mark the defining entity as PUBlicized. */ + /* XXX handle joined declarations. */ + NODE_T *defining_entity = NEXT (NEXT (SUB (p))); + if (!a68_is_one_of (defining_entity, + DEFINING_INDICANT, DEFINING_IDENTIFIER, DEFINING_OPERATOR, + STOP)) + FORWARD (defining_entity); + gcc_assert (defining_entity != NO_NODE + && a68_is_one_of (defining_entity, + DEFINING_INDICANT, + DEFINING_IDENTIFIER, + DEFINING_OPERATOR, + STOP)); + PUBLICIZED (defining_entity) = true; + + /* Unlink the PUBLIC_SYMBOL node and get rid of it. */ + SUB (p) = NEXT (public_symbol); + PREVIOUS (NEXT (public_symbol)) = NO_NODE; + } + } + a68_bottom_up_coalesce_pub (SUB (p)); + } +} diff --git a/gcc/algol68/a68-parser-brackets.cc b/gcc/algol68/a68-parser-brackets.cc new file mode 100644 index 000000000000..ccb4ab479838 --- /dev/null +++ b/gcc/algol68/a68-parser-brackets.cc @@ -0,0 +1,223 @@ +/* Recursive-descent parenthesis checker. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +/* After this checker, we know that at least brackets are matched. This + stabilises later parser phases. + + Note that this checker operates on a linear list of nodes. + + Error diagnostics are placed near offending lines. */ + +/* Intelligible diagnostics for the bracket checker. */ + +static void +bracket_check_error (char *txt, int n, const char *bra, const char *ket) +{ + BUFFER buf; + + if (n == 0) + return; + + const char *strop_ket = a68_strop_keyword (ket); + const char *strop_bra = a68_strop_keyword (bra); + + BUFCLR (buf); + if (snprintf (buf, SNPRINTF_SIZE, "missing matching %%<%s%%>", + (n > 0 ? strop_ket : strop_bra)) < 0) + gcc_unreachable (); + + if (strlen (txt) > 0) + a68_bufcat (txt, " or ", BUFFER_SIZE); + a68_bufcat (txt, buf, BUFFER_SIZE); +} + +/* Diagnose brackets in local branch of the tree. */ + +static char * +bracket_check_diagnose (NODE_T *p) +{ + int begins = 0, opens = 0, format_delims = 0, format_opens = 0; + int subs = 0, ifs = 0, cases = 0, dos = 0; + + for (; p != NO_NODE; FORWARD (p)) + { + switch (ATTRIBUTE (p)) + { + case BEGIN_SYMBOL: + begins++; + break; + case END_SYMBOL: + begins--; + break; + case OPEN_SYMBOL: + opens++; + break; + case CLOSE_SYMBOL: + opens--; + break; + case FORMAT_DELIMITER_SYMBOL: + if (format_delims == 0) + format_delims = 1; + else + format_delims = 0; + break; + case FORMAT_OPEN_SYMBOL: + format_opens++; + break; + case FORMAT_CLOSE_SYMBOL: + format_opens--; + break; + case SUB_SYMBOL: + subs++; + break; + case BUS_SYMBOL: + subs--; + break; + case IF_SYMBOL: + ifs++; + break; + case FI_SYMBOL: + ifs--; + break; + case CASE_SYMBOL: + cases++; + break; + case ESAC_SYMBOL: + cases--; + break; + case DO_SYMBOL: + dos++; + break; + case OD_SYMBOL: + dos--; + break; + default: + break; + } + } + + A68 (edit_line)[0] = '\0'; + bracket_check_error (A68 (edit_line), begins, "BEGIN", "END"); + bracket_check_error (A68 (edit_line), opens, "(", ")"); + bracket_check_error (A68 (edit_line), format_opens, "(", ")"); + bracket_check_error (A68 (edit_line), format_delims, "$", "$"); + bracket_check_error (A68 (edit_line), subs, "[", "]"); + bracket_check_error (A68 (edit_line), ifs, "IF", "FI"); + bracket_check_error (A68 (edit_line), cases, "CASE", "ESAC"); + bracket_check_error (A68 (edit_line), dos, "DO", "OD"); + return A68 (edit_line); +} + +/* Driver for locally diagnosing non-matching tokens. */ + +static NODE_T * +bracket_check_parse (NODE_T *top, NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + int ket = STOP; + NODE_T *q = NO_NODE; + bool ignore_token = false; + + switch (ATTRIBUTE (p)) + { + case BEGIN_SYMBOL: + ket = END_SYMBOL; + q = bracket_check_parse (top, NEXT (p)); + break; + case OPEN_SYMBOL: + ket = CLOSE_SYMBOL; + q = bracket_check_parse (top, NEXT (p)); + break; + case FORMAT_OPEN_SYMBOL: + ket = FORMAT_CLOSE_SYMBOL; + q = bracket_check_parse (top, NEXT (p)); + break; + case SUB_SYMBOL: + ket = BUS_SYMBOL; + q = bracket_check_parse (top, NEXT (p)); + break; + case IF_SYMBOL: + ket = FI_SYMBOL; + q = bracket_check_parse (top, NEXT (p)); + break; + case CASE_SYMBOL: + ket = ESAC_SYMBOL; + q = bracket_check_parse (top, NEXT (p)); + break; + case DO_SYMBOL: + ket = OD_SYMBOL; + q = bracket_check_parse (top, NEXT (p)); + break; + case END_SYMBOL: + case CLOSE_SYMBOL: + case FORMAT_CLOSE_SYMBOL: + case BUS_SYMBOL: + case FI_SYMBOL: + case ESAC_SYMBOL: + case OD_SYMBOL: + return p; + default: + ignore_token = true; + } + + if (ignore_token) + ; + else if (q != NO_NODE && IS (q, ket)) + p = q; + else if (q == NO_NODE) + { + char *diag = bracket_check_diagnose (top); + a68_error (p, "incorrect nesting, check for Y", + (strlen (diag) > 0 ? diag : "missing or unmatched keyword")); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + else + { + char *diag = bracket_check_diagnose (top); + a68_error (q, "unexpected X, check for Y", + ATTRIBUTE (q), + (strlen (diag) > 0 ? diag : "missing or unmatched keyword")); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + } + return NO_NODE; +} + +/* Driver for globally diagnosing non-matching tokens. */ + +void +a68_check_parenthesis (NODE_T *top) +{ + if (!setjmp (A68_PARSER (top_down_crash_exit))) + { + if (bracket_check_parse (top, top) != NO_NODE) + a68_error (top, "incorrect nesting, check for Y", + "missing or unmatched keyword"); + } +} diff --git a/gcc/algol68/a68-parser-debug.cc b/gcc/algol68/a68-parser-debug.cc new file mode 100644 index 000000000000..28646b3f31ad --- /dev/null +++ b/gcc/algol68/a68-parser-debug.cc @@ -0,0 +1,255 @@ +/* Debug facilities for the Algol 68 parser. + Copyright (C) 2025 Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#define INCLUDE_VECTOR +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "diagnostic.h" +#include "text-art/types.h" +#include "text-art/dump.h" +#include "text-art/dump-widget-info.h" +#include "text-art/canvas.h" +#include "text-art/theme.h" +#include "text-art/tree-widget.h" + +#include "a68.h" + +/* Write a printable representation of the parse tree with top node P to the + standard output. */ + +static void +a68_dump_parse_tree_1 (NODE_T *p, const text_art::dump_widget_info &dwi, + text_art::tree_widget &widget, bool tables, bool levels) +{ + for (; p != NO_NODE; FORWARD (p)) + { + char *symbol; + if (ATTRIBUTE (p) == IDENTIFIER + || ATTRIBUTE (p) == DEFINING_IDENTIFIER + || ATTRIBUTE (p) == DEFINING_OPERATOR + || ATTRIBUTE (p) == BOLD_TAG) + symbol = xasprintf (" %s", NSYMBOL (p)); + else + symbol = xstrdup (""); + + char *tableinfo; + if (tables && TABLE (p) != NO_TABLE) + tableinfo = xasprintf (" table=%p prev=%p", + (void *) TABLE (p), + (void *) PREVIOUS (TABLE (p))); + else + tableinfo = xstrdup (""); + + char *levelsinfo; + if (levels && TABLE (p) != NO_TABLE) + levelsinfo = xasprintf (" level=%d", LEVEL (TABLE (p))); + else + levelsinfo = xstrdup (""); + + char mode[BUFFER_SIZE]; + mode[0] = '\0'; + if (MOID (p) != NO_MOID) + { + MOID_T *moid = MOID (p); + mode[0] = '\0'; + + a68_bufcat (mode, " (", 2); + if (IS (moid, SERIES_MODE)) + { + if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) + a68_bufcat (mode, a68_moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), + BUFFER_SIZE); + else + a68_bufcat (mode, a68_moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE); + } + else + a68_bufcat (mode, a68_moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE); + a68_bufcat (mode, ")", 2); + } + + location_t loc = a68_get_node_location (p); + std::unique_ptr cwidget + = text_art::tree_widget::from_fmt (dwi, nullptr, + "%s:%d:%d [%d] %s%s%s%s%s", + LOCATION_FILE (loc), + LOCATION_LINE (loc), + LOCATION_COLUMN (loc), + NUMBER (p), + a68_attribute_name (ATTRIBUTE (p)), + symbol, + mode, + tableinfo, + levelsinfo); + free (symbol); + free (tableinfo); + free (levelsinfo); + + a68_dump_parse_tree_1 (SUB (p), dwi, *cwidget, tables, levels); + widget.add_child (std::move (cwidget)); + } +} + +void +a68_dump_parse_tree (NODE_T *p, bool tables, bool levels) +{ + text_art::style_manager sm; + text_art::style::id_t default_style_id (sm.get_or_create_id (text_art::style ())); + text_art::ascii_theme theme; + text_art::dump_widget_info dwi (sm, theme, default_style_id); + std::unique_ptr widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "Parse Tree"); + + a68_dump_parse_tree_1 (p, dwi, *widget, tables, levels); + + text_art::canvas c (widget->to_canvas (sm)); + pretty_printer *const pp = global_dc->get_reference_printer (); + pp_clear_output_area (pp); + c.print_to_pp (pp); + printf ("%s", pp_formatted_text (pp)); +} + +/* Dump the modes in the list MOID. */ + +void +a68_dump_modes (MOID_T *moid) +{ + for (; moid != NO_MOID; FORWARD (moid)) + { + printf ("%p %s\n", (void *) moid, + a68_moid_to_string (moid, MOID_ERROR_WIDTH, NODE (moid), + true /* indicant_value */)); + } +} + +/* Dump a given MOIF. */ + +void +a68_dump_moif (MOIF_T *moif) +{ + text_art::style_manager sm; + text_art::style::id_t default_style_id (sm.get_or_create_id (text_art::style ())); + text_art::ascii_theme theme; + text_art::dump_widget_info dwi (sm, theme, default_style_id); + std::unique_ptr widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "module interface: %s", NAME (moif)); + + std::unique_ptr prelude_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "prelude: %s", PRELUDE (moif)); + widget->add_child (std::move (prelude_widget)); + + std::unique_ptr postlude_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "postlude: %s", POSTLUDE (moif)); + widget->add_child (std::move (postlude_widget)); + + /* Mode table. */ + std::unique_ptr modes_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "modes"); + for (MOID_T *mode : MODES (moif)) + { + const char *asm_label = ASM_LABEL (mode); + if (asm_label == NULL) + asm_label = a68_moid_to_string (mode, 80, NO_NODE, false); + std::unique_ptr mode_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "mode: %s: %s", + asm_label, + a68_moid_to_string (mode, 80, NO_NODE, true)); + modes_widget->add_child (std::move (mode_widget)); + } + widget->add_child (std::move (modes_widget)); + + /* Module extracts. */ + std::unique_ptr mod_extracts_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "module extracts"); + for (EXTRACT_T *e : MODULES (moif)) + { + std::unique_ptr mod_extract_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "module extract: %s", EXTRACT_SYMBOL (e)); + mod_extracts_widget->add_child (std::move (mod_extract_widget)); + } + widget->add_child (std::move (mod_extracts_widget)); + + /* Mode extracts. */ + std::unique_ptr mode_extracts_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "mode extracts"); + for (EXTRACT_T *e : INDICANTS (moif)) + { + const char *asm_label = ASM_LABEL (EXTRACT_MODE (e)); + if (asm_label == NULL) + asm_label = a68_moid_to_string (EXTRACT_MODE (e), 80, NO_NODE, false); + std::unique_ptr mode_extract_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "mode extract: %s [%s]", + EXTRACT_SYMBOL (e), asm_label); + mode_extracts_widget->add_child (std::move (mode_extract_widget)); + } + widget->add_child (std::move (mode_extracts_widget)); + + /* Priority extracts. */ + std::unique_ptr prio_extracts_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "prio extracts"); + for (EXTRACT_T *e : PRIOS (moif)) + { + std::unique_ptr prio_extract_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "prio extract: %s [prio: %d]", + EXTRACT_SYMBOL (e), EXTRACT_PRIO (e)); + prio_extracts_widget->add_child (std::move (prio_extract_widget)); + } + widget->add_child (std::move (prio_extracts_widget)); + + /* Identifier extracts. */ + std::unique_ptr id_extracts_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "identifier extracts"); + for (EXTRACT_T *e : IDENTIFIERS (moif)) + { + const char *asm_label = ASM_LABEL (EXTRACT_MODE (e)); + if (asm_label == NULL) + asm_label = a68_moid_to_string (EXTRACT_MODE (e), 80, NO_NODE, false); + std::unique_ptr id_extract_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "iden extract: %s [%s] variable=%d inproc=%d", + EXTRACT_SYMBOL (e), asm_label, + EXTRACT_VARIABLE (e), + EXTRACT_IN_PROC (e)); + id_extracts_widget->add_child (std::move (id_extract_widget)); + } + widget->add_child (std::move (id_extracts_widget)); + + /* Operator extracts. */ + std::unique_ptr op_extracts_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "operator extracts"); + for (EXTRACT_T *e : OPERATORS (moif)) + { + const char *asm_label = ASM_LABEL (EXTRACT_MODE (e)); + if (asm_label == NULL) + asm_label = a68_moid_to_string (EXTRACT_MODE (e), 80, NO_NODE, false); + + std::unique_ptr op_extract_widget + = text_art::tree_widget::from_fmt (dwi, nullptr, "op extract: %s [%s] variable=%d inproc=%d", + EXTRACT_SYMBOL (e), asm_label, + EXTRACT_VARIABLE (e), + EXTRACT_IN_PROC (e)); + op_extracts_widget->add_child (std::move (op_extract_widget)); + } + widget->add_child (std::move (op_extracts_widget)); + + text_art::canvas c (widget->to_canvas (sm)); + pretty_printer *const pp = global_dc->get_reference_printer (); + pp_clear_output_area (pp); + c.print_to_pp (pp); + printf ("%s", pp_formatted_text (pp)); +} diff --git a/gcc/algol68/a68-parser-extract.cc b/gcc/algol68/a68-parser-extract.cc new file mode 100644 index 000000000000..e6474e9c744c --- /dev/null +++ b/gcc/algol68/a68-parser-extract.cc @@ -0,0 +1,895 @@ +/* Extract tags from phrases. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +/* This is part of the bottom-up parser. Here is a set of routines that gather + definitions from phrases. This way we can apply tags before defining them. + These routines do not look very elegant as they have to scan through all kind + of symbols to find a pattern that they recognise. */ + +/* Insert alt equals symbol. */ + +static void +insert_alt_equals (NODE_T *p) +{ + NODE_T *q = a68_new_node (); + *q = *p; + INFO (q) = a68_new_node_info (); + *INFO (q) = *INFO (p); + GINFO (q) = a68_new_genie_info (); + *GINFO (q) = *GINFO (p); + ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; + NSYMBOL (q) = TEXT (a68_add_token (&A68 (top_token), "=")); + NEXT (p) = q; + PREVIOUS (q) = p; + if (NEXT (q) != NO_NODE) + PREVIOUS (NEXT (q)) = q; +} + +/* Detect redefined keyword. */ + +static void +detect_redefined_keyword (NODE_T *p, int construct) +{ + if (p != NO_NODE && a68_whether (p, KEYWORD, EQUALS_SYMBOL, STOP)) + a68_error (p, "attempt to redefine keyword Y in A", + NSYMBOL (p), construct); +} + +/* Skip anything until a FED or ALT_ACCESS_SYMBOL is found. */ + +static NODE_T * +skip_module_text (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, FED_SYMBOL) || IS (p, ALT_ACCESS_SYMBOL)) + return p; + } + + return NO_NODE; +} + +/* Skip anything until a comma, semicolon or EXIT is found. */ + +static NODE_T * +skip_unit (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, COMMA_SYMBOL)) + return p; + else if (IS (p, SEMI_SYMBOL)) + return p; + else if (IS (p, EXIT_SYMBOL)) + return p; + } + return NO_NODE; +} + +/* Attribute of entry in symbol table. */ + +static int +find_tag_definition (TABLE_T *table, const char *name) +{ + if (table != NO_TABLE) + { + int ret = 0; + bool found = false; + for (TAG_T *s = INDICANTS (table); s != NO_TAG && !found; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + { + ret += INDICANT; + found = true; + } + } + found = false; + for (TAG_T *s = OPERATORS (table); s != NO_TAG && !found; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + { + ret += OPERATOR; + found = true; + } + } + found = false; + for (TAG_T *s = MODULES (table); s != NO_TAG && !found; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + { + ret += MODULE_INDICANT; + found = true; + } + } + + if (ret == 0) + return find_tag_definition (PREVIOUS (table), name); + else + return ret; + } + else + return 0; +} + +/* Fill in whether bold tag is operator, indicant or module indicant. */ + +void +a68_elaborate_bold_tags (NODE_T *p) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, BOLD_TAG)) + { + switch (find_tag_definition (TABLE (q), NSYMBOL (q))) + { + case 0: + a68_error (q, "tag S has not been declared properly"); + break; + case INDICANT: + ATTRIBUTE (q) = INDICANT; + break; + case OPERATOR: + ATTRIBUTE (q) = OPERATOR; + break; + case MODULE_INDICANT: + ATTRIBUTE (q) = MODULE_INDICANT; + break; + } + } + } +} + +/* Skip declarer, or argument pack and declarer. */ + +static NODE_T * +skip_pack_declarer (NODE_T *p) +{ + /* Skip () REF [] REF FLEX [] [] ... */ + while (p != NO_NODE + && (a68_is_one_of (p, SUB_SYMBOL, OPEN_SYMBOL, REF_SYMBOL, + FLEX_SYMBOL, SHORT_SYMBOL, LONG_SYMBOL, STOP))) + { + FORWARD (p); + } + + /* Skip STRUCT (), UNION () or PROC [()]. */ + if (p != NO_NODE && (a68_is_one_of (p, STRUCT_SYMBOL, UNION_SYMBOL, STOP))) + return NEXT (p); + else if (p != NO_NODE && IS (p, PROC_SYMBOL)) + return skip_pack_declarer (NEXT (p)); + else + return p; +} + +/* Extract a revelation. */ + +static void +extract_revelation (NODE_T *q, bool is_public ATTRIBUTE_UNUSED) +{ + /* Store in the symbol table. */ + TAG_T *tag = a68_add_tag (TABLE (q), MODULE_SYMBOL, q, NO_MOID, STOP); + gcc_assert (tag != NO_TAG); + EXPORTED (tag) = false; // XXX depends on PUB! + /* Import the MOIF and install it in the tag. */ + MOIF_T *moif = a68_open_packet (NSYMBOL (q)); + if (moif == NULL) + { + a68_error (q, "cannot find module Z", NSYMBOL (q)); + return; + } + MOIF (tag) = moif; // XXX add to existing list of moifs. + + /* Store all the modes from the MOIF in the moid list. + + The front-end depends on being able to compare any two modes by pointer + value. For example, the parser mode equivalence and coercion code relies + on this. The lowerer also relies on this to make sure the same lowered + trees are used for the same modes. */ + + for (MOID_T *m : MODES (moif)) + { + /* Note that m == NO_MOID if the imported mode was already known to the + compiler and has been replaced. */ + if (m != NO_MOID) + { + MOID_T *r = a68_register_extra_mode (&TOP_MOID (&A68_JOB), m); + if (r != m) + gcc_unreachable (); + } + } + + /* Store mode indicants from the MOIF in the symbol table, + and also in the moid list. */ + for (EXTRACT_T *e : INDICANTS (moif)) + { + /* Indicants stored in the indicants area of a symbol + table are expected to be INDICANT nodes originating in + parsing, with the following subtree: + + INDICANT - EQUALS_SYMBOL - DECLARER + + where MOID (DECLARER) is determined to be the mode + associated by INDICANT, or its "equivalent" mode. + Therefore we have to synthesize something like that + here, since the mode comes from a module interface and + we don't have a declarer tree for it.. */ + + /* INDICANT node. */ + NODE_T *n = a68_some_node (a68_demangle_symbol (NAME (moif), + EXTRACT_SYMBOL (e))); + /* EQUALS_SYMBOL node. */ + NEXT (n) = a68_some_node ("="); + ATTRIBUTE (NEXT (n)) = EQUALS_SYMBOL; + /* DECLARER node. */ + NEXT (NEXT (n)) = a68_some_node (""); + LINE (INFO (n)) = LINE (INFO (q)); + NCHAR_IN_LINE (n) = STRING (LINE (INFO (n))); + MOID (NEXT (NEXT (n))) = EXTRACT_MODE (e); + TABLE (n) = TABLE (q); + + /* Now add the INDICANT subtree to the symbol table of + this access clause lexical level. */ + TAG_T *tag = a68_add_tag (TABLE (q), INDICANT, n, NO_MOID, 0); + gcc_assert (tag != NO_TAG); + + /* Finally add the mode indicant to the moids list. Note + that the mode in DECLARER is associated to the + INDICANT in the table at some point later, via + EQUIVALENT. Hence the NO_MOID in the call to + a68_add_mode. */ + MOID_T *effective_mode = a68_add_mode (&TOP_MOID (&A68_JOB), INDICANT, + 0, n, NO_MOID, NO_PACK); + gcc_assert (effective_mode != NO_MOID); + } + + /* Store priorities from the MOIF. */ + for (EXTRACT_T *e : PRIOS (moif)) + { + NODE_T *n + = a68_some_node (a68_demangle_symbol (NAME (moif), + EXTRACT_SYMBOL (e))); + /* XXX sensible location somehow? */ + LINE (INFO (n)) = LINE (INFO (q)); + NCHAR_IN_LINE (n) = STRING (LINE (INFO (n))); + TABLE (n) = TABLE (q); + TAG_T *tag = a68_add_tag (TABLE (q), PRIO_SYMBOL, n, NO_MOID, + EXTRACT_PRIO (e)); + gcc_assert (tag != NO_TAG); + MOIF (tag) = moif; // XXX add to existing list of moifs. + } + + /* Store identifiers from the MOIF. */ + for (EXTRACT_T *e : IDENTIFIERS (moif)) + { + NODE_T *n + = a68_some_node (a68_demangle_symbol (NAME (moif), + EXTRACT_SYMBOL (e))); + /* XXX sensible location somehow? */ + LINE (INFO (n)) = LINE (INFO (q)); + NCHAR_IN_LINE (n) = STRING (LINE (INFO (n))); + TABLE (n) = TABLE (q); + + TAG_T *tag = a68_add_tag (TABLE (q), IDENTIFIER, + n, EXTRACT_MODE (e), NORMAL_IDENTIFIER); + gcc_assert (tag != NO_TAG); + EXTERN_SYMBOL (tag) = ggc_strdup (EXTRACT_SYMBOL (e)); + VARIABLE (tag) = VARIABLE (e); + IN_PROC (tag) = IN_PROC (e); + HEAP (tag) = STATIC_SYMBOL; + MOIF (tag) = moif; + } + + /* Store operators from the MOIF. */ + for (EXTRACT_T *e : OPERATORS (moif)) + { + NODE_T *n + = a68_some_node (a68_demangle_symbol (NAME (moif), + EXTRACT_SYMBOL (e), + true /* operator */)); + MOID (n) = EXTRACT_MODE (e); + LINE (INFO (n)) = LINE (INFO (q)); + NCHAR_IN_LINE (n) = STRING (LINE (INFO (n))); + TABLE (n) = TABLE (q); + TAG_T *tag = a68_add_tag (TABLE (q), OP_SYMBOL, + n, EXTRACT_MODE (e), STOP); + gcc_assert (tag != NO_TAG); + VARIABLE (tag) = VARIABLE (e); + IN_PROC (tag) = IN_PROC (e); + HEAP (tag) = STATIC_SYMBOL; + MOIF (tag) = moif; + EXTERN_SYMBOL (tag) = ggc_strdup (EXTRACT_SYMBOL (e)); + } +} + +/* Search [MODE|MODULE] A = .., B = .. + and ACCESS A, B, .. + and store indicants. */ + +void +a68_extract_indicants (NODE_T *p) +{ + NODE_T *q = p; + + while (q != NO_NODE) + { + if (IS (q, ACCESS_SYMBOL) || IS (q, ALT_ACCESS_SYMBOL)) + { + /* An access clause implies the declaration of module indicants, + provided they are found in a suitable packet. */ + do + { + FORWARD (q); + detect_redefined_keyword (q, MODE_DECLARATION); + if (IS (q, BOLD_TAG)) + { + extract_revelation (q, false /* is_public */); + FORWARD (q); + } + else if (a68_whether (q, PUBLIC_SYMBOL, BOLD_TAG, STOP)) + { + extract_revelation (q, true /* is_public */); + FORWARD (q); + FORWARD (q); + } + } + while (q != NO_NODE && IS (q, COMMA_SYMBOL)); + } + else if (IS (q, MODULE_SYMBOL)) + { + bool siga = true; + do + { + FORWARD (q); + detect_redefined_keyword (q, MODE_DECLARATION); + if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP)) + { + /* Store in the symbol table. + XXX also add to global list of modules? + Position of definition (q) connects to this lexical + level! */ + ATTRIBUTE (q) = DEFINING_MODULE_INDICANT; + TAG_T *tag = a68_add_tag (TABLE (p), MODULE_SYMBOL, q, NO_MOID, STOP); + gcc_assert (tag != NO_TAG); + EXPORTED (tag) = true; + FORWARD (q); + ATTRIBUTE (q) = EQUALS_SYMBOL; /* XXX why not ALT_EQUALS_SYMBOL */ + q = skip_module_text (NEXT (q)); + FORWARD (q); + } + else + siga = false; + } + while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); + } + else if (IS (q, MODE_SYMBOL)) + { + bool siga = true; + do + { + FORWARD (q); + detect_redefined_keyword (q, MODE_DECLARATION); + if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP)) + { + /* Store in the symbol table, but also in the moid list. + Position of definition (q) connects to this lexical + level! */ + if (a68_add_tag (TABLE (p), INDICANT, q, NO_MOID, STOP) == NO_TAG) + gcc_unreachable (); + if (a68_add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, q, NO_MOID, NO_PACK) == NO_MOID) + gcc_unreachable (); + ATTRIBUTE (q) = DEFINING_INDICANT; + FORWARD (q); + ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; + q = skip_pack_declarer (NEXT (q)); + FORWARD (q); + } + else + siga = false; + } + while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); + } + else + FORWARD (q); + } +} + +#define GET_PRIORITY(q, k) \ + do \ + { \ + errno=0; \ + (k) = atoi (NSYMBOL (q)); \ + if (errno != 0) { \ + a68_error ((q), "invalid priority declaration"); \ + (k) = MAX_PRIORITY; \ + } else if ((k) < 1 || (k) > MAX_PRIORITY) { \ + a68_error ((q), "invalid priority declaration"); \ + (k) = MAX_PRIORITY; \ + } \ + } \ + while (0) + +/* Search PRIO X = .., Y = .. and store priorities. */ + +void +a68_extract_priorities (NODE_T *p) +{ + NODE_T *q = p; + while (q != NO_NODE) + { + if (IS (q, PRIO_SYMBOL)) + { + bool siga = true; + do + { + FORWARD (q); + detect_redefined_keyword (q, PRIORITY_DECLARATION); + /* An operator tag like ++ or && gives strange errors so we catch + it here. */ + if (a68_whether (q, OPERATOR, OPERATOR, STOP)) + { + NODE_T *y = q; + a68_error (q, "invalid operator tag"); + ATTRIBUTE (q) = DEFINING_OPERATOR; + /* Remove one superfluous operator, and hope it was only + one. */ + NEXT (q) = NEXT_NEXT (q); + PREVIOUS (NEXT (q)) = q; + FORWARD (q); + ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; + FORWARD (q); + int k; + GET_PRIORITY (q, k); + ATTRIBUTE (q) = PRIORITY; + if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG) + gcc_unreachable (); + FORWARD (q); + } + else if (a68_whether (q, OPERATOR, EQUALS_SYMBOL, INT_DENOTATION, STOP) + || a68_whether (q, EQUALS_SYMBOL, EQUALS_SYMBOL, INT_DENOTATION, STOP)) + { + NODE_T *y = q; + ATTRIBUTE (q) = DEFINING_OPERATOR; + FORWARD (q); + ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; + FORWARD (q); + int k; + GET_PRIORITY (q, k); + ATTRIBUTE (q) = PRIORITY; + if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG) + gcc_unreachable (); + FORWARD (q); + } + else if (a68_whether (q, BOLD_TAG, IDENTIFIER, STOP)) + { + siga = false; + } + else if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, INT_DENOTATION, STOP)) + { + NODE_T *y = q; + ATTRIBUTE (q) = DEFINING_OPERATOR; + FORWARD (q); + ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; + FORWARD (q); + int k; + GET_PRIORITY (q, k); + ATTRIBUTE (q) = PRIORITY; + if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG) + gcc_unreachable (); + FORWARD (q); + } else if (a68_whether (q, BOLD_TAG, INT_DENOTATION, STOP) + || a68_whether (q, OPERATOR, INT_DENOTATION, STOP) + || a68_whether (q, EQUALS_SYMBOL, INT_DENOTATION, STOP)) + { + /* The scanner cannot separate operator and "=" sign so we do this here. */ + int len = (int) strlen (NSYMBOL (q)); + if (len > 1 && NSYMBOL (q)[len - 1] == '=') + { + NODE_T *y = q; + char *sym = (char *) xmalloc ((size_t) (len + 1)); + a68_bufcpy (sym, NSYMBOL (q), len + 1); + sym[len - 1] = '\0'; + NSYMBOL (q) = TEXT (a68_add_token (&A68 (top_token), sym)); + free (sym); + if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=') + a68_error (q, "probably a missing symbol near invalid operator S"); + ATTRIBUTE (q) = DEFINING_OPERATOR; + insert_alt_equals (q); + q = NEXT_NEXT (q); + int k; + GET_PRIORITY (q, k); + ATTRIBUTE (q) = PRIORITY; + if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG) + gcc_unreachable (); + FORWARD (q); + } + else + siga = false; + } + else + siga = false; + } + while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); + } + else + FORWARD (q); + } +} + +/* Search OP [( .. ) ..] X = .., Y = .. and store operators. */ + +void +a68_extract_operators (NODE_T *p) +{ + NODE_T *q = p; + + while (q != NO_NODE) + { + if (!IS (q, OP_SYMBOL)) + FORWARD (q); + else + { + bool siga = true; + bool in_proc = true; + /* Skip operator plan. */ + if (NEXT (q) != NO_NODE && IS (NEXT (q), OPEN_SYMBOL)) + { + q = skip_pack_declarer (NEXT (q)); + in_proc = false; + } + /* Sample operators. */ + if (q != NO_NODE) + { + do + { + FORWARD (q); + detect_redefined_keyword (q, OPERATOR_DECLARATION); + /* Unacceptable operator tags like ++ or && could give + strange errors. */ + if (a68_whether (q, OPERATOR, OPERATOR, STOP)) + { + a68_error (q, "invalid operator tag"); + ATTRIBUTE (q) = DEFINING_OPERATOR; + TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP); + if (t == NO_TAG) + gcc_unreachable (); + IN_PROC (t) = in_proc; + /* Remove one superfluous operator, and hope it was only one. */ + NEXT (q) = NEXT_NEXT (q); + PREVIOUS (NEXT (q)) = q; + FORWARD (q); + ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; + q = skip_unit (q); + } + else if (a68_whether (q, OPERATOR, EQUALS_SYMBOL, STOP) + || a68_whether (q, EQUALS_SYMBOL, EQUALS_SYMBOL, STOP)) + { + ATTRIBUTE (q) = DEFINING_OPERATOR; + TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP); + if (t == NO_TAG) + gcc_unreachable (); + IN_PROC (t) = in_proc; + FORWARD (q); + ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; + q = skip_unit (q); + } + else if (a68_whether (q, BOLD_TAG, IDENTIFIER, STOP)) + { + siga = false; + } + else if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP)) + { + ATTRIBUTE (q) = DEFINING_OPERATOR; + TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP); + if (t == NO_TAG) + gcc_unreachable (); + IN_PROC (t) = in_proc; + FORWARD (q); + ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; + q = skip_unit (q); + } + else if (q != NO_NODE && (a68_is_one_of (q, OPERATOR, BOLD_TAG, EQUALS_SYMBOL, STOP))) + { + /* The scanner cannot separate operator and "=" sign so + we do this here. */ + int len = (int) strlen (NSYMBOL (q)); + if (len > 1 && NSYMBOL (q)[len - 1] == '=') + { + char *sym = (char *) xmalloc ((size_t) (len + 1)); + a68_bufcpy (sym, NSYMBOL (q), len + 1); + sym[len - 1] = '\0'; + NSYMBOL (q) = TEXT (a68_add_token (&A68 (top_token), sym)); + if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=') + a68_error (q, "probably a missing symbol near invalid operator S"); + ATTRIBUTE (q) = DEFINING_OPERATOR; + insert_alt_equals (q); + TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP); + if (t == NO_TAG) + gcc_unreachable (); + IN_PROC (t) = in_proc; + FORWARD (q); + q = skip_unit (q); + } + else + siga = false; + } + else + siga = false; + } + while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); + } + } + } +} + +/* Search and store labels. */ + +void +a68_extract_labels (NODE_T *p, int expect) +{ + /* Only handle candidate phrases as not to search indexers!. */ + if (expect == SERIAL_CLAUSE || expect == ENQUIRY_CLAUSE || expect == SOME_CLAUSE) + { + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (a68_whether (q, IDENTIFIER, COLON_SYMBOL, STOP)) + { + TAG_T *z = a68_add_tag (TABLE (p), LABEL, q, NO_MOID, LOCAL_LABEL); + ATTRIBUTE (q) = DEFINING_IDENTIFIER; + UNIT (z) = NO_NODE; + } + } + } +} + +/* Search MOID x = .., y = .. and store identifiers. */ + +static void +extract_identities (NODE_T *p) +{ + NODE_T *q = p; + + while (q != NO_NODE) + { + if (a68_whether (q, DECLARER, IDENTIFIER, EQUALS_SYMBOL, STOP)) + { + bool siga = true; + do + { + if (a68_whether ((FORWARD (q)), IDENTIFIER, EQUALS_SYMBOL, STOP)) + { + TAG_T *tag = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER); + if (tag == NO_TAG) + gcc_unreachable (); + ATTRIBUTE (q) = DEFINING_IDENTIFIER; + FORWARD (q); + ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; + q = skip_unit (q); + } + else if (a68_whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP)) + { + /* Handle common error in ALGOL 68 programs. */ + a68_error (q, "mixed identity-declaration and variable-declaration"); + if (a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) == NO_TAG) + gcc_unreachable (); + ATTRIBUTE (q) = DEFINING_IDENTIFIER; + ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL; + q = skip_unit (q); + } + else + siga = false; + } + while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); + } + else + FORWARD (q); + } +} + +/* Search MOID x [:= ..], y [:= ..] and store identifiers. */ + +static void +extract_variables (NODE_T *p) +{ + NODE_T *q = p; + + while (q != NO_NODE) + { + if (a68_whether (q, HEAP_SYMBOL, DECLARER, IDENTIFIER, STOP) + || a68_whether (q, LOC_SYMBOL, DECLARER, IDENTIFIER, STOP) + || a68_whether (q, DECLARER, IDENTIFIER, STOP)) + { + if (!IS (q, DECLARER)) + FORWARD (q); + + bool siga = true; + do + { + FORWARD (q); + if (a68_whether (q, IDENTIFIER, STOP)) + { + if (a68_whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP)) + { + /* Handle common error in ALGOL 68 programs. */ + a68_error (q, "mixed identity-declaration and variable-declaration"); + ATTRIBUTE (NEXT (q)) = ASSIGN_SYMBOL; + } + TAG_T *tag = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER); + if (tag == NO_TAG) + gcc_unreachable (); + VARIABLE (tag) = true; + ATTRIBUTE (q) = DEFINING_IDENTIFIER; + q = skip_unit (q); + } + else + siga = false; + } + while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); + } + else + FORWARD (q); + } +} + +/* Search PROC x = .., y = .. and stores identifiers. */ + +static void +extract_proc_identities (NODE_T *p) +{ + NODE_T *q = p; + + while (q != NO_NODE) + { + if (a68_whether (q, PROC_SYMBOL, IDENTIFIER, EQUALS_SYMBOL, STOP)) + { + bool siga = true; + do + { + FORWARD (q); + if (a68_whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP)) + { + TAG_T *t = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER); + IN_PROC (t) = true; + ATTRIBUTE (q) = DEFINING_IDENTIFIER; + ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL; + q = skip_unit (q); + } + else if (a68_whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP)) + { + /* Handle common error in ALGOL 68 programs. */ + a68_error (q, "mixed identity-declaration and variable-declaration"); + if (a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) == NO_TAG) + gcc_unreachable (); + ATTRIBUTE (q) = DEFINING_IDENTIFIER; + ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL; + q = skip_unit (q); + } + else + siga = false; + } + while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); + } + else + FORWARD (q); + } +} + +/* Search PROC x [:= ..], y [:= ..]; store identifiers. */ + +static void +extract_proc_variables (NODE_T *p) +{ + NODE_T *q = p; + + while (q != NO_NODE) + { + if (a68_whether (q, PROC_SYMBOL, IDENTIFIER, STOP)) + { + bool siga = true; + do + { + FORWARD (q); + if (a68_whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP)) + { + TAG_T *tag = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER); + gcc_assert (tag != NO_TAG); + VARIABLE (tag) = true; + ATTRIBUTE (q) = DEFINING_IDENTIFIER; + q = skip_unit (FORWARD (q)); + } + else if (a68_whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP)) + { + /* Handle common error in ALGOL 68 programs. */ + a68_error (q, "mixed identity-declaration and variable-declaration"); + TAG_T *tag = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER); + gcc_assert (tag != NO_TAG); + ATTRIBUTE (q) = DEFINING_IDENTIFIER; + ATTRIBUTE (FORWARD (q)) = ASSIGN_SYMBOL; + q = skip_unit (q); + } else + siga = false; + } + while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); + } + else + FORWARD (q); + } +} + +/* Schedule gathering of definitions in a phrase. */ + +void +a68_extract_declarations (NODE_T *p) +{ + /* Get definitions so we know what is defined in this range. */ + extract_identities (p); + extract_variables (p); + extract_proc_identities (p); + extract_proc_variables (p); + /* By now we know whether "=" is an operator or not. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, EQUALS_SYMBOL)) + ATTRIBUTE (q) = OPERATOR; + else if (IS (q, ALT_EQUALS_SYMBOL)) + ATTRIBUTE (q) = EQUALS_SYMBOL; + } + + /* Get qualifiers. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (a68_whether (q, LOC_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP)) + a68_make_sub (q, q, QUALIFIER); + if (a68_whether (q, HEAP_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP)) + a68_make_sub (q, q, QUALIFIER); + if (a68_whether (q, LOC_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP)) + a68_make_sub (q, q, QUALIFIER); + if (a68_whether (q, HEAP_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP)) + a68_make_sub (q, q, QUALIFIER); + } + + /* Give priorities to operators. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, OPERATOR)) + { + if (a68_find_tag_global (TABLE (q), OP_SYMBOL, NSYMBOL (q))) + { + TAG_T *s = a68_find_tag_global (TABLE (q), PRIO_SYMBOL, NSYMBOL (q)); + + if (s != NO_TAG) + PRIO (INFO (q)) = PRIO (s); + else + PRIO (INFO (q)) = 0; + } + else + { + a68_error (q, "tag S has not been declared properly"); + PRIO (INFO (q)) = 1; + } + } + } +} diff --git a/gcc/algol68/a68-parser-keywords.cc b/gcc/algol68/a68-parser-keywords.cc new file mode 100644 index 000000000000..427e2b359fdf --- /dev/null +++ b/gcc/algol68/a68-parser-keywords.cc @@ -0,0 +1,254 @@ +/* Keyword tables. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +/* Apply stropping to the given keyword and return its written form, which must + be upper-case. */ + +const char * +a68_strop_keyword (const char *keyword) +{ + char *stropped = (char *) alloca (strlen (keyword) + 1); + memcpy (stropped, keyword, strlen (keyword) + 1); + + if (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING) + { + for (char *p = stropped; *p; ++p) + *p = TOLOWER (*p); + } + + return ggc_strdup (stropped); +} + +/* Add token to the token tree. */ + +TOKEN_T * +a68_add_token (TOKEN_T **p, const char *t) +{ + while (*p != NO_TOKEN) + { + int k = strcmp (t, TEXT (*p)); + + if (k < 0) + p = &LESS (*p); + else if (k > 0) + p = &MORE (*p); + else + return *p; + } + + *p = (TOKEN_T *) ggc_cleared_alloc (); + TEXT (*p) = ggc_strdup (t); + LESS (*p) = MORE (*p) = NO_TOKEN; + return *p; +} + +/* Find keyword, from token name. */ + +KEYWORD_T * +a68_find_keyword (KEYWORD_T *p, const char *t) +{ + while (p != NO_KEYWORD) + { + bool case_insensitive = (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING); + int k = (case_insensitive + ? strcasecmp (t, TEXT (p)) + : strcmp (t, TEXT (p))); + + if (k < 0) + p = LESS (p); + else if (k > 0) + p = MORE (p); + else + return p; + } + + return NO_KEYWORD; +} + +/* Find keyword, from attribute. */ + +KEYWORD_T * +a68_find_keyword_from_attribute (KEYWORD_T *p, enum a68_attribute a) +{ + if (p == NO_KEYWORD) + return NO_KEYWORD; + else if (a == ATTRIBUTE (p)) + return p; + else + { + KEYWORD_T *z; + + if ((z = a68_find_keyword_from_attribute (LESS (p), a)) != NO_KEYWORD) + return z; + else if ((z = a68_find_keyword_from_attribute (MORE (p), a)) != NO_KEYWORD) + return z; + } + + return NO_KEYWORD; +} + +/* Add keyword to the tree. */ + +static void +add_keyword (KEYWORD_T **p, enum a68_attribute a, const char *t) +{ + while (*p != NO_KEYWORD) + { + bool case_insensitive = (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING); + int k = (case_insensitive + ? strcasecmp (t, TEXT (*p)) + : strcmp (t, TEXT (*p))); + if (k < 0) + p = &LESS (*p); + else + p = &MORE (*p); + } + + *p = (KEYWORD_T *) ggc_cleared_alloc (); + ATTRIBUTE (*p) = a; + TEXT (*p) = t; + LESS (*p) = MORE (*p) = NO_KEYWORD; +} + +/* Make tables of keywords and non-terminals. */ + +void +a68_set_up_tables (void) +{ + /* Entries are randomised to balance the tree. */ + if (OPTION_STRICT (&A68_JOB) == false) + { + /* Symbols from GNU extensions. */ + add_keyword (&A68 (top_keyword), ANDF_SYMBOL, "ANDTH"); + add_keyword (&A68 (top_keyword), ORF_SYMBOL, "OREL"); + add_keyword (&A68 (top_keyword), BRIEF_COMMENT_BEGIN_SYMBOL, "{"); + add_keyword (&A68 (top_keyword), BRIEF_COMMENT_END_SYMBOL, "}"); + + if (OPTION_STROPPING (&A68_JOB) != SUPPER_STROPPING) + { + add_keyword (&A68 (top_keyword), BOLD_COMMENT_BEGIN_SYMBOL, "NOTE"); + add_keyword (&A68 (top_keyword), BOLD_COMMENT_END_SYMBOL, "ETON"); + } + + /* Symbols from MR. */ + add_keyword (&A68 (top_keyword), ACCESS_SYMBOL, "ACCESS"); + add_keyword (&A68 (top_keyword), DEF_SYMBOL, "DEF"); + add_keyword (&A68 (top_keyword), POSTLUDE_SYMBOL, "POSTLUDE"); + add_keyword (&A68 (top_keyword), FED_SYMBOL, "FED"); + add_keyword (&A68 (top_keyword), FORMAL_NEST_SYMBOL, "NEST"); + add_keyword (&A68 (top_keyword), MODULE_SYMBOL, "MODULE"); + add_keyword (&A68 (top_keyword), EGG_SYMBOL, "EGG"); + add_keyword (&A68 (top_keyword), PUBLIC_SYMBOL, "PUB"); + } + + if (OPTION_STROPPING (&A68_JOB) != SUPPER_STROPPING) + { + /* The following representations do not work well with stropping regimes + in which reserved words live in the same namespace than + tags/identifiers. The alternative "brief" representations for these + symbols shall be used instead. */ + add_keyword (&A68 (top_keyword), STYLE_I_COMMENT_SYMBOL, "CO"); + add_keyword (&A68 (top_keyword), BOLD_COMMENT_SYMBOL, "COMMENT"); + add_keyword (&A68 (top_keyword), STYLE_II_COMMENT_SYMBOL, "#"); + } + + add_keyword (&A68 (top_keyword), POINT_SYMBOL, "."); + add_keyword (&A68 (top_keyword), COLON_SYMBOL, ":"); + add_keyword (&A68 (top_keyword), THEN_BAR_SYMBOL, "|"); + add_keyword (&A68 (top_keyword), SUB_SYMBOL, "["); + add_keyword (&A68 (top_keyword), BY_SYMBOL, "BY"); + add_keyword (&A68 (top_keyword), OP_SYMBOL, "OP"); + add_keyword (&A68 (top_keyword), COMMA_SYMBOL, ","); + add_keyword (&A68 (top_keyword), AT_SYMBOL, "AT"); + add_keyword (&A68 (top_keyword), PRIO_SYMBOL, "PRIO"); + add_keyword (&A68 (top_keyword), END_SYMBOL, "END"); + add_keyword (&A68 (top_keyword), GO_SYMBOL, "GO"); + add_keyword (&A68 (top_keyword), TO_SYMBOL, "TO"); + add_keyword (&A68 (top_keyword), ELSE_BAR_SYMBOL, "|:"); + add_keyword (&A68 (top_keyword), THEN_SYMBOL, "THEN"); + add_keyword (&A68 (top_keyword), TRUE_SYMBOL, "TRUE"); + add_keyword (&A68 (top_keyword), PROC_SYMBOL, "PROC"); + add_keyword (&A68 (top_keyword), FOR_SYMBOL, "FOR"); + add_keyword (&A68 (top_keyword), GOTO_SYMBOL, "GOTO"); + add_keyword (&A68 (top_keyword), WHILE_SYMBOL, "WHILE"); + add_keyword (&A68 (top_keyword), IS_SYMBOL, ":=:"); + add_keyword (&A68 (top_keyword), ASSIGN_TO_SYMBOL, "=:"); + add_keyword (&A68 (top_keyword), COMPL_SYMBOL, "COMPL"); + add_keyword (&A68 (top_keyword), FROM_SYMBOL, "FROM"); + add_keyword (&A68 (top_keyword), BOLD_PRAGMAT_SYMBOL, "PRAGMAT"); + add_keyword (&A68 (top_keyword), DO_SYMBOL, "DO"); + add_keyword (&A68 (top_keyword), CASE_SYMBOL, "CASE"); + add_keyword (&A68 (top_keyword), LOC_SYMBOL, "LOC"); + add_keyword (&A68 (top_keyword), CHAR_SYMBOL, "CHAR"); + add_keyword (&A68 (top_keyword), ISNT_SYMBOL, ":/=:"); + add_keyword (&A68 (top_keyword), REF_SYMBOL, "REF"); + add_keyword (&A68 (top_keyword), NIL_SYMBOL, "NIL"); + add_keyword (&A68 (top_keyword), ASSIGN_SYMBOL, ":="); + add_keyword (&A68 (top_keyword), FI_SYMBOL, "FI"); + add_keyword (&A68 (top_keyword), FILE_SYMBOL, "FILE"); + add_keyword (&A68 (top_keyword), PAR_SYMBOL, "PAR"); + add_keyword (&A68 (top_keyword), ASSERT_SYMBOL, "ASSERT"); + add_keyword (&A68 (top_keyword), OUSE_SYMBOL, "OUSE"); + add_keyword (&A68 (top_keyword), IN_SYMBOL, "IN"); + add_keyword (&A68 (top_keyword), LONG_SYMBOL, "LONG"); + add_keyword (&A68 (top_keyword), SEMI_SYMBOL, ";"); + add_keyword (&A68 (top_keyword), EMPTY_SYMBOL, "EMPTY"); + add_keyword (&A68 (top_keyword), MODE_SYMBOL, "MODE"); + add_keyword (&A68 (top_keyword), IF_SYMBOL, "IF"); + add_keyword (&A68 (top_keyword), OD_SYMBOL, "OD"); + add_keyword (&A68 (top_keyword), OF_SYMBOL, "OF"); + add_keyword (&A68 (top_keyword), STRUCT_SYMBOL, "STRUCT"); + add_keyword (&A68 (top_keyword), STYLE_I_PRAGMAT_SYMBOL, "PR"); + add_keyword (&A68 (top_keyword), BUS_SYMBOL, "]"); + add_keyword (&A68 (top_keyword), SKIP_SYMBOL, "SKIP"); + add_keyword (&A68 (top_keyword), SHORT_SYMBOL, "SHORT"); + add_keyword (&A68 (top_keyword), IS_SYMBOL, "IS"); + add_keyword (&A68 (top_keyword), ESAC_SYMBOL, "ESAC"); + add_keyword (&A68 (top_keyword), CHANNEL_SYMBOL, "CHANNEL"); + add_keyword (&A68 (top_keyword), REAL_SYMBOL, "REAL"); + add_keyword (&A68 (top_keyword), STRING_SYMBOL, "STRING"); + add_keyword (&A68 (top_keyword), BOOL_SYMBOL, "BOOL"); + add_keyword (&A68 (top_keyword), ISNT_SYMBOL, "ISNT"); + add_keyword (&A68 (top_keyword), FALSE_SYMBOL, "FALSE"); + add_keyword (&A68 (top_keyword), UNION_SYMBOL, "UNION"); + add_keyword (&A68 (top_keyword), OUT_SYMBOL, "OUT"); + add_keyword (&A68 (top_keyword), BRIEF_COMMENT_END_SYMBOL, "{"); + add_keyword (&A68 (top_keyword), OPEN_SYMBOL, "("); + add_keyword (&A68 (top_keyword), BEGIN_SYMBOL, "BEGIN"); + add_keyword (&A68 (top_keyword), FLEX_SYMBOL, "FLEX"); + add_keyword (&A68 (top_keyword), VOID_SYMBOL, "VOID"); + add_keyword (&A68 (top_keyword), BITS_SYMBOL, "BITS"); + add_keyword (&A68 (top_keyword), ELSE_SYMBOL, "ELSE"); + add_keyword (&A68 (top_keyword), EXIT_SYMBOL, "EXIT"); + add_keyword (&A68 (top_keyword), HEAP_SYMBOL, "HEAP"); + add_keyword (&A68 (top_keyword), INT_SYMBOL, "INT"); + add_keyword (&A68 (top_keyword), BYTES_SYMBOL, "BYTES"); + add_keyword (&A68 (top_keyword), SEMA_SYMBOL, "SEMA"); + add_keyword (&A68 (top_keyword), CLOSE_SYMBOL, ")"); + add_keyword (&A68 (top_keyword), AT_SYMBOL, "@"); + add_keyword (&A68 (top_keyword), ELIF_SYMBOL, "ELIF"); +} diff --git a/gcc/algol68/a68-parser-modes.cc b/gcc/algol68/a68-parser-modes.cc new file mode 100644 index 000000000000..4a0128667ca0 --- /dev/null +++ b/gcc/algol68/a68-parser-modes.cc @@ -0,0 +1,1325 @@ +/* Mode table management. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +/* + * Mode collection, equivalencing and derived modes. + */ + +/* Few forward references. */ + +static MOID_T *get_mode_from_declarer (NODE_T *p); + +/* + * Mode service routines. + */ + +/* Count bounds in declarer in tree. */ + +static int +count_bounds (NODE_T *p) +{ + if (p == NO_NODE) + return 0; + else + { + if (IS (p, BOUND)) + return 1 + count_bounds (NEXT (p)); + else + return count_bounds (NEXT (p)) + count_bounds (SUB (p)); + } +} + +/* Count number of SHORTs or LONGs. */ + +static int +count_sizety (NODE_T *p) +{ + if (p == NO_NODE) + return 0; + else if (IS (p, LONGETY)) + return count_sizety (SUB (p)) + count_sizety (NEXT (p)); + else if (IS (p, SHORTETY)) + return count_sizety (SUB (p)) + count_sizety (NEXT (p)); + else if (IS (p, LONG_SYMBOL)) + return 1; + else if (IS (p, SHORT_SYMBOL)) + return -1; + else + return 0; +} + +/* Count moids in a pack. */ + +int +a68_count_pack_members (PACK_T *u) +{ + int k = 0; + + for (; u != NO_PACK; FORWARD (u)) + k++; + return k; +} + +/* Replace a mode by its equivalent mode. */ + +static void +resolve_equivalent (MOID_T **m) +{ + while ((*m) != NO_MOID + && EQUIVALENT ((*m)) != NO_MOID + && (*m) != EQUIVALENT (*m)) + { + (*m) = EQUIVALENT (*m); + } +} + +/* Reset moid. */ + +static void +reset_moid_tree (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + MOID (p) = NO_MOID; + reset_moid_tree (SUB (p)); + } +} + +/* Renumber moids. */ + +void +a68_renumber_moids (MOID_T *p, int n) +{ + if (p != NO_MOID) + { + NUMBER (p) = n; + a68_renumber_moids (NEXT (p), n + 1); + } +} + +/* See whether a mode equivalent to the mode M exists in the global mode table, + and return it. Return NO_MOID if no equivalent mode is found. */ + +MOID_T * +a68_search_equivalent_mode (MOID_T *m) +{ + for (MOID_T *head = TOP_MOID (&A68_JOB); head != NO_MOID; FORWARD (head)) + { + if (a68_prove_moid_equivalence (head, m)) + return head; + } + + return NO_MOID; +} + +/* Register mode in the global mode table, if mode is unique. */ + +MOID_T * +a68_register_extra_mode (MOID_T **z, MOID_T *u) +{ + /* If we already know this mode, return the existing entry; otherwise link it + in. */ + for (MOID_T *head = TOP_MOID (&A68_JOB); head != NO_MOID; FORWARD (head)) + { + if (a68_prove_moid_equivalence (head, u)) + return head; + } + + /* Link to chain and exit. */ + NUMBER (u) = A68 (mode_count)++; + NEXT (u) = (*z); + return *z = u; +} + +/* Create a new mode. */ + +MOID_T * +a68_create_mode (int att, int dim, NODE_T *node, MOID_T *sub, PACK_T *pack) +{ + MOID_T *new_mode = a68_new_moid (); + + if (sub == NO_MOID) + { + if (att == REF_SYMBOL + || att == FLEX_SYMBOL + || att == ROW_SYMBOL) + gcc_unreachable (); + } + + USE (new_mode) = false; + ATTRIBUTE (new_mode) = att; + DIM (new_mode) = dim; + NODE (new_mode) = node; + HAS_ROWS (new_mode) = (att == ROW_SYMBOL); + SUB (new_mode) = sub; + PACK (new_mode) = pack; + NEXT (new_mode) = NO_MOID; + EQUIVALENT (new_mode) = NO_MOID; + SLICE (new_mode) = NO_MOID; + DEFLEXED (new_mode) = NO_MOID; + NAME (new_mode) = NO_MOID; + MULTIPLE (new_mode) = NO_MOID; + ROWED (new_mode) = NO_MOID; + + return new_mode; +} + +/* Create a new mode and add it to chain Z. */ + +MOID_T * +a68_add_mode (MOID_T **z, int att, int dim, NODE_T *node, MOID_T *sub, PACK_T *pack) +{ + MOID_T *new_mode = a68_create_mode (att, dim, node, sub, pack); + return a68_register_extra_mode (z, new_mode); +} + +/* Contract a UNION. */ + +void +a68_contract_union (MOID_T *u) +{ + for (PACK_T *s = PACK (u); s != NO_PACK; FORWARD (s)) + { + PACK_T *t = s; + + while (t != NO_PACK) + { + if (NEXT (t) != NO_PACK && MOID (NEXT (t)) == MOID (s)) + { + MOID (t) = MOID (t); + NEXT (t) = NEXT_NEXT (t); + } + else + FORWARD (t); + } + } +} + +/* Absorb UNION pack. */ + +PACK_T * +a68_absorb_union_pack (PACK_T * u) +{ + PACK_T *z; + bool siga; + + do + { + z = NO_PACK; + siga = false; + for (PACK_T *t = u; t != NO_PACK; FORWARD (t)) + { + if (IS (MOID (t), UNION_SYMBOL)) + { + siga = true; + for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) + (void) a68_add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s)); + } + else + { + (void) a68_add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t)); + } + } + u = z; + } + while (siga); + return z; +} + +/* Add row and its slices to chain, recursively. */ + +static MOID_T * +add_row (MOID_T **p, int dim, MOID_T *sub, NODE_T *n, bool derivate) +{ + MOID_T *q = a68_add_mode (p, ROW_SYMBOL, dim, n, sub, NO_PACK); + + DERIVATE (q) |= derivate; + if (dim > 1) + SLICE (q) = add_row (&NEXT (q), dim - 1, sub, n, derivate); + else + SLICE (q) = sub; + return q; +} + +/* Add a moid to a pack, maybe with a (field) name. */ + +void +a68_add_mode_to_pack (PACK_T **p, MOID_T *m, const char *text, NODE_T *node) +{ + PACK_T *z = a68_new_pack (); + + MOID (z) = m; + TEXT (z) = text; + NODE (z) = node; + NEXT (z) = *p; + PREVIOUS (z) = NO_PACK; + if (NEXT (z) != NO_PACK) + PREVIOUS (NEXT (z)) = z; + + /* Link in chain. */ + *p = z; +} + +/* Add a moid to a pack, maybe with a (field) name. */ + +void +a68_add_mode_to_pack_end (PACK_T **p, MOID_T *m, const char *text, NODE_T *node) +{ + PACK_T *z = a68_new_pack (); + + MOID (z) = m; + TEXT (z) = text; + NODE (z) = node; + NEXT (z) = NO_PACK; + if (NEXT (z) != NO_PACK) + PREVIOUS (NEXT (z)) = z; + + /* Link in chain. */ + while ((*p) != NO_PACK) + p = &(NEXT (*p)); + PREVIOUS (z) = (*p); + (*p) = z; +} + +/* Absorb UNION members. */ + +static void +absorb_unions (MOID_T *m) +{ + /* UNION (A, UNION (B, C)) = UNION (A, B, C) or + UNION (A, UNION (A, B)) = UNION (A, B). */ + for (; m != NO_MOID; FORWARD (m)) + { + if (IS (m, UNION_SYMBOL)) + PACK (m) = a68_absorb_union_pack (PACK (m)); + } +} + +/* Contract UNIONs. */ + +static void +contract_unions (MOID_T *m) +{ + /* UNION (A, B, A) -> UNION (A, B). */ + for (; m != NO_MOID; FORWARD (m)) + { + if (IS (m, UNION_SYMBOL) && EQUIVALENT (m) == NO_MOID) + a68_contract_union (m); + } +} + +/* + * Routines to collect MOIDs from the program text. + */ + +/* Search standard mode in standard environ. */ + +static MOID_T * +search_standard_mode (int sizety, NODE_T *indicant) +{ + /* Search standard mode. */ + for (MOID_T *p = TOP_MOID (&A68_JOB); p != NO_MOID; FORWARD (p)) + { + if (IS (p, STANDARD) + && DIM (p) == sizety + && NSYMBOL (NODE (p)) == NSYMBOL (indicant)) + return p; + } + + /* Map onto greater precision. */ + if (sizety < 0) + return search_standard_mode (sizety + 1, indicant); + else if (sizety > 0) + return search_standard_mode (sizety - 1, indicant); + else + return NO_MOID; +} + +/* Collect mode from STRUCT field. */ + +static void +get_mode_from_struct_field (NODE_T *p, PACK_T **u) +{ + if (p != NO_NODE) + { + if (IS (p, IDENTIFIER)) + { + ATTRIBUTE (p) = FIELD_IDENTIFIER; + (void) a68_add_mode_to_pack (u, NO_MOID, NSYMBOL (p), p); + } + else if (IS (p, DECLARER)) + { + MOID_T *new_one = get_mode_from_declarer (p); + + get_mode_from_struct_field (NEXT (p), u); + for (PACK_T *t = *u; t && MOID (t) == NO_MOID; FORWARD (t)) + { + MOID (t) = new_one; + MOID (NODE (t)) = new_one; + } + } + else + { + get_mode_from_struct_field (NEXT (p), u); + get_mode_from_struct_field (SUB (p), u); + } + } +} + +/* Collect MODE from formal pack. */ + +static void +get_mode_from_formal_pack (NODE_T *p, PACK_T **u) +{ + if (p != NO_NODE) + { + if (IS (p, DECLARER)) + { + get_mode_from_formal_pack (NEXT (p), u); + MOID_T *z = get_mode_from_declarer (p); + (void) a68_add_mode_to_pack (u, z, NO_TEXT, p); + } + else + { + get_mode_from_formal_pack (NEXT (p), u); + get_mode_from_formal_pack (SUB (p), u); + } + } +} + +/* Collect MODE or VOID from formal UNION pack. */ + +static void +get_mode_from_union_pack (NODE_T *p, PACK_T **u) +{ + if (p != NO_NODE) + { + if (IS (p, DECLARER) || IS (p, VOID_SYMBOL)) + { + get_mode_from_union_pack (NEXT (p), u); + MOID_T *z = get_mode_from_declarer (p); + (void) a68_add_mode_to_pack (u, z, NO_TEXT, p); + } + else + { + get_mode_from_union_pack (NEXT (p), u); + get_mode_from_union_pack (SUB (p), u); + } + } +} + +/* Collect mode from PROC, OP pack. */ + +static void +get_mode_from_routine_pack (NODE_T *p, PACK_T **u) +{ + if (p != NO_NODE) + { + if (IS (p, IDENTIFIER)) + (void) a68_add_mode_to_pack (u, NO_MOID, NO_TEXT, p); + else if (IS (p, DECLARER)) + { + MOID_T *z = get_mode_from_declarer (p); + + for (PACK_T *t = *u; t != NO_PACK && MOID (t) == NO_MOID; FORWARD (t)) + { + MOID (t) = z; + MOID (NODE (t)) = z; + } + (void) a68_add_mode_to_pack (u, z, NO_TEXT, p); + } + else + { + get_mode_from_routine_pack (NEXT (p), u); + get_mode_from_routine_pack (SUB (p), u); + } + } +} + +/* Collect MODE from DECLARER. */ + +static MOID_T * +get_mode_from_declarer (NODE_T *p) +{ + if (p == NO_NODE) + return NO_MOID; + else + { + if (IS (p, DECLARER)) + { + if (MOID (p) != NO_MOID) + return MOID (p); + else + return MOID (p) = get_mode_from_declarer (SUB (p)); + } + else + { + if (IS (p, VOID_SYMBOL)) + { + MOID (p) = M_VOID; + return MOID (p); + } + else if (IS (p, LONGETY)) + { + if (a68_whether (p, LONGETY, INDICANT, STOP)) + { + int k = count_sizety (SUB (p)); + MOID (p) = search_standard_mode (k, NEXT (p)); + return MOID (p); + } + else + { + return NO_MOID; + } + } + else if (IS (p, SHORTETY)) + { + if (a68_whether (p, SHORTETY, INDICANT, STOP)) + { + int k = count_sizety (SUB (p)); + MOID (p) = search_standard_mode (k, NEXT (p)); + return MOID (p); + } + else + return NO_MOID; + } + else if (IS (p, INDICANT)) + { + MOID_T *q = search_standard_mode (0, p); + if (q != NO_MOID) + MOID (p) = q; + else + { + /* Position of definition tells indicants apart. */ + TAG_T *y = a68_find_tag_global (TABLE (p), INDICANT, NSYMBOL (p)); + if (y == NO_TAG) + a68_error ( p, "tag Z has not been declared properly", NSYMBOL (p)); + else + MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, NODE (y), + NO_MOID, NO_PACK); + } + return MOID (p); + } + else if (IS_REF (p)) + { + MOID_T *new_one = get_mode_from_declarer (NEXT (p)); + MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK); + return MOID (p); + } + else if (IS_FLEX (p)) + { + MOID_T *new_one = get_mode_from_declarer (NEXT (p)); + MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, p, new_one, NO_PACK); + SLICE (MOID (p)) = SLICE (new_one); + return MOID (p); + } + else if (IS (p, FORMAL_BOUNDS)) + { + MOID_T *new_one = get_mode_from_declarer (NEXT (p)); + MOID (p) = add_row (&TOP_MOID (&A68_JOB), + 1 + a68_count_formal_bounds (SUB (p)), new_one, p, false); + return MOID (p); + } + else if (IS (p, BOUNDS)) + { + MOID_T *new_one = get_mode_from_declarer (NEXT (p)); + MOID (p) = add_row (&TOP_MOID (&A68_JOB), count_bounds (SUB (p)), new_one, p, false); + return MOID (p); + } + else if (IS (p, STRUCT_SYMBOL)) + { + PACK_T *u = NO_PACK; + get_mode_from_struct_field (NEXT (p), &u); + MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), + STRUCT_SYMBOL, a68_count_pack_members (u), p, NO_MOID, u); + return MOID (p); + } + else if (IS (p, UNION_SYMBOL)) + { + PACK_T *u = NO_PACK; + get_mode_from_union_pack (NEXT (p), &u); + MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), + UNION_SYMBOL, a68_count_pack_members (u), p, NO_MOID, u); + return MOID (p); + } + else if (IS (p, PROC_SYMBOL)) + { + NODE_T *save = p; + PACK_T *u = NO_PACK; + if (IS (NEXT (p), FORMAL_DECLARERS)) + { + get_mode_from_formal_pack (SUB_NEXT (p), &u); + FORWARD (p); + } + MOID_T *new_one = get_mode_from_declarer (NEXT (p)); + MOID (p) = + a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (u), save, new_one, u); + MOID (save) = MOID (p); + return MOID (p); + } + else + return NO_MOID; + } + } +} + +/* Collect MODEs from a routine-text header. */ + +static MOID_T * +get_mode_from_routine_text (NODE_T *p) +{ + PACK_T *u = NO_PACK; + NODE_T *q = p; + + if (IS (p, PARAMETER_PACK)) + { + get_mode_from_routine_pack (SUB (p), &u); + FORWARD (p); + } + MOID_T *n = get_mode_from_declarer (p); + return a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (u), q, n, u); +} + +/* Collect modes from operator-plan. */ + +static MOID_T * +get_mode_from_operator (NODE_T *p) +{ + PACK_T *u = NO_PACK; + NODE_T *save = p; + + if (IS (NEXT (p), FORMAL_DECLARERS)) + { + get_mode_from_formal_pack (SUB_NEXT (p), &u); + FORWARD (p); + } + MOID_T *new_one = get_mode_from_declarer (NEXT (p)); + MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (u), save, new_one, u); + return MOID (p); +} + +/* Collect mode from denotation. */ + +static void +get_mode_from_denotation (NODE_T *p, int sizety) +{ + if (p != NO_NODE) + { + if (IS (p, ROW_CHAR_DENOTATION)) + { + const char *s = NSYMBOL (p); + size_t len = strlen (s); + + if (len == 1 + || (len == 2 && s[0] == '\'') + || (len == 8 && s[0] == '\'' && s[1] == '(' && s[2] == 'u') + || (len == 12 && s[0] == '\'' && s[1] == '(' && s[2] == 'U')) + { + MOID (p) = M_CHAR; + } + else + MOID (p) = M_ROW_CHAR; + } + else if (IS (p, TRUE_SYMBOL) || IS (p, FALSE_SYMBOL)) + { + MOID (p) = M_BOOL; + } + else if (IS (p, INT_DENOTATION)) + { + if (sizety == -2) + MOID (p) = M_SHORT_SHORT_INT; + else if (sizety == -1) + MOID (p) = M_SHORT_INT; + else if (sizety == 0) + MOID (p) = M_INT; + else if (sizety == 1) + MOID (p) = M_LONG_INT; + else if (sizety == 2) + MOID (p) = M_LONG_LONG_INT; + else + MOID (p) = (sizety > 0 ? M_LONG_LONG_INT : M_INT); + } + else if (IS (p, REAL_DENOTATION)) + { + if (sizety == 0) + MOID (p) = M_REAL; + else if (sizety == 1) + MOID (p) = M_LONG_REAL; + else if (sizety == 2) + MOID (p) = M_LONG_LONG_REAL; + else + MOID (p) = (sizety > 0 ? M_LONG_LONG_REAL : M_REAL); + } + else if (IS (p, BITS_DENOTATION)) + { + if (sizety == -2) + MOID (p) = M_SHORT_SHORT_BITS; + else if (sizety == -1) + MOID (p) = M_SHORT_BITS; + else if (sizety == 0) + MOID (p) = M_BITS; + else if (sizety == 1) + MOID (p) = M_LONG_BITS; + else if (sizety == 2) + MOID (p) = M_LONG_LONG_BITS; + else + MOID (p) = (sizety > 0 ? M_LONG_LONG_BITS : M_BITS); + } + else if (IS (p, LONGETY) || IS (p, SHORTETY)) + { + get_mode_from_denotation (NEXT (p), count_sizety (SUB (p))); + MOID (p) = MOID (NEXT (p)); + } + else if (IS (p, EMPTY_SYMBOL)) + { + MOID (p) = M_VOID; + } + } +} + +/* Collect modes from the syntax tree. */ + +static void +get_modes_from_tree (NODE_T *p, int attribute) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, VOID_SYMBOL)) + MOID (q) = M_VOID; + else if (IS (q, DECLARER)) + { + if (attribute == VARIABLE_DECLARATION) + { + MOID_T *new_one = get_mode_from_declarer (q); + MOID (q) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK); + } + else + MOID (q) = get_mode_from_declarer (q); + } + else if (IS (q, ROUTINE_TEXT)) + { + MOID (q) = get_mode_from_routine_text (SUB (q)); + } + else if (IS (q, OPERATOR_PLAN)) + { + MOID (q) = get_mode_from_operator (SUB (q)); + } + else if (a68_is_one_of (q, LOC_SYMBOL, HEAP_SYMBOL, STOP)) + { + if (attribute == GENERATOR) + { + MOID_T *new_one = get_mode_from_declarer (NEXT (q)); + MOID (NEXT (q)) = new_one; + MOID (q) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK); + } + } + else + { + if (attribute == DENOTATION) + get_mode_from_denotation (q, 0); + } + } + + if (attribute != DENOTATION) + { + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (SUB (q) != NO_NODE) + get_modes_from_tree (SUB (q), ATTRIBUTE (q)); + } + } +} + +//! @brief Collect modes from proc variables. + +static void +get_mode_from_proc_variables (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) + { + get_mode_from_proc_variables (SUB (p)); + get_mode_from_proc_variables (NEXT (p)); + } + else if (IS (p, QUALIFIER) || IS (p, PROC_SYMBOL) || IS (p, COMMA_SYMBOL)) + { + get_mode_from_proc_variables (NEXT (p)); + } + else if (IS (p, DEFINING_IDENTIFIER)) + { + MOID_T *new_one = MOID (NEXT_NEXT (p)); + MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK); + } + } +} + +/* Collect modes from proc variable declarations. */ + +static void +get_mode_from_proc_var_declarations_tree (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + get_mode_from_proc_var_declarations_tree (SUB (p)); + + if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) + get_mode_from_proc_variables (p); + } +} + +/* + * Various routines to test modes. + */ + +/* Whether a mode declaration refers to self or relates to void. + This uses Lindsey's ying-yang algorithm. */ + +static bool +is_well_formed (MOID_T *def, MOID_T *z, bool yin, bool yang, bool video) +{ + if (z == NO_MOID) + return false; + else if (yin && yang) + return z == M_VOID ? video : true; + else if (z == M_VOID) + return video; + else if (IS (z, STANDARD)) + return true; + else if (IS (z, INDICANT)) + { + if (def == NO_MOID) + { + /* Check an applied indicant for relation to VOID. */ + while (z != NO_MOID) + z = EQUIVALENT (z); + if (z == M_VOID) + return video; + else + return true; + } + else + { + if (z == def || USE (z)) + return yin && yang; + else + { + USE (z) = true; + bool wwf = is_well_formed (def, EQUIVALENT (z), yin, yang, video); + USE (z) = false; + return wwf; + } + } + } + else if (IS_REF (z)) + return is_well_formed (def, SUB (z), true, yang, false); + else if (IS (z, PROC_SYMBOL)) + return PACK (z) != NO_PACK ? true : is_well_formed (def, SUB (z), true, yang, true); + else if (IS_ROW (z)) + return is_well_formed (def, SUB (z), yin, yang, false); + else if (IS_FLEX (z)) + return is_well_formed (def, SUB (z), yin, yang, false); + else if (IS (z, STRUCT_SYMBOL)) + { + for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s)) + { + if (!is_well_formed (def, MOID (s), yin, true, false)) + return false; + } + return true; + } + else if (IS (z, UNION_SYMBOL)) + { + for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s)) + { + if (!is_well_formed (def, MOID (s), yin, yang, true)) + return false; + } + return true; + } + else + { + return false; + } +} + +/* Replace a mode by its equivalent mode (walk chain). */ + +static void +resolve_eq_members (MOID_T *q) +{ + resolve_equivalent (&SUB (q)); + resolve_equivalent (&DEFLEXED (q)); + resolve_equivalent (&MULTIPLE (q)); + resolve_equivalent (&NAME (q)); + resolve_equivalent (&SLICE (q)); + resolve_equivalent (&TRIM (q)); + resolve_equivalent (&ROWED (q)); + for (PACK_T *p = PACK (q); p != NO_PACK; FORWARD (p)) + resolve_equivalent (&MOID (p)); +} + +/* Track equivalent tags. */ + +static void +resolve_eq_tags (TAG_T *z) +{ + for (; z != NO_TAG; FORWARD (z)) + { + if (MOID (z) != NO_MOID) + resolve_equivalent (&MOID (z)); + } +} + +/* Bind modes in syntax tree. */ + +static void +bind_modes (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + resolve_equivalent (&MOID (p)); + + if (SUB (p) != NO_NODE && a68_is_new_lexical_level (p)) + { + TABLE_T *s = TABLE (SUB (p)); + for (TAG_T *z = INDICANTS (s); z != NO_TAG; FORWARD (z)) + { + if (NODE (z) != NO_NODE) + { + resolve_equivalent (&MOID (NEXT_NEXT (NODE (z)))); + MOID (z) = MOID (NEXT_NEXT (NODE (z))); + MOID (NODE (z)) = MOID (z); + } + } + } + bind_modes (SUB (p)); + } +} + +/* Routines for calculating subordinates for selections, for instance selection + from REF STRUCT (A) yields REF A fields and selection from [] STRUCT (A) + yields [] A fields. */ + +/* Make name pack. + Given a pack with modes: M1, M2, ... + Build a pack with modes: REF M1, REF M2, ... */ + +static void +make_name_pack (PACK_T *src, PACK_T **dst, MOID_T **p) +{ + if (src != NO_PACK) + { + make_name_pack (NEXT (src), dst, p); + MOID_T *z = a68_add_mode (p, REF_SYMBOL, 0, NO_NODE, MOID (src), NO_PACK); + (void) a68_add_mode_to_pack (dst, z, TEXT (src), NODE (src)); + } +} + +/* Make flex multiple row pack. + Given a pack with modes: M1, M2, ... + Build a pack with modes: []M1, []M2, ... */ + +static void +make_flex_multiple_row_pack (PACK_T *src, PACK_T **dst, MOID_T **p, int dim) +{ + if (src != NO_PACK) + { + make_flex_multiple_row_pack (NEXT (src), dst, p, dim); + MOID_T *z = add_row (p, dim, MOID (src), NO_NODE, false); + z = a68_add_mode (p, FLEX_SYMBOL, 0, NO_NODE, z, NO_PACK); + (void) a68_add_mode_to_pack (dst, z, TEXT (src), NODE (src)); + } +} + +/* Make name struct. */ + +static MOID_T * +make_name_struct (MOID_T *m, MOID_T **p) +{ + PACK_T *u = NO_PACK; + make_name_pack (PACK (m), &u, p); + return a68_add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u); +} + +/* Make name row. */ + +static MOID_T * +make_name_row (MOID_T *m, MOID_T **p) +{ + if (SLICE (m) != NO_MOID) + return a68_add_mode (p, REF_SYMBOL, 0, NO_NODE, SLICE (m), NO_PACK); + else if (SUB (m) != NO_MOID) + return a68_add_mode (p, REF_SYMBOL, 0, NO_NODE, SUB (m), NO_PACK); + else + /* weird, FLEX INT or so ... */ + return NO_MOID; +} + +/* Make multiple row pack. */ + +static void +make_multiple_row_pack (PACK_T *src, PACK_T **dst, MOID_T **p, int dim) +{ + if (src != NO_PACK) + { + make_multiple_row_pack (NEXT (src), dst, p, dim); + (void) a68_add_mode_to_pack (dst, add_row (p, dim, MOID (src), NO_NODE, false), + TEXT (src), NODE (src)); + } +} + +/* Make flex multiple struct. */ + +static MOID_T * +make_flex_multiple_struct (MOID_T *m, MOID_T **p, int dim) +{ + PACK_T *u = NO_PACK; + make_flex_multiple_row_pack (PACK (m), &u, p, dim); + return a68_add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u); +} + +/* Make multiple struct. */ + +static MOID_T * +make_multiple_struct (MOID_T *m, MOID_T **p, int dim) +{ + PACK_T *u = NO_PACK; + make_multiple_row_pack (PACK (m), &u, p, dim); + return a68_add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u); +} + +/* Whether mode has row. */ + +static bool +is_mode_has_row (MOID_T *m) +{ + if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL)) + { + bool k = false; + + for (PACK_T *p = PACK (m); p != NO_PACK && k == false; FORWARD (p)) + { + HAS_ROWS (MOID (p)) = is_mode_has_row (MOID (p)); + k |= (HAS_ROWS (MOID (p))); + } + return k; + } + else + return (HAS_ROWS (m) || IS_ROW (m) || IS_FLEX (m)); +} + +/* Compute derived modes. */ + +static void +compute_derived_modes (MODULE_T *mod) +{ + MOID_T *z; + int len = 0, nlen = 1; + + /* UNION things. */ + absorb_unions (TOP_MOID (mod)); + contract_unions (TOP_MOID (mod)); + /* The for-statement below prevents an endless loop. */ + for (int k = 1; k <= 10 && len != nlen; k++) + { + /* Make deflexed modes. */ + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (SUB (z) != NO_MOID) + { + if (IS_REF_FLEX (z) && DEFLEXED (SUB_SUB (z)) != NO_MOID) + DEFLEXED (z) = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), + DEFLEXED (SUB_SUB (z)), NO_PACK); + else if (IS_REF (z) && DEFLEXED (SUB (z)) != NO_MOID) + DEFLEXED (z) = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), + DEFLEXED (SUB (z)), NO_PACK); + else if (IS_ROW (z) && DEFLEXED (SUB (z)) != NO_MOID) + DEFLEXED (z) = a68_add_mode (&TOP_MOID (mod), ROW_SYMBOL, DIM (z), NODE (z), + DEFLEXED (SUB (z)), NO_PACK); + else if (IS_FLEX (z) && DEFLEXED (SUB (z)) != NO_MOID) + DEFLEXED (z) = DEFLEXED (SUB (z)); + else if (IS_FLEX (z)) + DEFLEXED (z) = SUB (z); + else + DEFLEXED (z) = z; + } + } + + /* Derived modes for stowed modes. */ + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (NAME (z) == NO_MOID && IS_REF (z)) + { + if (IS (SUB (z), STRUCT_SYMBOL)) + NAME (z) = make_name_struct (SUB (z), &TOP_MOID (mod)); + else if (IS_ROW (SUB (z))) + NAME (z) = make_name_row (SUB (z), &TOP_MOID (mod)); + else if (IS_FLEX (SUB (z)) && SUB_SUB (z) != NO_MOID) + NAME (z) = make_name_row (SUB_SUB (z), &TOP_MOID (mod)); + } + + if (MULTIPLE (z) != NO_MOID) + ; + else if (IS_REF (z)) + { + if (MULTIPLE (SUB (z)) != NO_MOID) + MULTIPLE (z) = make_name_struct (MULTIPLE (SUB (z)), &TOP_MOID (mod)); + } + else if (IS_ROW (z)) + { + if (IS (SUB (z), STRUCT_SYMBOL)) + MULTIPLE (z) = make_multiple_struct (SUB (z), &TOP_MOID (mod), DIM (z)); + } + } + + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (TRIM (z) == NO_MOID && IS_FLEX (z)) + TRIM (z) = SUB (z); + if (TRIM (z) == NO_MOID && IS_REF_FLEX (z)) + TRIM (z) = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), SUB_SUB (z), NO_PACK); + } + + /* Fill out stuff for rows, f.i. inverse relations. */ + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (IS_ROW (z) && DIM (z) > 0 && SUB (z) != NO_MOID && !DERIVATE (z)) + (void) add_row (&TOP_MOID (mod), DIM (z) + 1, SUB (z), NODE (z), true); + else if (IS_REF (z) && IS (SUB (z), ROW_SYMBOL) && !DERIVATE (SUB (z))) + { + MOID_T *x = add_row (&TOP_MOID (mod), DIM (SUB (z)) + 1, SUB_SUB (z), NODE (SUB (z)), true); + MOID_T *y = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), x, NO_PACK); + NAME (y) = z; + } + } + + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (IS_ROW (z) && SLICE (z) != NO_MOID) + ROWED (SLICE (z)) = z; + if (IS_REF (z)) + { + MOID_T *y = SUB (z); + if (SLICE (y) != NO_MOID && IS_ROW (SLICE (y)) && NAME (z) != NO_MOID) + ROWED (NAME (z)) = z; + } + } + + bind_modes (TOP_NODE (mod)); + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (IS (z, INDICANT) && NODE (z) != NO_NODE) + EQUIVALENT (z) = MOID (NODE (z)); + } + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + resolve_eq_members (z); + resolve_eq_tags (INDICANTS (A68_STANDENV)); + resolve_eq_tags (IDENTIFIERS (A68_STANDENV)); + resolve_eq_tags (OPERATORS (A68_STANDENV)); + resolve_equivalent (&M_STRING); + resolve_equivalent (&M_COMPLEX); + resolve_equivalent (&M_LONG_COMPLEX); + resolve_equivalent (&M_LONG_LONG_COMPLEX); + resolve_equivalent (&M_SEMA); + /* UNION members could be resolved. */ + absorb_unions (TOP_MOID (mod)); + contract_unions (TOP_MOID (mod)); + /* FLEX INDICANT could be resolved. */ + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (IS_FLEX (z) && SUB (z) != NO_MOID) + { + if (SUB_SUB (z) != NO_MOID && IS (SUB_SUB (z), STRUCT_SYMBOL)) + MULTIPLE (z) = make_flex_multiple_struct (SUB_SUB (z), &TOP_MOID (mod), DIM (SUB (z))); + } + } + /* See what new known modes we have generated by resolving.. */ + for (z = TOP_MOID (mod); z != STANDENV_MOID (&A68_JOB); FORWARD (z)) + { + MOID_T *v; + + for (v = NEXT (z); v != NO_MOID; FORWARD (v)) + { + if (a68_prove_moid_equivalence (z, v)) + { + EQUIVALENT (z) = v; + EQUIVALENT (v) = NO_MOID; + } + } + } + + /* Count the modes to check self consistency. */ + len = nlen; + for (nlen = 0, z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + nlen++; + } + + gcc_assert (M_STRING == M_FLEX_ROW_CHAR); + + /* Find out what modes contain rows. */ + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + HAS_ROWS (z) = is_mode_has_row (z); + + /* Check flexible modes. */ + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (IS_FLEX (z) && !IS (SUB (z), ROW_SYMBOL)) + a68_error (NODE (z), "M does not specify a well formed mode", z); + } + + /* Check on fields in structured modes f.i. STRUCT (REAL x, INT n, REAL x) is + wrong. */ + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (IS (z, STRUCT_SYMBOL) && EQUIVALENT (z) == NO_MOID) + { + PACK_T *s = PACK (z); + + for (; s != NO_PACK; FORWARD (s)) + { + PACK_T *t = NEXT (s); + bool x = true; + + for (t = NEXT (s); t != NO_PACK && x; FORWARD (t)) + { + if (TEXT (s) == TEXT (t)) + { + a68_error (NODE (z), "multiple declaration of field S"); + while (NEXT (s) != NO_PACK && TEXT (NEXT (s)) == TEXT (t)) + FORWARD (s); + x = false; + } + } + } + } + } + + /* Various union test. */ + for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (IS (z, UNION_SYMBOL) && EQUIVALENT (z) == NO_MOID) + { + PACK_T *s = PACK (z); + /* Discard unions with one member. */ + if (a68_count_pack_members (s) == 1) + a68_error (NODE (z), "M must have at least two components", z); + /* Discard incestuous unions with firmly related modes. */ + for (; s != NO_PACK; FORWARD (s)) + { + PACK_T *t; + + for (t = NEXT (s); t != NO_PACK; FORWARD (t)) + { + if (MOID (t) != MOID (s)) + { + if (a68_is_firm (MOID (s), MOID (t))) + a68_error (NODE (z), "M has firmly related components", z); + } + } + } + + /* Discard incestuous unions with firmly related subsets. */ + for (s = PACK (z); s != NO_PACK; FORWARD (s)) + { + MOID_T *n = a68_depref_completely (MOID (s)); + + if (IS (n, UNION_SYMBOL) && a68_is_subset (n, z, NO_DEFLEXING)) + a68_error (NODE (z), "M has firmly related subset M", z, n); + } + } + } + + /* Wrap up and exit. */ + a68_free_postulate_list (A68 (top_postulate), NO_POSTULATE); + A68 (top_postulate) = NO_POSTULATE; +} + +/* Make list of all modes in the program. */ + +void +a68_make_moid_list (MODULE_T *mod) +{ + bool cont = true; + + /* Collect modes from the syntax tree. */ + reset_moid_tree (TOP_NODE (mod)); + get_modes_from_tree (TOP_NODE (mod), STOP); + get_mode_from_proc_var_declarations_tree (TOP_NODE (mod)); + + /* Connect indicants to their declarers. */ + for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (IS (z, INDICANT)) + { + NODE_T *u = NODE (z); + gcc_assert (NEXT (u) != NO_NODE); + gcc_assert (NEXT_NEXT (u) != NO_NODE); + gcc_assert (MOID (NEXT_NEXT (u)) != NO_MOID); + EQUIVALENT (z) = MOID (NEXT_NEXT (u)); + } + } + + /* Checks on wrong declarations. */ + for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + USE (z) = false; + + for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) + { + if (!is_well_formed (z, EQUIVALENT (z), false, false, true)) + { + a68_error (NODE (z), "M does not specify a well formed mode", z); + cont = false; + } + } + } + + for (MOID_T *z = TOP_MOID (mod); cont && z != NO_MOID; FORWARD (z)) + { + if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) + ; + else if (NODE (z) != NO_NODE) + { + if (!is_well_formed (NO_MOID, z, false, false, true)) + a68_error (NODE (z), "M does not specify a well formed mode", z); + } + } + + for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) + { + if (USE (z)) + gcc_unreachable (); + } + + if (ERROR_COUNT (mod) != 0) + return; + + compute_derived_modes (mod); + a68_init_postulates (); +} diff --git a/gcc/algol68/a68-parser-moids-check.cc b/gcc/algol68/a68-parser-moids-check.cc new file mode 100644 index 000000000000..a7b02cb19576 --- /dev/null +++ b/gcc/algol68/a68-parser-moids-check.cc @@ -0,0 +1,1878 @@ +/* Mode checker routines. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC and fixes by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* ALGOL 68 contexts are SOFT, WEAK, MEEK, FIRM and STRONG. + These contexts are increasing in strength: + + SOFT: Deproceduring + + WEAK: Dereferencing to REF [] or REF STRUCT + + MEEK: Deproceduring and dereferencing + + FIRM: MEEK followed by uniting + + STRONG: FIRM followed by rowing, widening or voiding + + Furthermore you will see in this file next switches: + + (1) FORCE_DEFLEXING allows assignment compatibility between FLEX and non FLEX + rows. This can only be the case when there is no danger of altering bounds of a + non FLEX row. + + (2) ALIAS_DEFLEXING prohibits aliasing a FLEX row to a non FLEX row (vice versa + is no problem) so that one cannot alter the bounds of a non FLEX row by + aliasing it to a FLEX row. This is particularly the case when passing names as + parameters to procedures: + + PROC x = (REF STRING s) VOID: ..., PROC y = (REF [] CHAR c) VOID: ...; + + x (LOC STRING); # OK # + + x (LOC [10] CHAR); # Not OK, suppose x changes bounds of s! # + + y (LOC STRING); # OK # + + y (LOC [10] CHAR); # OK # + + (3) SAFE_DEFLEXING sets FLEX row apart from non FLEX row. This holds for names, + not for values, so common things are not rejected, for instance + + STRING x = read string; + + [] CHAR y = read string + + (4) NO_DEFLEXING sets FLEX row apart from non FLEX row. */ + +/* + In the RR grammar: + + SORT: strong; firm; weak; meek; soft. + SORT MOID serial clause; + strong void unit, go on token, SORT MOID serial clause; + declaration, go on token, SORT MOID serial clause; + SORT MOID unit + + And it is the SORT MOID sequence of metanotions, which shall evaluate the + same in the complete rule, that control the balancing! o_O + + Also, it denotes how the SORT MOID of the serial clause gets "passed" to the + last unit in the serial clause. Other units have SOID `strong void'. + + It is used to pass down the required mode on whatever context. Like, + PARTICULAR_PROGRAM evaluates in strong context and requires VOID. + + The ATTRIBUTE in the soid is used to pass down the kind of construct that + introduces the context+required mode. This is used in + a68_determine_unique_mode in order to know whether balancing shall be + performed or not. +*/ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" + +#include "a68.h" + +/* Forward declarations of some of the functions defined below. */ + +static void mode_check_enclosed (NODE_T *p, SOID_T *x, SOID_T *y); +static void mode_check_unit (NODE_T *p, SOID_T *x, SOID_T *y); +static void mode_check_formula (NODE_T *p, SOID_T *x, SOID_T *y); +static void mode_check_module_declaration (NODE_T *p); +static void mode_check_module_text (NODE_T *p); +static void mode_check_module_declaration (NODE_T *p); + +/* Driver for mode checker. */ + +void +a68_mode_checker (NODE_T *p) +{ + if (IS (p, PACKET)) + { + p = SUB (p); + + if (IS (p, PARTICULAR_PROGRAM)) + { + A68 (top_soid_list) = NO_SOID; + SOID_T x, y; + a68_make_soid (&x, STRONG, M_VOID, 0); + mode_check_enclosed (SUB (p), &x, &y); + MOID (p) = MOID (&y); + } + else if (IS (p, PRELUDE_PACKET)) + mode_check_module_declaration (SUB (p)); + } +} + +/* Mode check on bounds. */ + +static void +mode_check_bounds (NODE_T *p) +{ + if (p == NO_NODE) + return; + else if (IS (p, UNIT)) + { + SOID_T x, y; + a68_make_soid (&x, STRONG, M_INT, 0); + mode_check_unit (p, &x, &y); + if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) + a68_cannot_coerce (p, MOID (&y), M_INT, MEEK, SAFE_DEFLEXING, UNIT); + mode_check_bounds (NEXT (p)); + } + else + { + mode_check_bounds (SUB (p)); + mode_check_bounds (NEXT (p)); + } +} + +/* Mode check declarer. */ + +static void +mode_check_declarer (NODE_T *p) +{ + if (p == NO_NODE) + return; + else if (IS (p, BOUNDS)) + { + mode_check_bounds (SUB (p)); + mode_check_declarer (NEXT (p)); + } + else + { + mode_check_declarer (SUB (p)); + mode_check_declarer (NEXT (p)); + } +} + +/* Mode check identity declaration. */ + +static void +mode_check_identity_declaration (NODE_T *p) +{ + if (p != NO_NODE) + { + switch (ATTRIBUTE (p)) + { + case DECLARER: + mode_check_declarer (SUB (p)); + mode_check_identity_declaration (NEXT (p)); + break; + case DEFINING_IDENTIFIER: + { + SOID_T x, y; + a68_make_soid (&x, STRONG, MOID (p), 0); + mode_check_unit (NEXT_NEXT (p), &x, &y); + if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) + a68_cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT); + else if (MOID (&x) != MOID (&y)) + /* Check for instance, REF INT i = LOC REF INT. */ + a68_semantic_pitfall (NEXT_NEXT (p), MOID (&x), IDENTITY_DECLARATION, GENERATOR); + break; + } + default: + mode_check_identity_declaration (SUB (p)); + mode_check_identity_declaration (NEXT (p)); + break; + } + } +} + +/* Mode check variable declaration. */ + +static void +mode_check_variable_declaration (NODE_T *p) +{ + if (p != NO_NODE) + { + switch (ATTRIBUTE (p)) + { + case DECLARER: + mode_check_declarer (SUB (p)); + mode_check_variable_declaration (NEXT (p)); + break; + case DEFINING_IDENTIFIER: + if (a68_whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) + { + SOID_T x, y; + a68_make_soid (&x, STRONG, SUB_MOID (p), 0); + mode_check_unit (NEXT_NEXT (p), &x, &y); + if (!a68_is_coercible_in_context (&y, &x, FORCE_DEFLEXING)) + a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, FORCE_DEFLEXING, UNIT); + else if (SUB_MOID (&x) != MOID (&y)) + /* Check for instance, REF INT i = LOC REF INT. */ + a68_semantic_pitfall (NEXT_NEXT (p), MOID (&x), VARIABLE_DECLARATION, GENERATOR); + } + break; + default: + mode_check_variable_declaration (SUB (p)); + mode_check_variable_declaration (NEXT (p)); + break; + } + } +} + +/* Mode check routine text. */ + +static void +mode_check_routine_text (NODE_T *p, SOID_T *y) +{ + SOID_T w; + + if (IS (p, PARAMETER_PACK)) + { + mode_check_declarer (SUB (p)); + FORWARD (p); + } + + mode_check_declarer (SUB (p)); + a68_make_soid (&w, STRONG, MOID (p), 0); + mode_check_unit (NEXT_NEXT (p), &w, y); + if (!a68_is_coercible_in_context (y, &w, FORCE_DEFLEXING)) + a68_cannot_coerce (NEXT_NEXT (p), MOID (y), MOID (&w), STRONG, FORCE_DEFLEXING, UNIT); +} + +/* Mode check proc declaration. */ + +static void +mode_check_proc_declaration (NODE_T *p) +{ + if (p == NO_NODE) + return; + else if (IS (p, ROUTINE_TEXT)) + { + SOID_T x, y; + a68_make_soid (&x, STRONG, NO_MOID, 0); + mode_check_routine_text (SUB (p), &y); + } + else + { + mode_check_proc_declaration (SUB (p)); + mode_check_proc_declaration (NEXT (p)); + } +} + +/* Mode check brief op declaration. */ + +static void +mode_check_brief_op_declaration (NODE_T *p) +{ + if (p == NO_NODE) + return; + else if (IS (p, DEFINING_OPERATOR)) + { + SOID_T y; + + if (MOID (p) != MOID (NEXT_NEXT (p))) + { + SOID_T y2, x; + a68_make_soid (&y2, NO_SORT, MOID (NEXT_NEXT (p)), 0); + a68_make_soid (&x, NO_SORT, MOID (p), 0); + a68_cannot_coerce (NEXT_NEXT (p), MOID (&y2), MOID (&x), STRONG, SKIP_DEFLEXING, ROUTINE_TEXT); + } + mode_check_routine_text (SUB (NEXT_NEXT (p)), &y); + } + else + { + mode_check_brief_op_declaration (SUB (p)); + mode_check_brief_op_declaration (NEXT (p)); + } +} + +/* Mode check op declaration. */ + +static void +mode_check_op_declaration (NODE_T *p) +{ + if (p == NO_NODE) + return; + else if (IS (p, DEFINING_OPERATOR)) + { + SOID_T y, x; + a68_make_soid (&x, STRONG, MOID (p), 0); + mode_check_unit (NEXT_NEXT (p), &x, &y); + if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) + a68_cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT); + } + else + { + mode_check_op_declaration (SUB (p)); + mode_check_op_declaration (NEXT (p)); + } +} + +/* Mode check declaration list. */ + +static void +mode_check_declaration_list (NODE_T * p) +{ + if (p != NO_NODE) + { + switch (ATTRIBUTE (p)) + { + case IDENTITY_DECLARATION: + mode_check_identity_declaration (SUB (p)); + break; + case VARIABLE_DECLARATION: + mode_check_variable_declaration (SUB (p)); + break; + case MODE_DECLARATION: + mode_check_declarer (SUB (p)); + break; + case PROCEDURE_DECLARATION: + case PROCEDURE_VARIABLE_DECLARATION: + mode_check_proc_declaration (SUB (p)); + break; + case BRIEF_OPERATOR_DECLARATION: + mode_check_brief_op_declaration (SUB (p)); + break; + case OPERATOR_DECLARATION: + mode_check_op_declaration (SUB (p)); + break; + default: + mode_check_declaration_list (SUB (p)); + mode_check_declaration_list (NEXT (p)); + break; + } + } +} + +/* Mode check serial clause. */ + +static void +mode_check_serial (SOID_T **r, NODE_T *p, SOID_T *x, bool k) +{ + if (p == NO_NODE) + return; + else if (IS (p, INITIALISER_SERIES)) + { + mode_check_serial (r, SUB (p), x, false); + mode_check_serial (r, NEXT (p), x, k); + } + else if (IS (p, DECLARATION_LIST)) + mode_check_declaration_list (SUB (p)); + else if (a68_is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) + mode_check_serial (r, NEXT (p), x, k); + else if (a68_is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) + { + if (NEXT (p) != NO_NODE) + { + if (IS (NEXT (p), EXIT_SYMBOL) || IS (NEXT (p), END_SYMBOL) || IS (NEXT (p), CLOSE_SYMBOL)) + mode_check_serial (r, SUB (p), x, true); + else + mode_check_serial (r, SUB (p), x, false); + mode_check_serial (r, NEXT (p), x, k); + } + else + mode_check_serial (r, SUB (p), x, true); + } + else if (IS (p, LABELED_UNIT)) + mode_check_serial (r, SUB (p), x, k); + else if (IS (p, UNIT)) + { + SOID_T y; + + if (k) + mode_check_unit (p, x, &y); + else + { + SOID_T w; + a68_make_soid (&w, STRONG, M_VOID, 0); + mode_check_unit (p, &w, &y); + } + if (NEXT (p) != NO_NODE) + mode_check_serial (r, NEXT (p), x, k); + else + { + if (k) + a68_add_to_soid_list (r, p, &y); + } + } +} + +/* Mode check serial clause units. */ + +static void +mode_check_serial_units (NODE_T *p, SOID_T *x, SOID_T *y, + int att __attribute__((unused))) +{ + SOID_T *top_sl = NO_SOID; + + mode_check_serial (&top_sl, SUB (p), x, true); + if (a68_is_balanced (p, top_sl, SORT (x))) + { + MOID_T *result = a68_pack_soids_in_moid (top_sl, SERIES_MODE); + a68_make_soid (y, SORT (x), result, SERIAL_CLAUSE); + } + else + a68_make_soid (y, SORT (x), (MOID (x) != NO_MOID ? MOID (x) : M_ERROR), 0); + + a68_free_soid_list (top_sl); +} + +/* Mode check unit list. */ + +static void +mode_check_unit_list (SOID_T **r, NODE_T *p, SOID_T *x) +{ + if (p == NO_NODE) + return; + else if (IS (p, UNIT_LIST)) + { + mode_check_unit_list (r, SUB (p), x); + mode_check_unit_list (r, NEXT (p), x); + } + else if (IS (p, COMMA_SYMBOL)) + mode_check_unit_list (r, NEXT (p), x); + else if (IS (p, UNIT)) + { + SOID_T y; + mode_check_unit (p, x, &y); + a68_add_to_soid_list (r, p, &y); + mode_check_unit_list (r, NEXT (p), x); + } +} + +/* Mode check struct display. */ + +static void +mode_check_struct_display (SOID_T **r, NODE_T *p, PACK_T **fields) +{ + if (p == NO_NODE) + return; + else if (IS (p, UNIT_LIST)) + { + mode_check_struct_display (r, SUB (p), fields); + mode_check_struct_display (r, NEXT (p), fields); + } + else if (IS (p, COMMA_SYMBOL)) + mode_check_struct_display (r, NEXT (p), fields); + else if (IS (p, UNIT)) + { + SOID_T x, y; + + if (*fields != NO_PACK) + { + a68_make_soid (&x, STRONG, MOID (*fields), 0); + FORWARD (*fields); + } + else + a68_make_soid (&x, STRONG, NO_MOID, 0); + mode_check_unit (p, &x, &y); + a68_add_to_soid_list (r, p, &y); + mode_check_struct_display (r, NEXT (p), fields); + } +} + +/* Mode check get specified moids. */ + +static void +mode_check_get_specified_moids (NODE_T *p, MOID_T *u) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (a68_is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) + mode_check_get_specified_moids (SUB (p), u); + else if (IS (p, SPECIFIER)) + { + MOID_T *m = MOID (NEXT_SUB (p)); + a68_add_mode_to_pack (&(PACK (u)), m, NO_TEXT, NODE (m)); + } + } +} + +/* Mode check specified unit list. */ + +void +mode_check_specified_unit_list (SOID_T **r, NODE_T *p, SOID_T *x, MOID_T *u) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (a68_is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) + mode_check_specified_unit_list (r, SUB (p), x, u); + else if (IS (p, SPECIFIER)) + { + MOID_T *m = MOID (NEXT_SUB (p)); + if (u != NO_MOID && !a68_is_unitable (m, u, SAFE_DEFLEXING)) + a68_error (p, "M is neither component nor subset of M", m, u); + + } + else if (IS (p, UNIT)) + { + SOID_T y; + mode_check_unit (p, x, &y); + a68_add_to_soid_list (r, p, &y); + } + } +} + +/* Mode check united case parts. */ + +static void +mode_check_united_case_parts (SOID_T **ry, NODE_T *p, SOID_T *x) +{ + SOID_T enq_expct, enq_yield; + MOID_T *u = NO_MOID, *v = NO_MOID, *w = NO_MOID; + /* Check the CASE part and deduce the united mode. */ + a68_make_soid (&enq_expct, MEEK, NO_MOID, 0); + mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); + /* Deduce the united mode from the enquiry clause. + This requires balancing. */ + u = MOID (&enq_yield); + a68_absorb_series_pack (&u); + DIM (u) = a68_count_pack_members (PACK (u)); + if (DIM (u) == 1) + u = MOID (PACK (u)); + else + { + MOID_T *united, *balanced; + united = a68_make_united_mode (u); + balanced = a68_get_balanced_mode_or_no_mode (united, + STRONG, A68_NO_DEPREF, + SAFE_DEFLEXING); + if (balanced != NO_MOID) + u = balanced; + } + u = a68_depref_completely (u); + /* Also deduce the united mode from the specifiers. */ + v = a68_new_moid (); + ATTRIBUTE (v) = SERIES_MODE; + mode_check_get_specified_moids (NEXT_SUB (NEXT (p)), v); + v = a68_make_united_mode (v); + /* Determine a resulting union. */ + if (u == M_HIP) + w = v; + else + { + if (IS (u, UNION_SYMBOL)) + { + bool uv, vu, some; + a68_investigate_firm_relations (PACK (u), PACK (v), &uv, &some); + a68_investigate_firm_relations (PACK (v), PACK (u), &vu, &some); + if (uv && vu) + { + /* Every component has a specifier. */ + w = u; + } + else if (!uv && !vu) + { + /* Hmmmm ... let the coercer sort it out. */ + w = u; + } + else + { + /* This is all the balancing we allow here for the moment. Firmly + related subsets are not valid so we absorb them. If this + doesn't solve it then we get a coercion-error later. */ + w = a68_absorb_related_subsets (u); + } + } + else + { + a68_error (NEXT_SUB (p), "M is not a united mode", u); + return; + } + } + MOID (SUB (p)) = w; + FORWARD (p); + /* Check the IN part. */ + mode_check_specified_unit_list (ry, NEXT_SUB (p), x, w); + /* OUSE, OUT, ESAC. */ + if ((FORWARD (p)) != NO_NODE) + { + if (a68_is_one_of (p, OUT_PART, CHOICE, STOP)) + mode_check_serial (ry, NEXT_SUB (p), x, true); + else if (a68_is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) + mode_check_united_case_parts (ry, SUB (p), x); + } +} + +/* Mode check united case. */ + +static void +mode_check_united_case (NODE_T *p, SOID_T *x, SOID_T *y) +{ + SOID_T *top_sl = NO_SOID; + + mode_check_united_case_parts (&top_sl, p, x); + if (!a68_is_balanced (p, top_sl, SORT (x))) + { + if (MOID (x) != NO_MOID) + a68_make_soid (y, SORT (x), MOID (x), CONFORMITY_CLAUSE); + else + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + else + { + MOID_T *z = a68_pack_soids_in_moid (top_sl, SERIES_MODE); + a68_make_soid (y, SORT (x), z, CONFORMITY_CLAUSE); + } + a68_free_soid_list (top_sl); +} + +/* Mode check unit list 2. */ + +static void +mode_check_unit_list_2 (NODE_T *p, SOID_T *x, SOID_T *y) +{ + SOID_T *top_sl = NO_SOID; + + if (MOID (x) != NO_MOID) + { + if (IS_FLEX (MOID (x))) + { + SOID_T y2; + a68_make_soid (&y2, SORT (x), SLICE (SUB_MOID (x)), 0); + mode_check_unit_list (&top_sl, SUB (p), &y2); + } + else if (IS_ROW (MOID (x))) + { + SOID_T y2; + a68_make_soid (&y2, SORT (x), SLICE (MOID (x)), 0); + mode_check_unit_list (&top_sl, SUB (p), &y2); + } + else if (IS (MOID (x), STRUCT_SYMBOL)) + { + PACK_T *y2 = PACK (MOID (x)); + mode_check_struct_display (&top_sl, SUB (p), &y2); + } + else + mode_check_unit_list (&top_sl, SUB (p), x); + } + else + mode_check_unit_list (&top_sl, SUB (p), x); + + a68_make_soid (y, STRONG, a68_pack_soids_in_moid (top_sl, STOWED_MODE), 0); + a68_free_soid_list (top_sl); +} + +/* Mode check access. */ + +static void +mode_check_access (NODE_T *p, SOID_T *x, SOID_T *y) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, ENCLOSED_CLAUSE)) + { + mode_check_enclosed (q, x, y); + MOID (p) = MOID (y); + } + } +} + +/* Mode check closed. */ + +static void +mode_check_closed (NODE_T *p, SOID_T *x, SOID_T *y) +{ + if (p == NO_NODE) + return; + else if (IS (p, SERIAL_CLAUSE)) + mode_check_serial_units (p, x, y, SERIAL_CLAUSE); + else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) + mode_check_closed (NEXT (p), x, y); + MOID (p) = MOID (y); +} + +/* Mode check collateral. */ + +void +mode_check_collateral (NODE_T *p, SOID_T *x, SOID_T *y) +{ + if (p == NO_NODE) + return; + else if (a68_whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) + || a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP)) + { + if (SORT (x) == STRONG) + { + if (MOID (x) == NO_MOID) + a68_error (p, "vacuum cannot have row elements (use a Y generator)", + "REF MODE"); + else if (IS_FLEXETY_ROW (MOID (x))) + a68_make_soid (y, STRONG, M_VACUUM, 0); + else + { + /* The syntax only allows vacuums in strong contexts with rowed + modes. See rule 33d. */ + a68_error (p, "a vacuum is not a valid M", MOID (x)); + a68_make_soid (y, STRONG, M_ERROR, 0); + } + } + else + a68_make_soid (y, STRONG, M_UNDEFINED, 0); + } + else + { + if (IS (p, UNIT_LIST)) + mode_check_unit_list_2 (p, x, y); + else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) + mode_check_collateral (NEXT (p), x, y); + MOID (p) = MOID (y); + } +} + +/* Mode check conditional 2. */ + +static void +mode_check_conditional_2 (SOID_T **ry, NODE_T *p, SOID_T *x) +{ + SOID_T enq_expct, enq_yield; + + a68_make_soid (&enq_expct, MEEK, M_BOOL, 0); + mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); + if (!a68_is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) + a68_cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); + FORWARD (p); + mode_check_serial (ry, NEXT_SUB (p), x, true); + if ((FORWARD (p)) != NO_NODE) + { + if (a68_is_one_of (p, ELSE_PART, CHOICE, STOP)) + mode_check_serial (ry, NEXT_SUB (p), x, true); + else if (a68_is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) + mode_check_conditional_2 (ry, SUB (p), x); + } +} + +/* Mode check conditional. */ + +static void +mode_check_conditional (NODE_T *p, SOID_T *x, SOID_T *y) +{ + SOID_T *top_sl = NO_SOID; + mode_check_conditional_2 (&top_sl, p, x); + if (!a68_is_balanced (p, top_sl, SORT (x))) + { + if (MOID (x) != NO_MOID) + a68_make_soid (y, SORT (x), MOID (x), CONDITIONAL_CLAUSE); + else + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + else + { + MOID_T *z = a68_pack_soids_in_moid (top_sl, SERIES_MODE); + a68_make_soid (y, SORT (x), z, CONDITIONAL_CLAUSE); + } + a68_free_soid_list (top_sl); +} + +/* Mode check int case 2. */ + +static void +mode_check_int_case_2 (SOID_T **ry, NODE_T *p, SOID_T *x) +{ + SOID_T enq_expct, enq_yield; + a68_make_soid (&enq_expct, MEEK, M_INT, 0); + mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); + if (!a68_is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) + a68_cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); + FORWARD (p); + mode_check_unit_list (ry, NEXT_SUB (p), x); + if ((FORWARD (p)) != NO_NODE) + { + if (a68_is_one_of (p, OUT_PART, CHOICE, STOP)) + mode_check_serial (ry, NEXT_SUB (p), x, true); + else if (a68_is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) + mode_check_int_case_2 (ry, SUB (p), x); + } +} + +/* Mode check int case. */ + +static void +mode_check_int_case (NODE_T *p, SOID_T *x, SOID_T *y) +{ + SOID_T *top_sl = NO_SOID; + mode_check_int_case_2 (&top_sl, p, x); + if (!a68_is_balanced (p, top_sl, SORT (x))) + { + if (MOID (x) != NO_MOID) + a68_make_soid (y, SORT (x), MOID (x), CASE_CLAUSE); + else + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + else + { + MOID_T *z = a68_pack_soids_in_moid (top_sl, SERIES_MODE); + a68_make_soid (y, SORT (x), z, CASE_CLAUSE); + } + a68_free_soid_list (top_sl); +} + +/* Mode check loop 2. */ + +static void +mode_check_loop_2 (NODE_T *p, SOID_T *y) +{ + if (p == NO_NODE) + return; + else if (IS (p, FOR_PART)) + mode_check_loop_2 (NEXT (p), y); + else if (a68_is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) + { + SOID_T ix, iy; + a68_make_soid (&ix, STRONG, M_INT, 0); + mode_check_unit (NEXT_SUB (p), &ix, &iy); + if (!a68_is_coercible_in_context (&iy, &ix, SAFE_DEFLEXING)) + a68_cannot_coerce (NEXT_SUB (p), MOID (&iy), M_INT, MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); + mode_check_loop_2 (NEXT (p), y); + } + else if (IS (p, WHILE_PART)) + { + SOID_T enq_expct, enq_yield; + a68_make_soid (&enq_expct, MEEK, M_BOOL, 0); + mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); + if (!a68_is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) + a68_cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); + mode_check_loop_2 (NEXT (p), y); + } + else if (a68_is_one_of (p, DO_PART, ALT_DO_PART, STOP)) + { + SOID_T *z = NO_SOID; + NODE_T *do_p = NEXT_SUB (p); + SOID_T ix; + a68_make_soid (&ix, STRONG, M_VOID, 0); + if (IS (do_p, SERIAL_CLAUSE)) + mode_check_serial (&z, do_p, &ix, true); + a68_free_soid_list (z); + } +} + +/* Mode check loop. */ + +static void +mode_check_loop (NODE_T *p, SOID_T *y) +{ + SOID_T *z = NO_SOID; + mode_check_loop_2 (p, z); + a68_make_soid (y, STRONG, M_VOID, 0); +} + +/* Mode check enclosed. */ + +static void +mode_check_enclosed (NODE_T *p, SOID_T *x, SOID_T *y) +{ + if (p == NO_NODE) + return; + else if (IS (p, ENCLOSED_CLAUSE)) + mode_check_enclosed (SUB (p), x, y); + else if (IS (p, CLOSED_CLAUSE)) + mode_check_closed (SUB (p), x, y); + else if (IS (p, ACCESS_CLAUSE)) + mode_check_access (SUB (p), x, y); + else if (IS (p, PARALLEL_CLAUSE)) + { + mode_check_collateral (SUB (NEXT_SUB (p)), x, y); + a68_make_soid (y, STRONG, M_VOID, 0); + MOID (NEXT_SUB (p)) = M_VOID; + } + else if (IS (p, COLLATERAL_CLAUSE)) + mode_check_collateral (SUB (p), x, y); + else if (IS (p, CONDITIONAL_CLAUSE)) + mode_check_conditional (SUB (p), x, y); + else if (IS (p, CASE_CLAUSE)) + mode_check_int_case (SUB (p), x, y); + else if (IS (p, CONFORMITY_CLAUSE)) + mode_check_united_case (SUB (p), x, y); + else if (IS (p, LOOP_CLAUSE)) + mode_check_loop (SUB (p), y); + + MOID (p) = MOID (y); +} + +/* Search table for operator. */ + +static TAG_T * +search_table_for_operator (TAG_T *t, const char *n, MOID_T *x, MOID_T *y) +{ + if (a68_is_mode_isnt_well (x)) + return A68_PARSER (error_tag); + else if (y != NO_MOID && a68_is_mode_isnt_well (y)) + return A68_PARSER (error_tag); + + for (; t != NO_TAG; FORWARD (t)) + { + if (NSYMBOL (NODE (t)) == n || strcmp (NSYMBOL (NODE (t)), n) == 0) + { + PACK_T *p = PACK (MOID (t)); + if (a68_is_coercible (x, MOID (p), FIRM, ALIAS_DEFLEXING)) + { + FORWARD (p); + if (p == NO_PACK && y == NO_MOID) + /* Matched in case of a monadic. */ + return t; + else if (p != NO_PACK && y != NO_MOID + && a68_is_coercible (y, MOID (p), FIRM, ALIAS_DEFLEXING)) + /* Matched in case of a dyadic. */ + return t; + } + } + } + return NO_TAG; +} + +/* Search chain of symbol tables and return matching operator "x n y" or + "n x". */ + +static TAG_T * +search_table_chain_for_operator (TABLE_T *s, const char *n, MOID_T *x, MOID_T *y) +{ + if (a68_is_mode_isnt_well (x)) + return A68_PARSER (error_tag); + else if (y != NO_MOID && a68_is_mode_isnt_well (y)) + return A68_PARSER (error_tag); + + while (s != NO_TABLE) + { + TAG_T *z = search_table_for_operator (OPERATORS (s), n, x, y); + if (z != NO_TAG) + return z; + BACKWARD (s); + } + return NO_TAG; +} + +/* Return a matching operator "x n y". */ + +static TAG_T * +find_operator (TABLE_T *s, const char *n, MOID_T *x, MOID_T *y) +{ + /* Coercions to operand modes are FIRM. */ + MOID_T *u, *v; TAG_T *z; + /* (A) Catch exceptions first. */ + if (x == NO_MOID && y == NO_MOID) + return NO_TAG; + else if (a68_is_mode_isnt_well (x)) + return A68_PARSER (error_tag); + else if (y != NO_MOID && a68_is_mode_isnt_well (y)) + return A68_PARSER (error_tag); + + /* (B) MONADs. */ + if (x != NO_MOID && y == NO_MOID) + { + z = search_table_chain_for_operator (s, n, x, NO_MOID); + if (z != NO_TAG) + return z; + else + { + /* (B.2) A little trick to allow - (0, 1) or ABS (1, long pi). */ + if (a68_is_coercible (x, M_COMPLEX, STRONG, SAFE_DEFLEXING)) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, NO_MOID); + if (z != NO_TAG) + return z; + } + if (a68_is_coercible (x, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, NO_MOID); + if (z != NO_TAG) + return z; + } + if (a68_is_coercible (x, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, NO_MOID); + } + return NO_TAG; + } + /* (C) DYADs. */ + z = search_table_chain_for_operator (s, n, x, y); + if (z != NO_TAG) + return z; + /* (C.2) Vector and matrix "strong coercions" in standard environ. */ + u = DEFLEX (a68_depref_completely (x)); + v = DEFLEX (a68_depref_completely (y)); + if ((u == M_ROW_REAL || u == M_ROW_ROW_REAL) + || (v == M_ROW_REAL || v == M_ROW_ROW_REAL) + || (u == M_ROW_COMPLEX || u == M_ROW_ROW_COMPLEX) + || (v == M_ROW_COMPLEX || v == M_ROW_ROW_COMPLEX)) + { + if (u == M_INT) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, y); + if (z != NO_TAG) + return z; + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y); + if (z != NO_TAG) + return z; + } + else if (v == M_INT) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_REAL); + if (z != NO_TAG) + return z; + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX); + if (z != NO_TAG) + return z; + } + else if (u == M_REAL) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y); + if (z != NO_TAG) + return z; + } + else if (v == M_REAL) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX); + if (z != NO_TAG) + return z; + } + } + /* (C.3) Look in standenv for an appropriate cross-term. */ + u = a68_make_series_from_moids (x, y); + u = a68_make_united_mode (u); + v = a68_get_balanced_mode (u, STRONG, A68_NO_DEPREF, SAFE_DEFLEXING); + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v); + if (z != NO_TAG) + return z; + if (a68_is_coercible_series (u, M_REAL, STRONG, SAFE_DEFLEXING)) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, M_REAL); + if (z != NO_TAG) + return z; + } + if (a68_is_coercible_series (u, M_LONG_REAL, STRONG, SAFE_DEFLEXING)) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_REAL, M_LONG_REAL); + if (z != NO_TAG) + return z; + } + if (a68_is_coercible_series (u, M_LONG_LONG_REAL, STRONG, SAFE_DEFLEXING)) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_REAL, M_LONG_LONG_REAL); + if (z != NO_TAG) + return z; + } + if (a68_is_coercible_series (u, M_COMPLEX, STRONG, SAFE_DEFLEXING)) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, M_COMPLEX); + if (z != NO_TAG) + return z; + } + if (a68_is_coercible_series (u, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, M_LONG_COMPLEX); + if (z != NO_TAG) + return z; + } + if (a68_is_coercible_series (u, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING)) + { + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX); + if (z != NO_TAG) + return z; + } + /* (C.4) Now allow for depreffing for REF REAL +:= INT and alike. */ + v = a68_get_balanced_mode (u, STRONG, A68_DEPREF, SAFE_DEFLEXING); + z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v); + if (z != NO_TAG) + return z; + return NO_TAG; +} + +/* Mode check monadic operator. */ + +static void +mode_check_monadic_operator (NODE_T *p, SOID_T *x, SOID_T *y) +{ + if (p != NO_NODE) + { + TAG_T *t; + MOID_T *u = a68_determine_unique_mode (y, SAFE_DEFLEXING); + if (a68_is_mode_isnt_well (u)) + a68_make_soid (y, SORT (x), M_ERROR, 0); + else if (u == M_HIP) + { + a68_error (NEXT (p), "M construct is an invalid operand", u); + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + else + { + if (strchr (NOMADS, *(NSYMBOL (p))) != NO_TEXT) + { + t = NO_TAG; + a68_error (p, "monadic S cannot start with a character from Z", NOMADS); + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + else + { + t = find_operator (TABLE (p), NSYMBOL (p), u, NO_MOID); + if (t == NO_TAG) + { + a68_error (p, "monadic operator S O has not been declared", u); + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + } + if (t != NO_TAG) + MOID (p) = MOID (t); + TAX (p) = t; + if (t != NO_TAG && t != A68_PARSER (error_tag)) + { + MOID (p) = MOID (t); + a68_make_soid (y, SORT (x), SUB_MOID (t), 0); + } + else + { + MOID (p) = M_ERROR; + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + } + } +} + +/* Mode check monadic formula. */ + +static void +mode_check_monadic_formula (NODE_T *p, SOID_T *x, SOID_T *y) +{ + SOID_T e; + a68_make_soid (&e, FIRM, NO_MOID, 0); + mode_check_formula (NEXT (p), &e, y); + mode_check_monadic_operator (p, &e, y); + a68_make_soid (y, SORT (x), MOID (y), 0); +} + +/* Mode check formula. */ + +static void +mode_check_formula (NODE_T *p, SOID_T *x, SOID_T *y) +{ + SOID_T ls; + if (IS (p, MONADIC_FORMULA)) + mode_check_monadic_formula (SUB (p), x, &ls); + else if (IS (p, FORMULA)) + mode_check_formula (SUB (p), x, &ls); + else if (IS (p, SECONDARY)) + { + SOID_T e; + a68_make_soid (&e, FIRM, NO_MOID, 0); + mode_check_unit (SUB (p), &e, &ls); + } + MOID_T *u = a68_determine_unique_mode (&ls, SAFE_DEFLEXING); + MOID (p) = u; + SOID_T rs; + if (NEXT (p) == NO_NODE) + a68_make_soid (y, SORT (x), u, 0); + else + { + NODE_T *q = NEXT_NEXT (p); + if (IS (q, MONADIC_FORMULA)) + mode_check_monadic_formula (SUB (NEXT_NEXT (p)), x, &rs); + else if (IS (q, FORMULA)) + mode_check_formula (SUB (NEXT_NEXT (p)), x, &rs); + else if (IS (q, SECONDARY)) + { + SOID_T e; + a68_make_soid (&e, FIRM, NO_MOID, 0); + mode_check_unit (SUB (q), &e, &rs); + } + MOID_T *v = a68_determine_unique_mode (&rs, SAFE_DEFLEXING); + MOID (q) = v; + if (a68_is_mode_isnt_well (u) || a68_is_mode_isnt_well (v)) + a68_make_soid (y, SORT (x), M_ERROR, 0); + else if (u == M_HIP) + { + a68_error (p, "M construct is an invalid operand", u); + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + else if (v == M_HIP) + { + a68_error (q, "M construct is an invalid operand", u); + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + else + { + TAG_T *op = find_operator (TABLE (NEXT (p)), NSYMBOL (NEXT (p)), u, v); + if (op == NO_TAG) + { + a68_error (NEXT (p), "dyadic operator O S O has not been declared", u, v); + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + if (op != NO_TAG) + MOID (NEXT (p)) = MOID (op); + TAX (NEXT (p)) = op; + if (op != NO_TAG && op != A68_PARSER (error_tag)) + a68_make_soid (y, SORT (x), SUB_MOID (op), 0); + else + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + } +} + +/* Mode check assignation. */ + +static void +mode_check_assignation (NODE_T *p, SOID_T *x, SOID_T *y) +{ + /* Get destination mode. */ + SOID_T name, tmp, value; + a68_make_soid (&name, SOFT, NO_MOID, 0); + mode_check_unit (SUB (p), &name, &tmp); + /* SOFT coercion. */ + MOID_T *ori = a68_determine_unique_mode (&tmp, SAFE_DEFLEXING); + MOID_T *name_moid = a68_deproc_completely (ori); + if (ATTRIBUTE (name_moid) != REF_SYMBOL) + { + if (A68_IF_MODE_IS_WELL (name_moid)) + a68_error (p, "M A does not yield a name", ori, ATTRIBUTE (SUB (p))); + a68_make_soid (y, SORT (x), M_ERROR, 0); + return; + } + MOID (p) = name_moid; + /* Get source mode. */ + a68_make_soid (&name, STRONG, SUB (name_moid), 0); + mode_check_unit (NEXT_NEXT (p), &name, &value); + if (!a68_is_coercible_in_context (&value, &name, FORCE_DEFLEXING)) + { + a68_cannot_coerce (p, MOID (&value), MOID (&name), STRONG, FORCE_DEFLEXING, UNIT); + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + else + a68_make_soid (y, SORT (x), name_moid, 0); +} + +/* Mode check identity relation. */ + +static void +mode_check_identity_relation (NODE_T *p, SOID_T *x, SOID_T *y) +{ + NODE_T *ln = p, *rn = NEXT_NEXT (p); + SOID_T e, l, r; + a68_make_soid (&e, SOFT, NO_MOID, 0); + mode_check_unit (SUB (ln), &e, &l); + mode_check_unit (SUB (rn), &e, &r); + /* SOFT coercion. */ + MOID_T *oril = a68_determine_unique_mode (&l, SAFE_DEFLEXING); + MOID_T *orir = a68_determine_unique_mode (&r, SAFE_DEFLEXING); + MOID_T *lhs = a68_deproc_completely (oril); + MOID_T *rhs = a68_deproc_completely (orir); + if (A68_IF_MODE_IS_WELL (lhs) && lhs != M_HIP && ATTRIBUTE (lhs) != REF_SYMBOL) + { + a68_error (ln, "M A does not yield a name", oril, ATTRIBUTE (SUB (ln))); + lhs = M_ERROR; + } + if (A68_IF_MODE_IS_WELL (rhs) && rhs != M_HIP && ATTRIBUTE (rhs) != REF_SYMBOL) + { + a68_error (rn, "M A does not yield a name", orir, ATTRIBUTE (SUB (rn))); + rhs = M_ERROR; + } + if (lhs == M_HIP && rhs == M_HIP) + a68_error (p, "construct has no unique mode"); + + if (a68_is_coercible (lhs, rhs, STRONG, SAFE_DEFLEXING)) + lhs = rhs; + else if (a68_is_coercible (rhs, lhs, STRONG, SAFE_DEFLEXING)) + rhs = lhs; + else + { + a68_cannot_coerce (NEXT (p), rhs, lhs, SOFT, SKIP_DEFLEXING, TERTIARY); + lhs = rhs = M_ERROR; + } + MOID (ln) = lhs; + MOID (rn) = rhs; + a68_make_soid (y, SORT (x), M_BOOL, 0); +} + +/* Mode check bool functions ANDF and ORF. */ + +static void +mode_check_bool_function (NODE_T *p, SOID_T *x, SOID_T *y) +{ + SOID_T e, l, r; + NODE_T *ln = p, *rn = NEXT_NEXT (p); + a68_make_soid (&e, STRONG, M_BOOL, 0); + mode_check_unit (SUB (ln), &e, &l); + if (!a68_is_coercible_in_context (&l, &e, SAFE_DEFLEXING)) + a68_cannot_coerce (ln, MOID (&l), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY); + mode_check_unit (SUB (rn), &e, &r); + if (!a68_is_coercible_in_context (&r, &e, SAFE_DEFLEXING)) + a68_cannot_coerce (rn, MOID (&r), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY); + MOID (ln) = M_BOOL; + MOID (rn) = M_BOOL; + a68_make_soid (y, SORT (x), M_BOOL, 0); +} + +/* Mode check cast. */ + +static void +mode_check_cast (NODE_T *p, SOID_T *x, SOID_T *y) +{ + SOID_T w; + mode_check_declarer (p); + a68_make_soid (&w, STRONG, MOID (p), 0); + CAST (&w) = true; + mode_check_enclosed (SUB_NEXT (p), &w, y); + if (!a68_is_coercible_in_context (y, &w, SAFE_DEFLEXING)) + a68_cannot_coerce (NEXT (p), MOID (y), MOID (&w), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); + a68_make_soid (y, SORT (x), MOID (p), 0); +} + +/* Mode check assertion. */ + +static void +mode_check_assertion (NODE_T *p) +{ + SOID_T w, y; + a68_make_soid (&w, STRONG, M_BOOL, 0); + mode_check_enclosed (SUB_NEXT (p), &w, &y); + SORT (&y) = SORT (&w); + if (!a68_is_coercible_in_context (&y, &w, NO_DEFLEXING)) + a68_cannot_coerce (NEXT (p), MOID (&y), MOID (&w), MEEK, NO_DEFLEXING, ENCLOSED_CLAUSE); +} + +/* Mode check argument list. */ + +static void +mode_check_argument_list (SOID_T **r, NODE_T *p, PACK_T **x, PACK_T **v, PACK_T **w) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, GENERIC_ARGUMENT_LIST)) + ATTRIBUTE (p) = ARGUMENT_LIST; + + if (IS (p, ARGUMENT_LIST)) + mode_check_argument_list (r, SUB (p), x, v, w); + else if (IS (p, UNIT)) + { + SOID_T y, z; + if (*x != NO_PACK) + { + a68_make_soid (&z, STRONG, MOID (*x), 0); + a68_add_mode_to_pack_end (v, MOID (*x), NO_TEXT, p); + FORWARD (*x); + } + else + a68_make_soid (&z, STRONG, NO_MOID, 0); + mode_check_unit (p, &z, &y); + a68_add_to_soid_list (r, p, &y); + } + else if (IS (p, TRIMMER)) + { + SOID_T z; + if (SUB (p) != NO_NODE) + { + a68_error (p, "syntax error detected in A", ARGUMENT); + a68_make_soid (&z, STRONG, M_ERROR, 0); + a68_add_mode_to_pack_end (v, M_VOID, NO_TEXT, p); + a68_add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p); + FORWARD (*x); + } + else if (*x != NO_PACK) + { + a68_make_soid (&z, STRONG, MOID (*x), 0); + a68_add_mode_to_pack_end (v, M_VOID, NO_TEXT, p); + a68_add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p); + FORWARD (*x); + } + else + a68_make_soid (&z, STRONG, NO_MOID, 0); + a68_add_to_soid_list (r, p, &z); + } + else if (IS (p, SUB_SYMBOL) && !OPTION_BRACKETS (&A68_JOB)) + a68_error (p, "syntax error detected in A", CALL); + } +} + +/* Mode check argument list 2. */ + +static void +mode_check_argument_list_2 (NODE_T *p, PACK_T *x, SOID_T *y, PACK_T **v, PACK_T **w) +{ + SOID_T *top_sl = NO_SOID; + mode_check_argument_list (&top_sl, SUB (p), &x, v, w); + a68_make_soid (y, STRONG, a68_pack_soids_in_moid (top_sl, STOWED_MODE), 0); + a68_free_soid_list (top_sl); +} + +/* Mode check meek int. */ + +static void +mode_check_meek_int (NODE_T *p) +{ + SOID_T x, y; + a68_make_soid (&x, MEEK, M_INT, 0); + mode_check_unit (p, &x, &y); + if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) + a68_cannot_coerce (p, MOID (&y), MOID (&x), MEEK, SAFE_DEFLEXING, 0); +} + +/* Mode check trimmer. */ + +static void +mode_check_trimmer (NODE_T *p) +{ + if (p == NO_NODE) + return; + else if (IS (p, TRIMMER)) + mode_check_trimmer (SUB (p)); + else if (IS (p, UNIT)) + { + mode_check_meek_int (p); + mode_check_trimmer (NEXT (p)); + } + else + mode_check_trimmer (NEXT (p)); +} + +/* Mode check indexer. */ + +static void +mode_check_indexer (NODE_T *p, int *subs, int *trims) +{ + if (p == NO_NODE) + return; + else if (IS (p, TRIMMER)) + { + (*trims)++; + mode_check_trimmer (SUB (p)); + } + else if (IS (p, UNIT)) + { + (*subs)++; + mode_check_meek_int (p); + } + else + { + mode_check_indexer (SUB (p), subs, trims); + mode_check_indexer (NEXT (p), subs, trims); + } +} + +/* Mode check call. */ + +static void +mode_check_call (NODE_T *p, MOID_T *n, SOID_T *x, SOID_T *y) +{ + MOID (p) = n; + /* "partial_locale" is the mode of the locale. */ + PARTIAL_LOCALE (GINFO (p)) = a68_new_moid (); + ATTRIBUTE (PARTIAL_LOCALE (GINFO (p))) = PROC_SYMBOL; + PACK (PARTIAL_LOCALE (GINFO (p))) = NO_PACK; + SUB (PARTIAL_LOCALE (GINFO (p))) = SUB (n); + /* "partial_proc" is the mode of the resulting proc. */ + PARTIAL_PROC (GINFO (p)) = a68_new_moid (); + ATTRIBUTE (PARTIAL_PROC (GINFO (p))) = PROC_SYMBOL; + PACK (PARTIAL_PROC (GINFO (p))) = NO_PACK; + SUB (PARTIAL_PROC (GINFO (p))) = SUB (n); + /* Check arguments and construct modes. */ + SOID_T d; + mode_check_argument_list_2 (NEXT (p), PACK (n), &d, &PACK (PARTIAL_LOCALE (GINFO (p))), + &PACK (PARTIAL_PROC (GINFO (p)))); + DIM (PARTIAL_PROC (GINFO (p))) = a68_count_pack_members (PACK (PARTIAL_PROC (GINFO (p)))); + DIM (PARTIAL_LOCALE (GINFO (p))) = a68_count_pack_members (PACK (PARTIAL_LOCALE (GINFO (p)))); + PARTIAL_PROC (GINFO (p)) = a68_register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_PROC (GINFO (p))); + PARTIAL_LOCALE (GINFO (p)) = a68_register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_LOCALE (GINFO (p))); + if (DIM (MOID (&d)) != DIM (n)) + { + a68_error (p, "incorrect number of arguments for M", n); + a68_make_soid (y, SORT (x), SUB (n), 0); + /* a68_make_soid (y, SORT (x), M_ERROR, 0);. */ + } + else + { + if (!a68_is_coercible (MOID (&d), n, STRONG, ALIAS_DEFLEXING)) + a68_cannot_coerce (p, MOID (&d), n, STRONG, ALIAS_DEFLEXING, ARGUMENT); + if (DIM (PARTIAL_PROC (GINFO (p))) == 0) + a68_make_soid (y, SORT (x), SUB (n), 0); + else + { + a68_warning (NEXT (p), OPT_Wextensions, "@ is an extension"); + a68_make_soid (y, SORT (x), PARTIAL_PROC (GINFO (p)), 0); + } + } +} + +/* Mode check slice. */ + +static void +mode_check_slice (NODE_T *p, MOID_T *ori, SOID_T *x, SOID_T *y) +{ + MOID_T *m = a68_depref_completely (ori), *n = ori; + /* WEAK coercion. */ + while ((IS_REF (n) && !a68_is_ref_row (n)) || (IS (n, PROC_SYMBOL) && PACK (n) == NO_PACK)) + n = a68_depref_once (n); + + if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || a68_is_ref_row (n))) + { + if (A68_IF_MODE_IS_WELL (n)) + a68_error (p, "M A does not yield a row or procedure", + n, ATTRIBUTE (SUB (p))); + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + + MOID (p) = n; + int dim = 0, subs = 0, trims = 0; + mode_check_indexer (SUB_NEXT (p), &subs, &trims); + bool is_ref; + if ((is_ref = a68_is_ref_row (n)) != 0) + dim = DIM (DEFLEX (SUB (n))); + else + dim = DIM (DEFLEX (n)); + + if ((subs + trims) != dim) + { + a68_error (p, "incorrect number of indexers for M", n); + a68_make_soid (y, SORT (x), M_ERROR, 0); + } + else + { + if (subs > 0 && trims == 0) + { + ANNOTATION (NEXT (p)) = SLICE; + m = n; + } + else + { + ANNOTATION (NEXT (p)) = TRIMMER; + m = n; + } + while (subs > 0) + { + if (is_ref) + m = NAME (m); + else + { + if (IS_FLEX (m)) + m = SUB (m); + m = SLICE (m); + } + gcc_assert (m != NO_MOID); + subs--; + } + /* A trim cannot be but deflexed. */ + if (ANNOTATION (NEXT (p)) == TRIMMER && TRIM (m) != NO_MOID) + { + gcc_assert (TRIM (m) != NO_MOID); + a68_make_soid (y, SORT (x), TRIM (m), 0); + } + else + a68_make_soid (y, SORT (x), m, 0); + } +} + +/* Mode check specification. */ + +static enum a68_attribute +mode_check_specification (NODE_T *p, SOID_T *x, SOID_T *y) +{ + SOID_T w, d; + a68_make_soid (&w, WEAK, NO_MOID, 0); + mode_check_unit (SUB (p), &w, &d); + MOID_T *ori = a68_determine_unique_mode (&d, SAFE_DEFLEXING); + MOID_T *m = a68_depref_completely (ori); + if (IS (m, PROC_SYMBOL)) + { + /* Assume CALL. */ + mode_check_call (p, m, x, y); + return CALL; + } + else if (IS_ROW (m) || IS_FLEX (m)) + { + /* Assume SLICE. */ + mode_check_slice (p, ori, x, y); + return SLICE; + } + else + { + if (m != M_ERROR) + a68_error (p, "M construct must yield a routine or a row value", m); + a68_make_soid (y, SORT (x), M_ERROR, 0); + return PRIMARY; + } +} + +/* Mode check selection. */ + +static void +mode_check_selection (NODE_T *p, SOID_T *x, SOID_T *y) +{ + bool deflex = false; + NODE_T *secondary = SUB_NEXT (p); + SOID_T w, d; + a68_make_soid (&w, WEAK, NO_MOID, 0); + mode_check_unit (secondary, &w, &d); + MOID_T *n, *ori; + n = ori = a68_determine_unique_mode (&d, SAFE_DEFLEXING); + PACK_T *t = NO_PACK, *t_2 = NO_PACK; + bool coerce = true; + while (coerce) + { + if (IS (n, STRUCT_SYMBOL)) + { + coerce = false; + t = PACK (n); + } + else if (IS_REF (n) && (IS_ROW (SUB (n)) || IS_FLEX (SUB (n))) && MULTIPLE (n) != NO_MOID) + { + coerce = false; + deflex = true; + t = PACK (MULTIPLE (n)); + } + else if ((IS_ROW (n) || IS_FLEX (n)) && MULTIPLE (n) != NO_MOID) + { + coerce = false; + deflex = true; + t = PACK (MULTIPLE (n)); + } + else if (IS_REF (n) && a68_is_name_struct (n)) + { + coerce = false; + t = PACK (NAME (n)); + } + else if (a68_is_deprefable (n)) + { + coerce = true; + n = SUB (n); + t = NO_PACK; + } + else + { + coerce = false; + t = NO_PACK; + } + } + if (t == NO_PACK) + { + if (A68_IF_MODE_IS_WELL (MOID (&d))) + a68_error (secondary, "M A does not yield a structured value", ori, ATTRIBUTE (secondary)); + a68_make_soid (y, SORT (x), M_ERROR, 0); + return; + } + + MOID (NEXT (p)) = n; + const char *fs = NSYMBOL (SUB (p)); + MOID_T *str = n; + while (IS_REF (str)) + str = SUB (str); + if (IS_FLEX (str)) + str = SUB (str); + if (IS_ROW (str)) + str = SUB (str); + t_2 = PACK (str); + while (t != NO_PACK && t_2 != NO_PACK) + { + if (TEXT (t) == fs || strcmp (TEXT (t), fs) == 0) + { + MOID_T *ret = MOID (t); + if (deflex && TRIM (ret) != NO_MOID) + ret = TRIM (ret); + a68_make_soid (y, SORT (x), ret, 0); + MOID (p) = ret; + NODE_PACK (SUB (p)) = t_2; + return; + } + FORWARD (t); + FORWARD (t_2); + } + a68_make_soid (&d, NO_SORT, n, 0); + a68_error (p, "M has no field Z", str, fs); + a68_make_soid (y, SORT (x), M_ERROR, 0); +} + +/* Mode check format text. */ + +static void +mode_check_format_text (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + mode_check_format_text (SUB (p)); + if (IS (p, FORMAT_PATTERN)) + { + SOID_T x, y; + a68_make_soid (&x, STRONG, M_FORMAT, 0); + mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y); + if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) + a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); + } + else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) + { + SOID_T x, y; + a68_make_soid (&x, STRONG, M_ROW_INT, 0); + mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y); + if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) + a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); + } + else if (IS (p, DYNAMIC_REPLICATOR)) + { + SOID_T x, y; + a68_make_soid (&x, STRONG, M_INT, 0); + mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y); + if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) + a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); + } + } +} + +/* Mode check unit. */ + +static void +mode_check_unit (NODE_T *p, SOID_T *x, SOID_T *y) +{ + if (p == NO_NODE) + return; + else if (a68_is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) + mode_check_unit (SUB (p), x, y); + /* Ex primary. */ + else if (IS (p, SPECIFICATION)) + { + ATTRIBUTE (p) = mode_check_specification (SUB (p), x, y); + a68_warn_for_voiding (p, x, y, ATTRIBUTE (p)); + } + else if (IS (p, CAST)) + { + mode_check_cast (SUB (p), x, y); + a68_warn_for_voiding (p, x, y, CAST); + } + else if (IS (p, DENOTATION)) + { + a68_make_soid (y, SORT (x), MOID (SUB (p)), 0); + a68_warn_for_voiding (p, x, y, DENOTATION); + } + else if (IS (p, IDENTIFIER)) + { + if ((TAX (p) == NO_TAG) && (MOID (p) == NO_MOID)) + { + int att = a68_first_tag_global (TABLE (p), NSYMBOL (p)); + if (att == STOP) + { + (void) a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER); + a68_error (p, "tag S has not been declared properly"); + MOID (p) = M_ERROR; + } + else + { + TAG_T *z = a68_find_tag_global (TABLE (p), att, NSYMBOL (p)); + if (att == IDENTIFIER && z != NO_TAG) + MOID (p) = MOID (z); + else + { + (void) a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER); + a68_error (p, "tag S has not been declared properly"); + MOID (p) = M_ERROR; + } + } + } + a68_make_soid (y, SORT (x), MOID (p), 0); + a68_warn_for_voiding (p, x, y, IDENTIFIER); + } + else if (IS (p, ENCLOSED_CLAUSE)) + mode_check_enclosed (SUB (p), x, y); + else if (IS (p, FORMAT_TEXT)) + { + mode_check_format_text (p); + a68_make_soid (y, SORT (x), M_FORMAT, 0); + a68_warn_for_voiding (p, x, y, FORMAT_TEXT); + /* Ex secondary. */ + } + else if (IS (p, GENERATOR)) + { + mode_check_declarer (SUB (p)); + a68_make_soid (y, SORT (x), MOID (SUB (p)), 0); + a68_warn_for_voiding (p, x, y, GENERATOR); + } + else if (IS (p, SELECTION)) + { + mode_check_selection (SUB (p), x, y); + a68_warn_for_voiding (p, x, y, SELECTION); + /* Ex tertiary. */ + } + else if (IS (p, NIHIL)) + a68_make_soid (y, STRONG, M_HIP, 0); + else if (IS (p, FORMULA)) + { + mode_check_formula (p, x, y); + if (!IS_REF (MOID (y))) + a68_warn_for_voiding (p, x, y, FORMULA); + } + else if (a68_is_one_of (p, JUMP, SKIP, STOP)) + { + if (SORT (x) != STRONG) + a68_warning (p, 0, "@ should not be in C context", SORT (x)); + /* a68_make_soid (y, STRONG, M_HIP, 0); */ + a68_make_soid (y, SORT (x), M_HIP, 0); + } + else if (IS (p, ASSIGNATION)) + mode_check_assignation (SUB (p), x, y); + else if (IS (p, IDENTITY_RELATION)) + { + mode_check_identity_relation (SUB (p), x, y); + a68_warn_for_voiding (p, x, y, IDENTITY_RELATION); + } + else if (IS (p, ROUTINE_TEXT)) + { + mode_check_routine_text (SUB (p), y); + a68_make_soid (y, SORT (x), MOID (p), 0); + a68_warn_for_voiding (p, x, y, ROUTINE_TEXT); + } + else if (IS (p, ASSERTION)) + { + mode_check_assertion (SUB (p)); + a68_make_soid (y, STRONG, M_VOID, 0); + } + else if (IS (p, AND_FUNCTION)) + { + mode_check_bool_function (SUB (p), x, y); + a68_warn_for_voiding (p, x, y, AND_FUNCTION); + } + else if (IS (p, OR_FUNCTION)) + { + mode_check_bool_function (SUB (p), x, y); + a68_warn_for_voiding (p, x, y, OR_FUNCTION); + } + + MOID (p) = MOID (y); +} + +/* Mode check a module text. */ + +static void +mode_check_module_text (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, DEF_PART) || IS (p, POSTLUDE_PART)) + { + /* XXX unde def is an enquiry clause */ + SOID_T *z = NO_SOID; + SOID_T ix; + a68_make_soid (&ix, STRONG, M_VOID, 0); + mode_check_serial (&z, NEXT_SUB (p), &ix, true); + a68_free_soid_list (z); + } + } +} + +/* Mode check a module declaration. */ + +static void +mode_check_module_declaration (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, MODULE_TEXT)) + mode_check_module_text (SUB (p)); + else + mode_check_module_declaration (SUB (p)); + } +} diff --git a/gcc/algol68/a68-parser-moids-coerce.cc b/gcc/algol68/a68-parser-moids-coerce.cc new file mode 100644 index 000000000000..3e127c909f14 --- /dev/null +++ b/gcc/algol68/a68-parser-moids-coerce.cc @@ -0,0 +1,925 @@ +/* Mode coercion driver. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" + +#include "a68.h" + +#define A68_INSERT_COERCIONS(n, p, q) a68_make_strong ((n), (p), MOID (q)) + +/* A few forward references of functions defined below. */ + +static void coerce_unit (NODE_T *p, SOID_T *q); +static void coerce_formula (NODE_T *p, SOID_T *q __attribute__ ((unused))); +static void coerce_operand (NODE_T *p, SOID_T *q); +static void coerce_enclosed (NODE_T *p, SOID_T *q); + +/* Coerce bounds. */ + +static void +coerce_bounds (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + { + SOID_T q; + a68_make_soid (&q, MEEK, M_INT, 0); + coerce_unit (p, &q); + } + else + coerce_bounds (SUB (p)); + } +} + +/* Coerce declarer. */ + +static void +coerce_declarer (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, BOUNDS)) + coerce_bounds (SUB (p)); + else + coerce_declarer (SUB (p)); + } +} + +/* Coerce identity declaration. */ + +static void +coerce_identity_declaration (NODE_T *p) +{ + if (p != NO_NODE) + { + switch (ATTRIBUTE (p)) + { + case DECLARER: + coerce_declarer (SUB (p)); + coerce_identity_declaration (NEXT (p)); + break; + case DEFINING_IDENTIFIER: + { + SOID_T q; + a68_make_soid (&q, STRONG, MOID (p), 0); + coerce_unit (NEXT_NEXT (p), &q); + break; + } + default: + coerce_identity_declaration (SUB (p)); + coerce_identity_declaration (NEXT (p)); + break; + } + } +} + +/* Coerce variable declaration. */ + +static void +coerce_variable_declaration (NODE_T *p) +{ + if (p != NO_NODE) + { + switch (ATTRIBUTE (p)) + { + case DECLARER: + coerce_declarer (SUB (p)); + coerce_variable_declaration (NEXT (p)); + break; + case DEFINING_IDENTIFIER: + if (a68_whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) + { + SOID_T q; + a68_make_soid (&q, STRONG, SUB_MOID (p), 0); + coerce_unit (NEXT_NEXT (p), &q); + break; + } + /* Fallthrough. */ + default: + coerce_variable_declaration (SUB (p)); + coerce_variable_declaration (NEXT (p)); + break; + } + } +} + +/* Coerce routine text. */ + +static void +coerce_routine_text (NODE_T *p) +{ + if (IS (p, PARAMETER_PACK)) + FORWARD (p); + SOID_T w; + a68_make_soid (&w, STRONG, MOID (p), 0); + coerce_unit (NEXT_NEXT (p), &w); +} + +/* Coerce proc declaration. */ + +static void +coerce_proc_declaration (NODE_T *p) +{ + if (p == NO_NODE) + return; + else if (IS (p, ROUTINE_TEXT)) + coerce_routine_text (SUB (p)); + else + { + coerce_proc_declaration (SUB (p)); + coerce_proc_declaration (NEXT (p)); + } +} + +/* Coerce_op_declaration. */ + +static void +coerce_op_declaration (NODE_T *p) +{ + if (p == NO_NODE) + return; + else if (IS (p, DEFINING_OPERATOR)) + { + SOID_T q; + a68_make_soid (&q, STRONG, MOID (p), 0); + coerce_unit (NEXT_NEXT (p), &q); + } + else + { + coerce_op_declaration (SUB (p)); + coerce_op_declaration (NEXT (p)); + } +} + +/* Coerce brief op declaration. */ + +static void +coerce_brief_op_declaration (NODE_T *p) +{ + if (p == NO_NODE) + return; + else if (IS (p, DEFINING_OPERATOR)) + coerce_routine_text (SUB (NEXT_NEXT (p))); + else + { + coerce_brief_op_declaration (SUB (p)); + coerce_brief_op_declaration (NEXT (p)); + } +} + +/* Coerce declaration list. */ + +static void +coerce_declaration_list (NODE_T *p) +{ + if (p != NO_NODE) + { + switch (ATTRIBUTE (p)) + { + case IDENTITY_DECLARATION: + coerce_identity_declaration (SUB (p)); + break; + case VARIABLE_DECLARATION: + coerce_variable_declaration (SUB (p)); + break; + case MODE_DECLARATION: + coerce_declarer (SUB (p)); + break; + case PROCEDURE_DECLARATION: + case PROCEDURE_VARIABLE_DECLARATION: + coerce_proc_declaration (SUB (p)); + break; + case BRIEF_OPERATOR_DECLARATION: + coerce_brief_op_declaration (SUB (p)); + break; + case OPERATOR_DECLARATION: + coerce_op_declaration (SUB (p)); + break; + default: + coerce_declaration_list (SUB (p)); + coerce_declaration_list (NEXT (p)); + break; + } + } +} + +/* Coerce serial. */ + +static void +coerce_serial (NODE_T *p, SOID_T *q, bool k) +{ + if (p == NO_NODE) + return; + else if (IS (p, INITIALISER_SERIES)) + { + coerce_serial (SUB (p), q, false); + coerce_serial (NEXT (p), q, k); + } + else if (IS (p, DECLARATION_LIST)) + coerce_declaration_list (SUB (p)); + else if (a68_is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) + coerce_serial (NEXT (p), q, k); + else if (a68_is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) + { + NODE_T *z = NEXT (p); + if (z != NO_NODE) + { + if (IS (z, EXIT_SYMBOL) || IS (z, END_SYMBOL) || IS (z, CLOSE_SYMBOL)) + coerce_serial (SUB (p), q, true); + else + coerce_serial (SUB (p), q, false); + } + else + coerce_serial (SUB (p), q, true); + coerce_serial (NEXT (p), q, k); + } + else if (IS (p, LABELED_UNIT)) + coerce_serial (SUB (p), q, k); + else if (IS (p, UNIT)) + { + if (k) + coerce_unit (p, q); + else + { + SOID_T strongvoid; + a68_make_soid (&strongvoid, STRONG, M_VOID, 0); + coerce_unit (p, &strongvoid); + } + } +} + +/* Coerce closed. */ + +static void +coerce_closed (NODE_T *p, SOID_T *q) +{ + if (IS (p, SERIAL_CLAUSE)) + coerce_serial (p, q, true); + else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) + coerce_closed (NEXT (p), q); +} + +/* Coerce access clause. */ + +static void +coerce_access (NODE_T *p, SOID_T *q) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, ENCLOSED_CLAUSE)) + coerce_enclosed (p, q); + } +} + +/* Coerce conditional. */ + +static void +coerce_conditional (NODE_T *p, SOID_T *q) +{ + SOID_T w; + a68_make_soid (&w, MEEK, M_BOOL, 0); + coerce_serial (NEXT_SUB (p), &w, true); + FORWARD (p); + coerce_serial (NEXT_SUB (p), q, true); + if ((FORWARD (p)) != NO_NODE) + { + if (a68_is_one_of (p, ELSE_PART, CHOICE, STOP)) + coerce_serial (NEXT_SUB (p), q, true); + else if (a68_is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) + coerce_conditional (SUB (p), q); + } +} + +/* Coerce unit list. */ + +static void +coerce_unit_list (NODE_T *p, SOID_T *q) +{ + if (p == NO_NODE) + return; + else if (IS (p, UNIT_LIST)) + { + coerce_unit_list (SUB (p), q); + coerce_unit_list (NEXT (p), q); + } + else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP)) + coerce_unit_list (NEXT (p), q); + else if (IS (p, UNIT)) + { + coerce_unit (p, q); + coerce_unit_list (NEXT (p), q); + } +} + +/* Coerce int case. */ + +static void +coerce_int_case (NODE_T *p, SOID_T *q) +{ + SOID_T w; + a68_make_soid (&w, MEEK, M_INT, 0); + coerce_serial (NEXT_SUB (p), &w, true); + FORWARD (p); + coerce_unit_list (NEXT_SUB (p), q); + if ((FORWARD (p)) != NO_NODE) + { + if (a68_is_one_of (p, OUT_PART, CHOICE, STOP)) + coerce_serial (NEXT_SUB (p), q, true); + else if (a68_is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) + coerce_int_case (SUB (p), q); + } +} + +/* Coerce spec unit list. */ + +static void +coerce_spec_unit_list (NODE_T *p, SOID_T *q) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (a68_is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP)) + coerce_spec_unit_list (SUB (p), q); + else if (IS (p, UNIT)) + coerce_unit (p, q); + } +} + +/* Coerce united case. */ + +static void +coerce_united_case (NODE_T *p, SOID_T *q) +{ + SOID_T w; + a68_make_soid (&w, MEEK, MOID (SUB (p)), 0); + coerce_serial (NEXT_SUB (p), &w, true); + FORWARD (p); + coerce_spec_unit_list (NEXT_SUB (p), q); + if ((FORWARD (p)) != NO_NODE) + { + if (a68_is_one_of (p, OUT_PART, CHOICE, STOP)) + coerce_serial (NEXT_SUB (p), q, true); + else if (a68_is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) + coerce_united_case (SUB (p), q); + } +} + +/* Coerce loop. */ + +static void +coerce_loop (NODE_T *p) +{ + if (IS (p, FOR_PART)) + coerce_loop (NEXT (p)); + else if (a68_is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) + { + SOID_T w; + a68_make_soid (&w, MEEK, M_INT, 0); + coerce_unit (NEXT_SUB (p), &w); + coerce_loop (NEXT (p)); + } + else if (IS (p, WHILE_PART)) + { + SOID_T w; + a68_make_soid (&w, MEEK, M_BOOL, 0); + coerce_serial (NEXT_SUB (p), &w, true); + coerce_loop (NEXT (p)); + } + else if (a68_is_one_of (p, DO_PART, ALT_DO_PART, STOP)) + { + SOID_T w; + NODE_T *do_p = NEXT_SUB (p); + a68_make_soid (&w, STRONG, M_VOID, 0); + coerce_serial (do_p, &w, true); + } +} + +/* Coerce struct display. */ + +static void +coerce_struct_display (PACK_T **r, NODE_T *p) +{ + if (p == NO_NODE) + return; + else if (IS (p, UNIT_LIST)) + { + coerce_struct_display (r, SUB (p)); + coerce_struct_display (r, NEXT (p)); + } + else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP)) + coerce_struct_display (r, NEXT (p)); + else if (IS (p, UNIT)) + { + SOID_T s; + a68_make_soid (&s, STRONG, MOID (*r), 0); + coerce_unit (p, &s); + FORWARD (*r); + coerce_struct_display (r, NEXT (p)); + } +} + +/* Coerce collateral. */ + +static void +coerce_collateral (NODE_T *p, SOID_T *q) +{ + if (!(a68_whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) + || a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))) + { + if (IS (MOID (q), STRUCT_SYMBOL)) + { + PACK_T *t = PACK (MOID (q)); + coerce_struct_display (&t, p); + } + else if (IS_FLEX (MOID (q))) + { + SOID_T w; + a68_make_soid (&w, STRONG, SLICE (SUB_MOID (q)), 0); + coerce_unit_list (p, &w); + } + else if (IS_ROW (MOID (q))) + { + SOID_T w; + a68_make_soid (&w, STRONG, SLICE (MOID (q)), 0); + coerce_unit_list (p, &w); + } + else + { + /* if (MOID (q) != M_VOID). */ + coerce_unit_list (p, q); + } + } +} + +/* Coerce_enclosed. */ + +static void +coerce_enclosed (NODE_T *p, SOID_T *q) +{ + if (IS (p, ENCLOSED_CLAUSE)) + coerce_enclosed (SUB (p), q); + else if (IS (p, CLOSED_CLAUSE)) + coerce_closed (SUB (p), q); + else if (IS (p, COLLATERAL_CLAUSE)) + coerce_collateral (SUB (p), q); + else if (IS (p, ACCESS_CLAUSE)) + coerce_access (SUB (p), q); + else if (IS (p, PARALLEL_CLAUSE)) + coerce_collateral (SUB (NEXT_SUB (p)), q); + else if (IS (p, CONDITIONAL_CLAUSE)) + coerce_conditional (SUB (p), q); + else if (IS (p, CASE_CLAUSE)) + coerce_int_case (SUB (p), q); + else if (IS (p, CONFORMITY_CLAUSE)) + coerce_united_case (SUB (p), q); + else if (IS (p, LOOP_CLAUSE)) + coerce_loop (SUB (p)); + + MOID (p) = a68_depref_rows (MOID (p), MOID (q)); +} + +/* Get monad moid. */ + +static MOID_T * +get_monad_moid (NODE_T *p) +{ + if (TAX (p) != NO_TAG && TAX (p) != A68_PARSER (error_tag)) + { + MOID (p) = MOID (TAX (p)); + return MOID (PACK (MOID (p))); + } + else + return M_ERROR; +} + +/* Coerce monad oper. */ + +static void +coerce_monad_oper (NODE_T *p, SOID_T *q) +{ + if (p != NO_NODE) + { + SOID_T z; + a68_make_soid (&z, FIRM, MOID (PACK (MOID (TAX (p)))), 0); + A68_INSERT_COERCIONS (NEXT (p), MOID (q), &z); + } +} + +/* Coerce monad formula. */ + +static void +coerce_monad_formula (NODE_T *p) +{ + SOID_T e; + a68_make_soid (&e, STRONG, get_monad_moid (p), 0); + coerce_operand (NEXT (p), &e); + coerce_monad_oper (p, &e); +} + +/* Coerce operand. */ + +static void +coerce_operand (NODE_T *p, SOID_T *q) +{ + if (IS (p, MONADIC_FORMULA)) + { + coerce_monad_formula (SUB (p)); + if (MOID (p) != MOID (q)) + { + a68_make_sub (p, p, FORMULA); + A68_INSERT_COERCIONS (p, MOID (p), q); + a68_make_sub (p, p, TERTIARY); + } + MOID (p) = a68_depref_rows (MOID (p), MOID (q)); + } + else if (IS (p, FORMULA)) + { + coerce_formula (SUB (p), q); + A68_INSERT_COERCIONS (p, MOID (p), q); + MOID (p) = a68_depref_rows (MOID (p), MOID (q)); + } + else if (IS (p, SECONDARY)) + { + coerce_unit (SUB (p), q); + MOID (p) = MOID (SUB (p)); + } +} + +/* Coerce formula. */ + +static void +coerce_formula (NODE_T *p, SOID_T *q __attribute__ ((unused))) +{ + if (IS (p, MONADIC_FORMULA) && NEXT (p) == NO_NODE) + coerce_monad_formula (SUB (p)); + else + { + if (TAX (NEXT (p)) != NO_TAG && TAX (NEXT (p)) != A68_PARSER (error_tag)) + { + SOID_T s; + NODE_T *op = NEXT (p), *nq = NEXT_NEXT (p); + MOID_T *w = MOID (op); + MOID_T *u = MOID (PACK (w)), *v = MOID (NEXT (PACK (w))); + a68_make_soid (&s, STRONG, u, 0); + coerce_operand (p, &s); + a68_make_soid (&s, STRONG, v, 0); + coerce_operand (nq, &s); + } + } +} + +/* Coerce assignation. */ + +static void +coerce_assignation (NODE_T *p) +{ + SOID_T w; + a68_make_soid (&w, SOFT, MOID (p), 0); + coerce_unit (SUB (p), &w); + a68_make_soid (&w, STRONG, SUB_MOID (p), 0); + coerce_unit (NEXT_NEXT (p), &w); +} + +/* Coerce relation. */ + +static void +coerce_relation (NODE_T *p) +{ + SOID_T w; + a68_make_soid (&w, STRONG, MOID (p), 0); + coerce_unit (SUB (p), &w); + a68_make_soid (&w, STRONG, MOID (NEXT_NEXT (p)), 0); + coerce_unit (SUB (NEXT_NEXT (p)), &w); +} + +/* Coerce bool function. */ + +static void +coerce_bool_function (NODE_T *p) +{ + SOID_T w; + a68_make_soid (&w, STRONG, M_BOOL, 0); + coerce_unit (SUB (p), &w); + coerce_unit (SUB (NEXT_NEXT (p)), &w); +} + +/* Coerce assertion. */ + +static void +coerce_assertion (NODE_T *p) +{ + SOID_T w; + a68_make_soid (&w, MEEK, M_BOOL, 0); + coerce_enclosed (SUB_NEXT (p), &w); +} + +/* Coerce selection. */ + +static void +coerce_selection (NODE_T * p) +{ + SOID_T w; + a68_make_soid (&w, STRONG, MOID (NEXT (p)), 0); + coerce_unit (SUB_NEXT (p), &w); +} + +/* Coerce cast. */ + +static void +coerce_cast (NODE_T * p) +{ + coerce_declarer (p); + SOID_T w; + a68_make_soid (&w, STRONG, MOID (p), 0); + coerce_enclosed (NEXT (p), &w); +} + +/* Coerce argument list. */ + +static void +coerce_argument_list (PACK_T **r, NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, ARGUMENT_LIST)) + coerce_argument_list (r, SUB (p)); + else if (IS (p, UNIT)) + { + SOID_T s; + a68_make_soid (&s, STRONG, MOID (*r), 0); + coerce_unit (p, &s); + FORWARD (*r); + } + else if (IS (p, TRIMMER)) + FORWARD (*r); + } +} + +/* Coerce call. */ + +static void +coerce_call (NODE_T *p) +{ + MOID_T *proc = MOID (p); + SOID_T w; + a68_make_soid (&w, MEEK, proc, 0); + coerce_unit (SUB (p), &w); + FORWARD (p); + PACK_T *t = PACK (proc); + coerce_argument_list (&t, SUB (p)); +} + +/* Coerce meek int. */ + +static void +coerce_meek_int (NODE_T *p) +{ + SOID_T x; + a68_make_soid (&x, MEEK, M_INT, 0); + coerce_unit (p, &x); +} + +/* Coerce trimmer. */ + +static void +coerce_trimmer (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, UNIT)) + { + coerce_meek_int (p); + coerce_trimmer (NEXT (p)); + } + else + coerce_trimmer (NEXT (p)); + } +} + +/* Coerce indexer. */ + +static void +coerce_indexer (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, TRIMMER)) + coerce_trimmer (SUB (p)); + else if (IS (p, UNIT)) + coerce_meek_int (p); + else + { + coerce_indexer (SUB (p)); + coerce_indexer (NEXT (p)); + } + } +} + +/* Coerce_slice. */ + +static void +coerce_slice (NODE_T *p) +{ + SOID_T w; + MOID_T *row = MOID (p); + a68_make_soid (&w, STRONG, row, 0); + coerce_unit (SUB (p), &w); + coerce_indexer (SUB_NEXT (p)); +} + +/* Coerce format text. */ + +static void +coerce_format_text (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + coerce_format_text (SUB (p)); + if (IS (p, FORMAT_PATTERN)) + { + SOID_T x; + a68_make_soid (&x, STRONG, M_FORMAT, 0); + coerce_enclosed (SUB (NEXT_SUB (p)), &x); + } + else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) + { + SOID_T x; + a68_make_soid (&x, STRONG, M_ROW_INT, 0); + coerce_enclosed (SUB (NEXT_SUB (p)), &x); + } + else if (IS (p, DYNAMIC_REPLICATOR)) + { + SOID_T x; + a68_make_soid (&x, STRONG, M_INT, 0); + coerce_enclosed (SUB (NEXT_SUB (p)), &x); + } + } +} + +/* Coerce unit. */ + +static void +coerce_unit (NODE_T *p, SOID_T *q) +{ + if (p == NO_NODE) + return; + else if (a68_is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) + { + coerce_unit (SUB (p), q); + MOID (p) = MOID (SUB (p)); + /* Ex primary. */ + } + else if (IS (p, CALL)) + { + coerce_call (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + } + else if (IS (p, SLICE)) + { + coerce_slice (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + } + else if (IS (p, CAST)) + { + coerce_cast (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + } + else if (a68_is_one_of (p, DENOTATION, IDENTIFIER, STOP)) + A68_INSERT_COERCIONS (p, MOID (p), q); + else if (IS (p, FORMAT_TEXT)) + { + coerce_format_text (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + } + else if (IS (p, ENCLOSED_CLAUSE)) + { + coerce_enclosed (p, q); + /* Ex secondary. */ + } + else if (IS (p, SELECTION)) + { + coerce_selection (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + } + else if (IS (p, GENERATOR)) + { + coerce_declarer (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + /* Ex tertiary. */ + } + else if (IS (p, NIHIL)) + { + if (ATTRIBUTE (MOID (q)) != REF_SYMBOL && MOID (q) != M_VOID) + a68_error (p, "context does not require a name"); + MOID (p) = a68_depref_rows (MOID (p), MOID (q)); + } + else if (IS (p, FORMULA)) + { + coerce_formula (SUB (p), q); + A68_INSERT_COERCIONS (p, MOID (p), q); + } + else if (IS (p, JUMP)) + { + if (MOID (q) == M_PROC_VOID) + a68_make_sub (p, p, PROCEDURING); + MOID (p) = a68_depref_rows (MOID (p), MOID (q)); + } + else if (IS (p, SKIP)) + MOID (p) = a68_depref_rows (MOID (p), MOID (q)); + else if (IS (p, ASSIGNATION)) + { + coerce_assignation (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + MOID (p) = a68_depref_rows (MOID (p), MOID (q)); + } + else if (IS (p, IDENTITY_RELATION)) + { + coerce_relation (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + } + else if (IS (p, ROUTINE_TEXT)) + { + coerce_routine_text (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + } + else if (a68_is_one_of (p, AND_FUNCTION, OR_FUNCTION, STOP)) + { + coerce_bool_function (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + } + else if (IS (p, ASSERTION)) + { + coerce_assertion (SUB (p)); + A68_INSERT_COERCIONS (p, MOID (p), q); + } +} + +/* Coerce module text. */ + +static void +coerce_module_text (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, DEF_PART) || IS (p, POSTLUDE_PART)) + { + SOID_T w; + a68_make_soid (&w, STRONG, M_VOID, 0); + coerce_serial (NEXT_SUB (p), &w, true); + } + } +} + +/* Coerce module declaration. */ + +static void +coerce_module_declaration (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, MODULE_TEXT)) + coerce_module_text (SUB (p)); + else + coerce_module_declaration (SUB (p)); + } +} + +/* Driver for coercion insertions. */ + +void +a68_coercion_inserter (NODE_T *p) +{ + if (IS (p, PACKET)) + { + p = SUB (p); + if (IS (p, PARTICULAR_PROGRAM)) + { + SOID_T q; + a68_make_soid (&q, STRONG, M_VOID, 0); + coerce_enclosed (SUB (p), &q); + } + else if (IS (p, PRELUDE_PACKET)) + coerce_module_declaration (SUB (p)); + } +} diff --git a/gcc/algol68/a68-parser-moids-equivalence.cc b/gcc/algol68/a68-parser-moids-equivalence.cc new file mode 100644 index 000000000000..c022f9cb6732 --- /dev/null +++ b/gcc/algol68/a68-parser-moids-equivalence.cc @@ -0,0 +1,183 @@ +/* Prove equivalence of modes. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +/* Routines for establishing equivalence of modes. + After I made this mode equivalencer (in 1993), I found: + + Algol Bulletin 30.3.3 C.H.A. Koster: On infinite modes, 86-89 [1969], + + which essentially concurs with this test on mode equivalence I wrote. + It is elementary logic anyway: prove equivalence, assuming equivalence. */ + +/* Forward declarations of some of the functions defined below. */ + +static bool are_modes_equivalent (MOID_T * a, MOID_T * b); + +/* Whether packs are equivalent, same sequence of equivalence modes. */ + +static bool +are_packs_equivalent (PACK_T *s, PACK_T *t, + bool compare_names = true) +{ + for (; s != NO_PACK && t != NO_PACK; s = s->next, t = t->next) + { + if (!are_modes_equivalent (MOID (s), MOID (t))) + return false; + if (compare_names) + { + if (TEXT (s) != TEXT (t) + && TEXT (s) != NO_TEXT + && TEXT (t) != NO_TEXT + && strcmp (TEXT (s), TEXT (t)) != 0) + return false; + } + } + + return s == NO_PACK && t == NO_PACK; +} + +/* Whether packs are subsets. */ + +static bool +is_united_subset (PACK_T *s, PACK_T *t) +{ + /* For all modes in 's' there must be an equivalent in 't'. */ + for (PACK_T *p = s; p != NO_PACK; p = p->next) + { + bool f = false; + for (PACK_T *q = t; q != NO_PACK && !f; q = q->next) + f = are_modes_equivalent (MOID (p), MOID (q)); + + if (!f) + return false; + } + + return true; +} + +/* Whether packs are subsets. */ + +static bool +are_united_packs_equivalent (PACK_T *s, PACK_T *t) +{ + return is_united_subset (s, t) && is_united_subset (t, s); +} + +/* Whether moids A and B are structurally equivalent. */ + +static bool +are_modes_equivalent (MOID_T * a, MOID_T * b) +{ + /* First lets try some cheap heuristics. */ + + if (a == NO_MOID || b == NO_MOID) + /* Modes can be NO_MOID in partial argument lists. */ + return false; + else if (a == M_ERROR || b == M_ERROR) + return false; + else if (a == b) + return true; + else if (ATTRIBUTE (a) != ATTRIBUTE (b)) + return false; + else if (DIM (a) != DIM (b)) + return false; + else if (IS (a, STANDARD)) + return (a == b); + else if (EQUIVALENT (a) == b || EQUIVALENT (b) == a) + return true; + else if (a68_is_postulated_pair (A68 (top_postulate), a, b) + || a68_is_postulated_pair (A68 (top_postulate), b, a)) + return true; + else if (IS (a, INDICANT)) + { + if (NODE (a) == NO_NODE || NODE (b) == NO_NODE) + return false; + else + return (NODE (a) == NODE (b) + || strcmp (NSYMBOL (NODE (a)), NSYMBOL (NODE (b))) == 0); + } + + /* Investigate structure. */ + + /* We now know that 'a' and 'b' have same attribute, dimension, ... */ + if (IS (a, REF_SYMBOL)) + /* REF MODE */ + return are_modes_equivalent (a->sub, b->sub); + else if (IS (a, ROW_SYMBOL)) + /* [] MODE */ + return are_modes_equivalent (a->sub, b->sub); + else if (IS (a, FLEX_SYMBOL)) + /* FLEX [...] MODE */ + return are_modes_equivalent (a->sub, b->sub); + else if (IS (a, STRUCT_SYMBOL)) + { + /* STRUCT (...) */ + POSTULATE_T *save = A68 (top_postulate); + a68_make_postulate (&A68 (top_postulate), a, b); + bool z = are_packs_equivalent (PACK (a), PACK (b)); + a68_free_postulate_list (A68 (top_postulate), save); + A68 (top_postulate) = save; + return z; + } + else if (IS (a, UNION_SYMBOL)) + /* UNION (...) */ + return are_united_packs_equivalent (PACK (a), PACK (b)); + else if (IS (a, PROC_SYMBOL) && PACK (a) == NO_PACK && PACK (b) == NO_PACK) + /* PROC MOID */ + return are_modes_equivalent (a->sub, b->sub); + else if (IS (a, PROC_SYMBOL) && PACK (a) != NO_PACK && PACK (b) != NO_PACK) + { + /* PROC (...) MOID */ + POSTULATE_T *save = A68 (top_postulate); + a68_make_postulate (&A68 (top_postulate), a, b); + bool z = are_modes_equivalent (a->sub, b->sub); + if (z) + z = are_packs_equivalent (PACK (a), PACK (b), + false /* compare_names */); + a68_free_postulate_list (A68 (top_postulate), save); + A68 (top_postulate) = save; + return z; + } + else if (IS (a, SERIES_MODE) || IS (a, STOWED_MODE)) + /* Modes occurring in displays. */ + return are_packs_equivalent (PACK (a), PACK (b)); + + return false; +} + +//! @brief Whether two modes are structurally equivalent. + +bool +a68_prove_moid_equivalence (MOID_T *p, MOID_T *q) +{ +// Prove two modes to be equivalent under assumption that they indeed are. + POSTULATE_T *save = A68 (top_postulate); + bool z = are_modes_equivalent (p, q); + a68_free_postulate_list (A68 (top_postulate), save); + A68 (top_postulate) = save; + return z; +} diff --git a/gcc/algol68/a68-parser-pragmat.cc b/gcc/algol68/a68-parser-pragmat.cc new file mode 100644 index 000000000000..2407eaa1b721 --- /dev/null +++ b/gcc/algol68/a68-parser-pragmat.cc @@ -0,0 +1,202 @@ +/* Handling of compiler pragmats. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +/* Utility macros useful for parsing pragmat contents. */ + +#define SKIP_WHITESPACES(P) \ + while (ISSPACE (*(P))) (P)++ + +#define PARSE_WORD(P,W) \ + do \ + { \ + (W) = (char *) alloca (strlen ((P))); \ + size_t i = 0; \ + while (ISALPHA (*(P))) \ + (W)[i++] = *((P)++); \ + (W)[i] = '\0'; \ + } while (0) + +/* Parse a string denotation and return its value in an allocated buffer in + *STR. It is up to the caller to dispose of the allocated memory. + + This function returns a pointer to the character following the string + denotation in P, or P in case of parse error. + + In case of parse error *STR is also set to NULL. */ + +const char * +parse_string_denotation (const char *p, char **str) +{ + const char *orig = p; + size_t i = 0; + char *s = (char *) xmalloc (2 * strlen (p)); + + if (*(p++) != '\"') + goto error; + while (*p != '\0' && *p != '\"') + { + if (*p == '\'' && *(p + 1) == '\"') + { + s[i++] = '\"'; + p += 2; + } + else + { + s[i++] = *p; + p++; + } + } + if (*p != '\"') + goto error; + + *str = s; + return p + 1; + error: + free (s); + *str = NULL; + return orig; +} + +/* PR access MODULE in "filename" PR */ + +const char * +handle_access_in_pragmat (NODE_T *p, const char *pragmat, size_t pos) +{ + const char *beginning = pragmat; + + SKIP_WHITESPACES (pragmat); + /* Parse module name. */ + char *module; + PARSE_WORD (pragmat, module); + if (*module == '\0') + { + a68_error (p, "invalid pragmat: expected module name after %"); + return NULL; + } + SKIP_WHITESPACES (pragmat); + /* Parse "in " */ + if (strncmp (pragmat, "in ", 3) != 0) + { + a68_error (p, "invalid pragmat: expected % after module name"); + return NULL; + } + pragmat += 3; + SKIP_WHITESPACES (pragmat); + /* Parse a string denotation. */ + char *filename; + pragmat = parse_string_denotation (pragmat, &filename); + if (filename == NULL) + { + size_t off = pos + pragmat - beginning; + char *found; + PARSE_WORD (pragmat, found); + a68_error_in_pragmat (p, off, + "in % pragmat, expected string, found Z", + found); + return NULL; + } + /* Add entry in the module files map. */ + const char **pmodule = A68_MODULE_FILES->get (module); + if (pmodule != NULL) + { + a68_error_in_pragmat (p, pos + pragmat - beginning, + "module Z cannot appear in multiple % pragmats", + module); + return NULL; + } + + SKIP_WHITESPACES (pragmat); + /* Skip closing PR or PRAGMAT. */ + if (NPRAGMAT_TYPE (p) == STYLE_I_PRAGMAT_SYMBOL) + pragmat += 2; + else + pragmat += 7; + + A68_MODULE_FILES->put (ggc_strdup (module), ggc_strdup (filename)); + free (filename); + return pragmat; +} + +/* Parse and action on a pragmat. */ + +void +handle_pragmat (NODE_T *p) +{ + const char *pragmat = NPRAGMAT (p); + if (pragmat != NULL + && (NPRAGMAT_TYPE (p) == STYLE_I_PRAGMAT_SYMBOL + || NPRAGMAT_TYPE (p) == BOLD_PRAGMAT_SYMBOL)) + { + /* Process pragmat commands. */ + do + { + SKIP_WHITESPACES (pragmat); + /* Skip PR or PRAGMAT. */ + if (NPRAGMAT_TYPE (p) == STYLE_I_PRAGMAT_SYMBOL) + pragmat += 2; + else + pragmat += 7; + SKIP_WHITESPACES (pragmat); + /* Get first word in pragmat and dispatch. */ + SKIP_WHITESPACES (pragmat); + char *word = (char *) alloca (strlen (pragmat)); + size_t i = 0; + while (ISALPHA (*pragmat) || *pragmat == '\n') + word[i++] = *(pragmat++); + word[i] = '\0'; + + if (strcmp (word, "access") == 0) + { + pragmat + = handle_access_in_pragmat (p, pragmat, pragmat - NPRAGMAT (p)); + if (pragmat == NULL) + break; + } + else if (strcmp (word, "include") == 0) + /* Include pragmats are handled in the scanner. */ + return; + else + { + a68_error_in_pragmat (p, pragmat - NPRAGMAT (p), + "unrecognized pragmat Z", word); + break; + } + } + while (*pragmat != '\0'); + } +} + +/* Entry point: handle all pragmats in the given parse tree. */ + +void +a68_handle_pragmats (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + a68_handle_pragmats (SUB (p)); + handle_pragmat (p); + } +} diff --git a/gcc/algol68/a68-parser-prelude.cc b/gcc/algol68/a68-parser-prelude.cc new file mode 100644 index 000000000000..cb899873f357 --- /dev/null +++ b/gcc/algol68/a68-parser-prelude.cc @@ -0,0 +1,1502 @@ +/* Standard prelude definitions. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +#define A68_STD true +#define A68_EXT false + +/* ALGOL68C type procs. */ + +#define A68C_DEFIO(name, mode) \ + do \ + { \ + m = a68_proc (MODE (mode), M_REF_FILE, NO_MOID); \ + a68_idf (A68_EXT, "get" #name, m); \ + m = a68_proc (M_VOID, M_REF_FILE, MODE (mode), NO_MOID); \ + a68_idf (A68_EXT, "put" #name, m); \ + m = a68_proc (MODE (mode), NO_MOID); \ + a68_idf (A68_EXT, "read" #name, m); \ + m = a68_proc (M_VOID, MODE (mode), NO_MOID); \ + a68_idf (A68_EXT, "print" #name, m); \ + } \ + while (0) + +/* Enter tag in standenv symbol table. */ + +static void +add_a68_standenv (bool portable, int a, NODE_T* n, char *c, MOID_T *m, + int p, LOWERER_T l = NO_LOWERER) +{ +#define INSERT_TAG(l, n) \ + do { \ + NEXT (n) = *(l); \ + *(l) = (n); \ + } while (0) + + TAG_T *new_one = a68_new_tag (); + + PROCEDURE_LEVEL (INFO (n)) = 0; + USE (new_one) = false; + HEAP (new_one) = HEAP_SYMBOL; + TAG_TABLE (new_one) = A68_STANDENV; + NODE (new_one) = n; + if (c != NO_TEXT) + VALUE (new_one) = TEXT (a68_add_token (&A68 (top_token), c)); + else + VALUE (new_one) = NO_TEXT; + PRIO (new_one) = p; + TAX_TREE_DECL (new_one) = NULL; + LOWERER (new_one) = l; + UNIT (new_one) = NULL; + PORTABLE (new_one) = portable; + MOID (new_one) = m; + NEXT (new_one) = NO_TAG; + if (a == IDENTIFIER) + INSERT_TAG (&IDENTIFIERS (A68_STANDENV), new_one); + else if (a == OP_SYMBOL) + INSERT_TAG (&OPERATORS (A68_STANDENV), new_one); + else if (a == PRIO_SYMBOL) + INSERT_TAG (&PRIO (A68_STANDENV), new_one); + else if (a == INDICANT) + INSERT_TAG (&INDICANTS (A68_STANDENV), new_one); + else if (a == LABEL) + INSERT_TAG (&LABELS (A68_STANDENV), new_one); +#undef INSERT_TAG +} + +/* Compose PROC moid from arguments - first result, than arguments. */ + +static MOID_T * +a68_proc (MOID_T *m, ...) +{ + PACK_T *p = NO_PACK, *q = NO_PACK; + MOID_T *y; + + va_list attribute; + va_start (attribute, m); + while ((y = va_arg (attribute, MOID_T *)) != NO_MOID) + { + PACK_T *new_one = a68_new_pack (); + + MOID (new_one) = y; + TEXT (new_one) = NO_TEXT; + NEXT (new_one) = NO_PACK; + if (q != NO_PACK) + NEXT (q) = new_one; + else + p = new_one; + q = new_one; + } + + va_end (attribute); + return a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, + a68_count_pack_members (p), NO_NODE, m, p); +} + +/* Enter an identifier in standenv. */ + +static void +a68_idf (bool portable, const char *n, MOID_T *m, LOWERER_T l = NO_LOWERER) +{ + add_a68_standenv (portable, IDENTIFIER, + a68_some_node (TEXT (a68_add_token (&A68 (top_token), n))), + NO_TEXT, m, 0, l); +} + +/* Enter a moid in standenv. */ + +static void +a68_mode (int p, const char *t, MOID_T **m) +{ + (*m) = a68_add_mode (&TOP_MOID (&A68_JOB), + STANDARD, p, + a68_some_node (TEXT (a68_find_keyword (A68 (top_keyword), t))), + NO_MOID, NO_PACK); +} + +/* Enter a priority in standenv. */ + +static void +a68_prio (const char *p, int b) +{ + add_a68_standenv (true, PRIO_SYMBOL, + a68_some_node (TEXT (a68_add_token (&A68 (top_token), p))), + NO_TEXT, NO_MOID, b, NO_LOWERER); +} + +/* Enter operator in standenv. */ + +static void +a68_op (bool portable, const char *n, MOID_T *m, LOWERER_T l = NO_LOWERER) +{ + add_a68_standenv (portable, OP_SYMBOL, + a68_some_node (TEXT (a68_add_token (&A68 (top_token), n))), + NO_TEXT, m, 0, l); +} + +/* Enter standard modes in standenv. */ + +static void +stand_moids (void) +{ + /* Primitive A68 moids. */ + a68_mode (0, "VOID", &M_VOID); + /* Standard precision. */ + a68_mode (0, "INT", &M_INT); + a68_mode (0, "REAL", &M_REAL); + a68_mode (0, "COMPL", &M_COMPLEX); + a68_mode (0, "BITS", &M_BITS); + a68_mode (0, "BYTES", &M_BYTES); + /* Multiple precision. */ + a68_mode (-2, "INT", &M_SHORT_SHORT_INT); + a68_mode (-2, "BITS", &M_SHORT_SHORT_BITS); + a68_mode (-1, "INT", &M_SHORT_INT); + a68_mode (-1, "BITS", &M_SHORT_BITS); + a68_mode (1, "INT", &M_LONG_INT); + a68_mode (1, "REAL", &M_LONG_REAL); + a68_mode (1, "COMPL", &M_LONG_COMPLEX); + a68_mode (1, "BITS", &M_LONG_BITS); + a68_mode (1, "BYTES", &M_LONG_BYTES); + a68_mode (2, "REAL", &M_LONG_LONG_REAL); + a68_mode (2, "INT", &M_LONG_LONG_INT); + a68_mode (2, "BITS", &M_LONG_LONG_BITS); + a68_mode (2, "COMPL", &M_LONG_LONG_COMPLEX); + /* Other. */ + a68_mode (0, "BOOL", &M_BOOL); + a68_mode (0, "CHAR", &M_CHAR); + a68_mode (0, "STRING", &M_STRING); + a68_mode (0, "FILE", &M_FILE); + a68_mode (0, "CHANNEL", &M_CHANNEL); + a68_mode (0, "SEMA", &M_SEMA); + /* Rows. */ + M_ROWS = a68_add_mode (&TOP_MOID (&A68_JOB), ROWS_SYMBOL, 0, NO_NODE, NO_MOID, NO_PACK); + /* REFs. */ + M_REF_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_INT, NO_PACK); + M_REF_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_REAL, NO_PACK); + M_REF_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_COMPLEX, NO_PACK); + M_REF_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_BITS, NO_PACK); + M_REF_BYTES = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_BYTES, NO_PACK); + /* Multiple precision. */ + M_REF_LONG_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_INT, NO_PACK); + M_REF_LONG_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_REAL, NO_PACK); + M_REF_LONG_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_COMPLEX, NO_PACK); + M_REF_LONG_LONG_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_INT, NO_PACK); + M_REF_LONG_LONG_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_REAL, NO_PACK); + M_REF_LONG_LONG_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_COMPLEX, NO_PACK); + M_REF_LONG_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_BITS, NO_PACK); + M_REF_LONG_LONG_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_BITS, NO_PACK); + M_REF_LONG_BYTES = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_BYTES, NO_PACK); + M_REF_SHORT_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_SHORT_INT, NO_PACK); + M_REF_SHORT_SHORT_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_SHORT_SHORT_INT, NO_PACK +); + M_REF_SHORT_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_SHORT_BITS, NO_PACK); + M_REF_SHORT_SHORT_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_SHORT_SHORT_BITS, NO_PACK); + /* Other. */ + M_REF_BOOL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_BOOL, NO_PACK); + M_REF_CHAR = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_CHAR, NO_PACK); + M_REF_FILE = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_FILE, NO_PACK); + M_REF_REF_FILE = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_REF_FILE, NO_PACK); + /* [] INT. */ + M_ROW_INT = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_INT, NO_PACK); + HAS_ROWS (M_ROW_INT) = true; + SLICE (M_ROW_INT) = M_INT; + M_REF_ROW_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_INT, NO_PACK); + NAME (M_REF_ROW_INT) = M_REF_INT; + /* [] REAL. */ + M_ROW_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_REAL, NO_PACK); + HAS_ROWS (M_ROW_REAL) = true; + SLICE (M_ROW_REAL) = M_REAL; + M_REF_ROW_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_REAL, NO_PACK); + NAME (M_REF_ROW_REAL) = M_REF_REAL; + /* [,] REAL. */ + M_ROW_ROW_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 2, NO_NODE, M_REAL, NO_PACK); + HAS_ROWS (M_ROW_ROW_REAL) = true; + SLICE (M_ROW_ROW_REAL) = M_ROW_REAL; + M_REF_ROW_ROW_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_ROW_REAL, NO_PACK); + NAME (M_REF_ROW_ROW_REAL) = M_REF_ROW_REAL; + /* [] COMPLEX. */ + M_ROW_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_COMPLEX, NO_PACK); + HAS_ROWS (M_ROW_COMPLEX) = true; + SLICE (M_ROW_COMPLEX) = M_COMPLEX; + M_REF_ROW_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_COMPLEX, NO_PACK); + NAME (M_REF_ROW_COMPLEX) = M_REF_COMPLEX; + /* [,] COMPLEX. */ + M_ROW_ROW_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 2, NO_NODE, M_COMPLEX, NO_PACK); + HAS_ROWS (M_ROW_ROW_COMPLEX) = true; + SLICE (M_ROW_ROW_COMPLEX) = M_ROW_COMPLEX; + M_REF_ROW_ROW_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_ROW_COMPLEX, NO_PACK); + NAME (M_REF_ROW_ROW_COMPLEX) = M_REF_ROW_COMPLEX; + /* [] BOOL. */ + M_ROW_BOOL = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_BOOL, NO_PACK); + HAS_ROWS (M_ROW_BOOL) = true; + SLICE (M_ROW_BOOL) = M_BOOL; + /* FLEX [] BOOL. */ + MOID_T *m = a68_add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, NO_NODE, M_ROW_BOOL, NO_PACK); + HAS_ROWS (m) = true; + M_FLEX_ROW_BOOL = m; + /* [] BITS. */ + M_ROW_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_BITS, NO_PACK); + HAS_ROWS (M_ROW_BITS) = true; + SLICE (M_ROW_BITS) = M_BITS; + /* [] CHAR. */ + M_ROW_CHAR = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_CHAR, NO_PACK); + HAS_ROWS (M_ROW_CHAR) = true; + SLICE (M_ROW_CHAR) = M_CHAR; + /* [][] CHAR. */ + M_ROW_ROW_CHAR = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_ROW_CHAR, NO_PACK); + HAS_ROWS (M_ROW_ROW_CHAR) = true; + SLICE (M_ROW_ROW_CHAR) = M_ROW_CHAR; + /* MODE STRING = FLEX [] CHAR. */ + m = a68_add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, NO_NODE, M_ROW_CHAR, NO_PACK); + HAS_ROWS (m) = true; + M_FLEX_ROW_CHAR = m; + EQUIVALENT (M_STRING) = m; + /* REF [] CHAR. */ + M_REF_ROW_CHAR = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_CHAR, NO_PACK); + NAME (M_REF_ROW_CHAR) = M_REF_CHAR; + /* PROC [] CHAR. */ + M_PROC_ROW_CHAR = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, 0, NO_NODE, M_ROW_CHAR, NO_PACK); + /* REF STRING = REF FLEX [] CHAR. */ + M_REF_STRING = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, EQUIVALENT (M_STRING), NO_PACK); + NAME (M_REF_STRING) = M_REF_CHAR; + DEFLEXED (M_REF_STRING) = M_REF_ROW_CHAR; + /* [] STRING. */ + M_ROW_STRING = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_STRING, NO_PACK); + HAS_ROWS (M_ROW_STRING) = true; + SLICE (M_ROW_STRING) = M_STRING; + DEFLEXED (M_ROW_STRING) = M_ROW_ROW_CHAR; + /* PROC STRING. */ + M_PROC_STRING = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, 0, NO_NODE, M_STRING, NO_PACK); + DEFLEXED (M_PROC_STRING) = M_PROC_ROW_CHAR; + /* COMPLEX. */ + PACK_T *z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE); + (void) a68_add_mode_to_pack (&z, M_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE); + m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z); + EQUIVALENT (M_COMPLEX) = m; + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_REF_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE); + (void) a68_add_mode_to_pack (&z, M_REF_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE); + m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z); + NAME (M_REF_COMPLEX) = m; + /* LONG COMPLEX. */ + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE); + (void) a68_add_mode_to_pack (&z, M_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE); + m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z); + EQUIVALENT (M_LONG_COMPLEX) = m; + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_REF_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE); + (void) a68_add_mode_to_pack (&z, M_REF_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE); + m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z); + NAME (M_REF_LONG_COMPLEX) = m; + /* LONG_LONG COMPLEX. */ + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_LONG_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE); + (void) a68_add_mode_to_pack (&z, M_LONG_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE); + m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z); + EQUIVALENT (M_LONG_LONG_COMPLEX) = m; + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_REF_LONG_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE); + (void) a68_add_mode_to_pack (&z, M_REF_LONG_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE); + m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z); + NAME (M_REF_LONG_LONG_COMPLEX) = m; + /* SEMA. */ + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_REF_INT, NO_TEXT, NO_NODE); + EQUIVALENT (M_SEMA) = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z); + /* PROC VOID. */ + z = NO_PACK; + M_PROC_VOID = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (z), NO_NODE, M_VOID, z); + /* PROC (REAL) REAL. */ + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_REAL, NO_TEXT, NO_NODE); + M_PROC_REAL_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (z), NO_NODE, M_REAL, z); + /* PROC (LONG_REAL) LONG_REAL. */ + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_LONG_REAL, NO_TEXT, NO_NODE); + M_PROC_LONG_REAL_LONG_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (z), NO_NODE, M_LONG_REAL, z); + /* IO: PROC (REF FILE) BOOL. */ + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_REF_FILE, NO_TEXT, NO_NODE); + M_PROC_REF_FILE_BOOL = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (z), NO_NODE, M_BOOL, z); + /* IO: PROC (REF FILE) VOID. */ + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_REF_FILE, NO_TEXT, NO_NODE); + M_PROC_REF_FILE_VOID = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (z), NO_NODE, M_VOID, z); + /* IO: SIMPLIN and SIMPLOUT. */ + M_SIMPLIN = a68_add_mode (&TOP_MOID (&A68_JOB), IN_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK); + M_ROW_SIMPLIN = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_SIMPLIN, NO_PACK); + SLICE (M_ROW_SIMPLIN) = M_SIMPLIN; + M_SIMPLOUT = a68_add_mode (&TOP_MOID (&A68_JOB), OUT_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK); + M_ROW_SIMPLOUT = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_SIMPLOUT, NO_PACK); + SLICE (M_ROW_SIMPLOUT) = M_SIMPLOUT; +} + +/* Set up standenv - general RR but not transput. */ + +static void +stand_prelude (void) +{ + /* Identifiers. */ + a68_idf (A68_STD, "intlengths", M_INT, a68_lower_intlengths); + a68_idf (A68_STD, "intshorths", M_INT, a68_lower_intshorths); + a68_idf (A68_STD, "maxint", M_INT, a68_lower_maxint); + a68_idf (A68_STD, "longmaxint", M_LONG_INT, a68_lower_maxint); + a68_idf (A68_STD, "longlongmaxint", M_LONG_LONG_INT, a68_lower_maxint); + a68_idf (A68_STD, "shortmaxint", M_SHORT_INT, a68_lower_maxint); + a68_idf (A68_STD, "shortshortmaxint", M_SHORT_SHORT_INT, a68_lower_maxint); + a68_idf (A68_STD, "maxreal", M_REAL, a68_lower_maxreal); + a68_idf (A68_STD, "longmaxreal", M_LONG_REAL, a68_lower_maxreal); + a68_idf (A68_STD, "longlongmaxreal", M_LONG_LONG_REAL, a68_lower_maxreal); + a68_idf (A68_STD, "smallreal", M_REAL, a68_lower_smallreal); + a68_idf (A68_STD, "longsmallreal", M_LONG_REAL, a68_lower_smallreal); + a68_idf (A68_STD, "longlongsmallreal", M_LONG_LONG_REAL, a68_lower_smallreal); + a68_idf (A68_STD, "reallengths", M_INT, a68_lower_reallengths); + a68_idf (A68_STD, "realshorths", M_INT, a68_lower_realshorths); + a68_idf (A68_STD, "bitslengths", M_INT, a68_lower_bitslengths); + a68_idf (A68_STD, "bitsshorths", M_INT, a68_lower_bitsshorths); + a68_idf (A68_STD, "bitswidth", M_INT, a68_lower_bitswidth); + a68_idf (A68_STD, "longbitswidth", M_INT, a68_lower_longbitswidth); + a68_idf (A68_STD, "longlongbitswidth", M_INT, a68_lower_longlongbitswidth); + a68_idf (A68_STD, "shortbitswidth", M_INT, a68_lower_shortbitswidth); + a68_idf (A68_STD, "shortshortbitswidth", M_INT, a68_lower_shortshortbitswidth); + a68_idf (A68_STD, "maxbits", M_BITS, a68_lower_maxbits); + a68_idf (A68_STD, "longmaxbits", M_LONG_BITS, a68_lower_maxbits); + a68_idf (A68_STD, "longlongmaxbits", M_LONG_LONG_BITS, a68_lower_maxbits); + a68_idf (A68_STD, "maxabschar", M_INT, a68_lower_maxabschar); + a68_idf (A68_STD, "intwidth", M_INT, a68_lower_intwidth); + a68_idf (A68_STD, "longintwidth", M_INT, a68_lower_longintwidth); + a68_idf (A68_STD, "longlongintwidth", M_INT, a68_lower_longlongintwidth); + a68_idf (A68_STD, "shortintwidth", M_INT, a68_lower_shortintwidth); + a68_idf (A68_STD, "shortshortintwidth", M_INT, a68_lower_shortshortintwidth); + a68_idf (A68_STD, "realwidth", M_INT, a68_lower_realwidth); + a68_idf (A68_STD, "longrealwidth", M_INT, a68_lower_longrealwidth); + a68_idf (A68_STD, "longlongrealwidth", M_INT, a68_lower_longlongrealwidth); + a68_idf (A68_STD, "expwidth", M_INT, a68_lower_expwidth); + a68_idf (A68_STD, "longexpwidth", M_INT, a68_lower_longexpwidth); + a68_idf (A68_STD, "longlongexpwidth", M_INT, a68_lower_longlongexpwidth); + a68_idf (A68_STD, "pi", M_REAL, a68_lower_pi); + a68_idf (A68_STD, "longpi", M_LONG_REAL, a68_lower_pi); + a68_idf (A68_STD, "longlongpi", M_LONG_LONG_REAL, a68_lower_pi); + a68_idf (A68_STD, "compllengths", M_INT); + a68_idf (A68_STD, "complshorths", M_INT); + a68_idf (A68_STD, "byteslengths", M_INT); + a68_idf (A68_STD, "bytesshorths", M_INT); + a68_idf (A68_STD, "byteswidth", M_INT); + a68_idf (A68_STD, "longbyteswidth", M_INT); + a68_idf (A68_STD, "flip", M_CHAR, a68_lower_flip); + a68_idf (A68_STD, "flop", M_CHAR, a68_lower_flop); + a68_idf (A68_STD, "errorchar", M_CHAR, a68_lower_errorchar); + a68_idf (A68_STD, "nullcharacter", M_CHAR, a68_lower_nullcharacter); + a68_idf (A68_STD, "blank", M_CHAR, a68_lower_blank); + /* BITS procedures. */ + MOID_T *m = a68_proc (M_BITS, M_ROW_BOOL, NO_MOID); + a68_idf (A68_STD, "bitspack", m); + /* SHORT BITS procedures. */ + m = a68_proc (M_SHORT_BITS, M_ROW_BOOL, NO_MOID); + a68_idf (A68_STD, "shortbitspack", m); + /* SHORT SHORT BITS procedures. */ + m = a68_proc (M_SHORT_SHORT_BITS, M_ROW_BOOL, NO_MOID); + a68_idf (A68_STD, "shortshortbitspack", m); + /* LONG BITS procedures. */ + m = a68_proc (M_LONG_BITS, M_ROW_BOOL, NO_MOID); + a68_idf (A68_STD, "longbitspack", m); + /* LONG LONG BITS procedures. */ + m = a68_proc (M_LONG_LONG_BITS, M_ROW_BOOL, NO_MOID); + a68_idf (A68_STD, "longlongbitspack", m); + /* RNG procedures. */ + m = a68_proc (M_VOID, M_INT, NO_MOID); + a68_idf (A68_STD, "firstrandom", m); + /* REAL procedures. */ + m = A68_MCACHE (proc_real); + a68_idf (A68_STD, "nextrandom", m); + a68_idf (A68_STD, "random", m, a68_lower_random); + a68_idf (A68_STD, "rnd", m); + m = A68_MCACHE (proc_real_real); + a68_idf (A68_STD, "arccos", m, a68_lower_acos); + a68_idf (A68_STD, "arcsin", m, a68_lower_asin); + a68_idf (A68_STD, "arctan", m, a68_lower_atan); + a68_idf (A68_STD, "cos", m, a68_lower_cos); + a68_idf (A68_STD, "exp", m, a68_lower_exp); + a68_idf (A68_STD, "ln", m, a68_lower_ln); + a68_idf (A68_STD, "sin", m, a68_lower_sin); + a68_idf (A68_STD, "sqrt", m, a68_lower_sqrt); + a68_idf (A68_STD, "tan", m, a68_lower_tan); + /* LONG REAL procedures. */ + m = a68_proc (M_LONG_REAL, NO_MOID); + a68_idf (A68_STD, "longnextrandom", m); + a68_idf (A68_STD, "longrandom", m, a68_lower_longrandom); + m = a68_proc (M_LONG_REAL, M_LONG_REAL, NO_MOID); + a68_idf (A68_STD, "longarccos", m, a68_lower_long_acos); + a68_idf (A68_STD, "longarcsin", m, a68_lower_long_asin); + a68_idf (A68_STD, "longarctan", m, a68_lower_long_atan); + a68_idf (A68_STD, "longcos", m, a68_lower_long_cos); + a68_idf (A68_STD, "longexp", m, a68_lower_long_exp); + a68_idf (A68_STD, "longln", m, a68_lower_long_ln); + a68_idf (A68_STD, "longsin", m, a68_lower_long_sin); + a68_idf (A68_STD, "longsqrt", m, a68_lower_long_sqrt); + a68_idf (A68_STD, "longtan", m, a68_lower_long_tan); + /* LONG LONG REAL procedures. */ + m = a68_proc (M_LONG_LONG_REAL, NO_MOID); + a68_idf (A68_STD, "longlongnextrandom", m); + a68_idf (A68_STD, "longlongrandom", m, a68_lower_longlongrandom); + m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); + a68_idf (A68_STD, "longlongarccos", m, a68_lower_long_long_acos); + a68_idf (A68_STD, "longlongarcsin", m, a68_lower_long_long_asin); + a68_idf (A68_STD, "longlongarctan", m, a68_lower_long_long_atan); + a68_idf (A68_STD, "longlongcos", m, a68_lower_long_long_cos); + a68_idf (A68_STD, "longlongexp", m, a68_lower_long_long_exp); + a68_idf (A68_STD, "longlongln", m, a68_lower_long_long_ln); + a68_idf (A68_STD, "longlongsin", m, a68_lower_long_long_sin); + a68_idf (A68_STD, "longlongsqrt", m, a68_lower_long_long_sqrt); + a68_idf (A68_STD, "longlongtan", m, a68_lower_long_long_tan); + /* Priorities. */ + a68_prio ("+:=", 1); + a68_prio ("-:=", 1); + a68_prio ("*:=", 1); + a68_prio ("/:=", 1); + a68_prio ("%:=", 1); + a68_prio ("%*:=", 1); + a68_prio ("+=:", 1); + a68_prio ("PLUSAB", 1); + a68_prio ("MINUSAB", 1); + a68_prio ("TIMESAB", 1); + a68_prio ("DIVAB", 1); + a68_prio ("OVERAB", 1); + a68_prio ("MODAB", 1); + a68_prio ("PLUSTO", 1); + a68_prio ("OR", 2); + a68_prio ("AND", 3); + a68_prio ("XOR", 3); + a68_prio ("=", 4); + a68_prio ("/=", 4); + a68_prio ("<", 5); + a68_prio ("<=", 5); + a68_prio (">", 5); + a68_prio (">=", 5); + a68_prio ("EQ", 4); + a68_prio ("NE", 4); + a68_prio ("LT", 5); + a68_prio ("LE", 5); + a68_prio ("GT", 5); + a68_prio ("GE", 5); + a68_prio ("+", 6); + a68_prio ("-", 6); + a68_prio ("*", 7); + a68_prio ("/", 7); + a68_prio ("OVER", 7); + a68_prio ("%", 7); + a68_prio ("MOD", 7); + a68_prio ("%*", 7); + a68_prio ("ELEM", 7); + a68_prio ("**", 8); + a68_prio ("SHL", 8); + a68_prio ("SHR", 8); + a68_prio ("UP", 8); + a68_prio ("DOWN", 8); + a68_prio ("^", 8); + a68_prio ("LWB", 8); + a68_prio ("UPB", 8); + a68_prio ("I", 9); + a68_prio ("+*", 9); + /* BOOL operators. */ + m = a68_proc (M_BOOL, M_BOOL, NO_MOID); + a68_op (A68_STD, "NOT", m, a68_lower_not2); + a68_op (A68_STD, "~", m, a68_lower_not2); + m = a68_proc (M_INT, M_BOOL, NO_MOID); + a68_op (A68_STD, "ABS", m, a68_lower_boolabs2); + m = a68_proc (M_BOOL, M_BOOL, M_BOOL, NO_MOID); + a68_op (A68_STD, "OR", m, a68_lower_or3); + a68_op (A68_STD, "AND", m, a68_lower_and3); + a68_op (A68_STD, "=", m, a68_lower_bool_eq3); + a68_op (A68_STD, "/=", m, a68_lower_bool_ne3); + a68_op (A68_STD, "EQ", m, a68_lower_bool_eq3); + a68_op (A68_STD, "NE", m, a68_lower_bool_ne3); + /* CHAR operators. */ + m = a68_proc (M_BOOL, M_CHAR, M_CHAR, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_char_eq3); + a68_op (A68_STD, "/=", m, a68_lower_char_ne3); + a68_op (A68_STD, "<", m, a68_lower_char_lt3); + a68_op (A68_STD, "<=", m, a68_lower_char_le3); + a68_op (A68_STD, ">", m, a68_lower_char_gt3); + a68_op (A68_STD, ">=", m, a68_lower_char_ge3); + a68_op (A68_STD, "EQ", m, a68_lower_char_eq3); + a68_op (A68_STD, "NE", m, a68_lower_char_ne3); + a68_op (A68_STD, "LT", m, a68_lower_char_lt3); + a68_op (A68_STD, "LE", m, a68_lower_char_le3); + a68_op (A68_STD, "GT", m, a68_lower_char_gt3); + a68_op (A68_STD, "GE", m, a68_lower_char_ge3); + m = a68_proc (M_INT, M_CHAR, NO_MOID); + a68_op (A68_STD, "ABS", m, a68_lower_charabs2); + m = a68_proc (M_CHAR, M_INT, NO_MOID); + a68_op (A68_STD, "REPR", m, a68_lower_repr2); + /* STRING operators. */ + m = a68_proc (M_BOOL, M_STRING, M_STRING, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_string_eq3); + a68_op (A68_STD, "/=", m, a68_lower_string_ne3); + a68_op (A68_STD, "<", m, a68_lower_string_lt3); + a68_op (A68_STD, "<=", m, a68_lower_string_le3); + a68_op (A68_STD, ">=", m, a68_lower_string_ge3); + a68_op (A68_STD, ">", m, a68_lower_string_gt3); + a68_op (A68_STD, "EQ", m, a68_lower_string_eq3); + a68_op (A68_STD, "NE", m, a68_lower_string_ne3); + a68_op (A68_STD, "LT", m, a68_lower_string_lt3); + a68_op (A68_STD, "LE", m, a68_lower_string_le3); + a68_op (A68_STD, "GE", m, a68_lower_string_ge3); + a68_op (A68_STD, "GT", m, a68_lower_string_gt3); + m = a68_proc (M_STRING, M_CHAR, M_CHAR, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_char_plus3); + m = a68_proc (M_STRING, M_STRING, M_STRING, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_string_plus3); + m = a68_proc (M_REF_STRING, M_REF_STRING, M_STRING, NO_MOID); + a68_op (A68_STD, "+:=", m, a68_lower_string_plusab3); + a68_op (A68_STD, "PLUSAB", m, a68_lower_string_plusab3); + m = a68_proc (M_REF_STRING, M_REF_STRING, M_INT, NO_MOID); + a68_op (A68_STD, "*:=", m, a68_lower_string_multab3); + a68_op (A68_STD, "TIMESAB", m, a68_lower_string_multab3); + m = a68_proc (M_REF_STRING, M_STRING, M_REF_STRING, NO_MOID); + a68_op (A68_STD, "+=:", m, a68_lower_string_plusto3); + a68_op (A68_STD, "PLUSTO", m, a68_lower_string_plusto3); + m = a68_proc (M_STRING, M_STRING, M_INT, NO_MOID); + a68_op (A68_STD, "*", m, a68_lower_string_mult3); + m = a68_proc (M_STRING, M_INT, M_STRING, NO_MOID); + a68_op (A68_STD, "*", m, a68_lower_string_mult3); + m = a68_proc (M_STRING, M_INT, M_CHAR, NO_MOID); + a68_op (A68_STD, "*", m, a68_lower_char_mult3); + m = a68_proc (M_STRING, M_CHAR, M_INT, NO_MOID); + a68_op (A68_STD, "*", m, a68_lower_char_mult3); + /* SHORT SHORT INT operators. */ + m = a68_proc (M_SHORT_SHORT_INT, M_SHORT_SHORT_INT, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_confirm2); + a68_op (A68_STD, "-", m, a68_lower_negate2); + a68_op (A68_STD, "ABS", m, a68_lower_intabs2); + m = a68_proc (M_INT, M_SHORT_SHORT_INT, NO_MOID); + a68_op (A68_STD, "SIGN", m, a68_lower_sign2); + m = a68_proc (M_SHORT_INT, M_SHORT_SHORT_INT, NO_MOID); + a68_op (A68_STD, "LENG", m, a68_lower_lengint2); + m = a68_proc (M_BOOL, M_SHORT_SHORT_INT, NO_MOID); + a68_op (A68_STD, "ODD", m, a68_lower_odd2); + m = a68_proc (M_SHORT_SHORT_INT, M_SHORT_SHORT_INT, M_SHORT_SHORT_INT, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_plus_int); + a68_op (A68_STD, "-", m, a68_lower_minus_int); + a68_op (A68_STD, "*", m, a68_lower_mult_int); + a68_op (A68_STD, "OVER", m, a68_lower_over3); + a68_op (A68_STD, "%", m, a68_lower_over3); + a68_op (A68_STD, "MOD", m, a68_lower_mod3); + a68_op (A68_STD, "%*", m, a68_lower_mod3); + m = a68_proc (M_REF_SHORT_SHORT_INT, M_REF_SHORT_SHORT_INT, M_SHORT_SHORT_INT, NO_MOID); + a68_op (A68_STD, "+:=", m, a68_lower_plusab3); + a68_op (A68_STD, "-:=", m, a68_lower_minusab3); + a68_op (A68_STD, "*:=", m, a68_lower_multab3); + a68_op (A68_STD, "%:=", m, a68_lower_overab3); + a68_op (A68_STD, "%*:=", m, a68_lower_modab3); + a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3); + a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3); + a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3); + a68_op (A68_STD, "OVERAB", m, a68_lower_overab3); + a68_op (A68_STD, "MODAB", m, a68_lower_modab3); + m = a68_proc (M_BOOL, M_SHORT_SHORT_INT, M_SHORT_SHORT_INT, NO_MOID); + a68_op (A68_STD, "EQ", m, a68_lower_int_eq3); + a68_op (A68_STD, "NE", m, a68_lower_int_ne3); + a68_op (A68_STD, "GE", m, a68_lower_int_ge3); + a68_op (A68_STD, "GT", m, a68_lower_int_gt3); + a68_op (A68_STD, "LE", m, a68_lower_int_le3); + a68_op (A68_STD, "LT", m, a68_lower_int_lt3); + a68_op (A68_STD, "=", m, a68_lower_int_eq3); + a68_op (A68_STD, ">=", m, a68_lower_int_ge3); + a68_op (A68_STD, ">", m, a68_lower_int_gt3); + a68_op (A68_STD, "<=", m, a68_lower_int_le3); + a68_op (A68_STD, "<", m, a68_lower_int_lt3); + a68_op (A68_STD, "/=", m, a68_lower_int_ne3); + m = a68_proc (M_SHORT_SHORT_INT, M_SHORT_SHORT_INT, M_INT, NO_MOID); + a68_op (A68_STD, "**", m, a68_lower_pow_int); + a68_op (A68_STD, "^", m, a68_lower_pow_int); + /* SHORT INT operators. */ + m = a68_proc (M_SHORT_INT, M_SHORT_INT, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_confirm2); + a68_op (A68_STD, "-", m, a68_lower_negate2); + a68_op (A68_STD, "ABS", m, a68_lower_intabs2); + m = a68_proc (M_SHORT_SHORT_INT, M_SHORT_INT, NO_MOID); + a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenint2); + m = a68_proc (M_INT, M_SHORT_INT, NO_MOID); + a68_op (A68_STD, "LENG", m, a68_lower_lengint2); + a68_op (A68_STD, "SIGN", m, a68_lower_sign2); + m = a68_proc (M_BOOL, M_SHORT_INT, NO_MOID); + a68_op (A68_STD, "ODD", m, a68_lower_odd2); + m = a68_proc (M_SHORT_INT, M_SHORT_INT, M_SHORT_INT, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_plus_int); + a68_op (A68_STD, "-", m, a68_lower_minus_int); + a68_op (A68_STD, "*", m, a68_lower_mult_int); + a68_op (A68_STD, "OVER", m, a68_lower_over3); + a68_op (A68_STD, "%", m, a68_lower_over3); + a68_op (A68_STD, "MOD", m, a68_lower_mod3); + a68_op (A68_STD, "%*", m, a68_lower_mod3); + m = a68_proc (M_REF_SHORT_INT, M_REF_SHORT_INT, M_SHORT_INT, NO_MOID); + a68_op (A68_STD, "+:=", m, a68_lower_plusab3); + a68_op (A68_STD, "-:=", m, a68_lower_minusab3); + a68_op (A68_STD, "*:=", m, a68_lower_multab3); + a68_op (A68_STD, "%:=", m, a68_lower_overab3); + a68_op (A68_STD, "%*:=", m, a68_lower_modab3); + a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3); + a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3); + a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3); + a68_op (A68_STD, "OVERAB", m, a68_lower_overab3); + a68_op (A68_STD, "MODAB", m, a68_lower_modab3); + m = a68_proc (M_BOOL, M_SHORT_INT, M_SHORT_INT, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_int_eq3); + a68_op (A68_STD, "EQ", m, a68_lower_int_eq3); + a68_op (A68_STD, "/=", m, a68_lower_int_ne3); + a68_op (A68_STD, "NE", m, a68_lower_int_ne3); + a68_op (A68_STD, "<", m, a68_lower_int_lt3); + a68_op (A68_STD, "LT", m, a68_lower_int_lt3); + a68_op (A68_STD, "<=", m, a68_lower_int_le3); + a68_op (A68_STD, "LE", m, a68_lower_int_le3); + a68_op (A68_STD, ">", m, a68_lower_int_gt3); + a68_op (A68_STD, "GT", m, a68_lower_int_gt3); + a68_op (A68_STD, ">=", m, a68_lower_int_ge3); + a68_op (A68_STD, "GE", m, a68_lower_int_ge3); + m = a68_proc (M_SHORT_INT, M_SHORT_INT, M_INT, NO_MOID); + a68_op (A68_STD, "**", m, a68_lower_pow_int); + a68_op (A68_STD, "^", m, a68_lower_pow_int); + /* INT operators. */ + m = a68_proc (M_INT, M_INT, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_confirm2); + a68_op (A68_STD, "-", m, a68_lower_negate2); + a68_op (A68_STD, "ABS", m, a68_lower_intabs2); + a68_op (A68_STD, "SIGN", m, a68_lower_sign2); + m = a68_proc (M_SHORT_INT, M_INT, NO_MOID); + a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenint2); + m = a68_proc (M_LONG_INT, M_INT, NO_MOID); + a68_op (A68_STD, "LENG", m, a68_lower_lengint2); + m = a68_proc (M_BOOL, M_INT, NO_MOID); + a68_op (A68_STD, "ODD", m, a68_lower_odd2); + m = a68_proc (M_BOOL, M_INT, M_INT, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_int_eq3); + a68_op (A68_STD, "/=", m, a68_lower_int_ne3); + a68_op (A68_STD, "<", m, a68_lower_int_lt3); + a68_op (A68_STD, "<=", m, a68_lower_int_le3); + a68_op (A68_STD, ">", m, a68_lower_int_gt3); + a68_op (A68_STD, ">=", m, a68_lower_int_ge3); + a68_op (A68_STD, "EQ", m, a68_lower_int_eq3); + a68_op (A68_STD, "NE", m, a68_lower_int_ne3); + a68_op (A68_STD, "LT", m, a68_lower_int_lt3); + a68_op (A68_STD, "LE", m, a68_lower_int_le3); + a68_op (A68_STD, "GT", m, a68_lower_int_gt3); + a68_op (A68_STD, "GE", m, a68_lower_int_ge3); + m = a68_proc (M_INT, M_INT, M_INT, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_plus_int); + a68_op (A68_STD, "-", m, a68_lower_minus_int); + a68_op (A68_STD, "*", m, a68_lower_mult_int); + a68_op (A68_STD, "OVER", m, a68_lower_over3); + a68_op (A68_STD, "%", m, a68_lower_over3); + a68_op (A68_STD, "MOD", m, a68_lower_mod3); + a68_op (A68_STD, "%*", m, a68_lower_mod3); + a68_op (A68_STD, "**", m, a68_lower_pow_int); + a68_op (A68_STD, "^", m, a68_lower_pow_int); + m = a68_proc (M_REAL, M_INT, M_INT, NO_MOID); + a68_op (A68_STD, "/", m, a68_lower_rdiv3); + m = a68_proc (M_REF_INT, M_REF_INT, M_INT, NO_MOID); + a68_op (A68_STD, "+:=", m, a68_lower_plusab3); + a68_op (A68_STD, "-:=", m, a68_lower_minusab3); + a68_op (A68_STD, "*:=", m, a68_lower_multab3); + a68_op (A68_STD, "%:=", m, a68_lower_overab3); + a68_op (A68_STD, "%*:=", m, a68_lower_modab3); + a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3); + a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3); + a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3); + a68_op (A68_STD, "OVERAB", m, a68_lower_overab3); + a68_op (A68_STD, "MODAB", m, a68_lower_modab3); + /* LONG INT operators */ + m = a68_proc (M_LONG_INT, M_LONG_INT, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_confirm2); + a68_op (A68_STD, "-", m, a68_lower_negate2); + a68_op (A68_STD, "ABS", m, a68_lower_intabs2); + m = a68_proc (M_INT, M_LONG_INT, NO_MOID); + a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenint2); + a68_op (A68_STD, "SIGN", m, a68_lower_sign2); + m = a68_proc (M_LONG_LONG_INT, M_LONG_INT, NO_MOID); + a68_op (A68_STD, "LENG", m, a68_lower_lengint2); + m = a68_proc (M_BOOL, M_LONG_INT, NO_MOID); + a68_op (A68_STD, "ODD", m, a68_lower_odd2); + m = a68_proc (M_LONG_INT, M_LONG_INT, M_LONG_INT, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_plus_int); + a68_op (A68_STD, "-", m, a68_lower_minus_int); + a68_op (A68_STD, "*", m, a68_lower_mult_int); + a68_op (A68_STD, "OVER", m, a68_lower_over3); + a68_op (A68_STD, "%", m, a68_lower_over3); + a68_op (A68_STD, "MOD", m, a68_lower_mod3); + a68_op (A68_STD, "%*", m, a68_lower_mod3); + m = a68_proc (M_REF_LONG_INT, M_REF_LONG_INT, M_LONG_INT, NO_MOID); + a68_op (A68_STD, "+:=", m, a68_lower_plusab3); + a68_op (A68_STD, "-:=", m, a68_lower_minusab3); + a68_op (A68_STD, "*:=", m, a68_lower_multab3); + a68_op (A68_STD, "%:=", m, a68_lower_overab3); + a68_op (A68_STD, "%*:=", m, a68_lower_modab3); + a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3); + a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3); + a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3); + a68_op (A68_STD, "OVERAB", m, a68_lower_overab3); + a68_op (A68_STD, "MODAB", m, a68_lower_modab3); + m = a68_proc (M_BOOL, M_LONG_INT, M_LONG_INT, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_int_eq3); + a68_op (A68_STD, "EQ", m, a68_lower_int_eq3); + a68_op (A68_STD, "/=", m, a68_lower_int_ne3); + a68_op (A68_STD, "NE", m, a68_lower_int_ne3); + a68_op (A68_STD, "<", m, a68_lower_int_lt3); + a68_op (A68_STD, "LT", m, a68_lower_int_lt3); + a68_op (A68_STD, "<=", m, a68_lower_int_le3); + a68_op (A68_STD, "LE", m, a68_lower_int_le3); + a68_op (A68_STD, ">", m, a68_lower_int_gt3); + a68_op (A68_STD, "GT", m, a68_lower_int_gt3); + a68_op (A68_STD, ">=", m, a68_lower_int_ge3); + a68_op (A68_STD, "GE", m, a68_lower_int_ge3); + m = a68_proc (M_LONG_REAL, M_LONG_INT, M_LONG_INT, NO_MOID); + a68_op (A68_STD, "/", m, a68_lower_rdiv3); + m = a68_proc (M_LONG_INT, M_LONG_INT, M_INT, NO_MOID); + a68_op (A68_STD, "**", m, a68_lower_pow_int); + a68_op (A68_STD, "^", m, a68_lower_pow_int); + /* LONG LONG INT operators. */ + m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_confirm2); + a68_op (A68_STD, "-", m, a68_lower_negate2); + a68_op (A68_STD, "ABS", m, a68_lower_intabs2); + m = a68_proc (M_INT, M_LONG_LONG_INT, NO_MOID); + a68_op (A68_STD, "SIGN", m, a68_lower_sign2); + m = a68_proc (M_LONG_INT, M_LONG_LONG_INT, NO_MOID); + a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenint2); + m = a68_proc (M_BOOL, M_LONG_LONG_INT, NO_MOID); + a68_op (A68_STD, "ODD", m, a68_lower_odd2); + m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_plus_int); + a68_op (A68_STD, "-", m, a68_lower_minus_int); + a68_op (A68_STD, "*", m, a68_lower_mult_int); + a68_op (A68_STD, "OVER", m, a68_lower_over3); + a68_op (A68_STD, "%", m, a68_lower_over3); + a68_op (A68_STD, "MOD", m, a68_lower_mod3); + a68_op (A68_STD, "%*", m, a68_lower_mod3); + m = a68_proc (M_REF_LONG_LONG_INT, M_REF_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); + a68_op (A68_STD, "+:=", m, a68_lower_plusab3); + a68_op (A68_STD, "-:=", m, a68_lower_minusab3); + a68_op (A68_STD, "*:=", m, a68_lower_multab3); + a68_op (A68_STD, "%:=", m, a68_lower_overab3); + a68_op (A68_STD, "%*:=", m, a68_lower_modab3); + a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3); + a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3); + a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3); + a68_op (A68_STD, "OVERAB", m, a68_lower_overab3); + a68_op (A68_STD, "MODAB", m, a68_lower_modab3); + m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); + a68_op (A68_STD, "/", m, a68_lower_rdiv3); + m = a68_proc (M_BOOL, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); + a68_op (A68_STD, "EQ", m, a68_lower_int_eq3); + a68_op (A68_STD, "NE", m, a68_lower_int_ne3); + a68_op (A68_STD, "GE", m, a68_lower_int_ge3); + a68_op (A68_STD, "GT", m, a68_lower_int_gt3); + a68_op (A68_STD, "LE", m, a68_lower_int_le3); + a68_op (A68_STD, "LT", m, a68_lower_int_lt3); + a68_op (A68_STD, "=", m, a68_lower_int_eq3); + a68_op (A68_STD, ">=", m, a68_lower_int_ge3); + a68_op (A68_STD, ">", m, a68_lower_int_gt3); + a68_op (A68_STD, "<=", m, a68_lower_int_le3); + a68_op (A68_STD, "<", m, a68_lower_int_lt3); + a68_op (A68_STD, "/=", m, a68_lower_int_ne3); + m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_INT, M_INT, NO_MOID); + a68_op (A68_STD, "**", m, a68_lower_pow_int); + a68_op (A68_STD, "^", m, a68_lower_pow_int); + /* SHORT SHORT BITS operators */ + m = a68_proc (M_BOOL, M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_bit_eq3); + a68_op (A68_STD, "EQ", m, a68_lower_bit_eq3); + a68_op (A68_STD, "/=", m, a68_lower_bit_ne3); + a68_op (A68_STD, "NE", m, a68_lower_bit_ne3); + a68_op (A68_STD, "<=", m, a68_lower_bit_le3); + a68_op (A68_STD, "LE", m, a68_lower_bit_le3); + a68_op (A68_STD, ">=", m, a68_lower_bit_ge3); + a68_op (A68_STD, "GE", m, a68_lower_bit_ge3); + m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "NOT", m, a68_lower_bitnot2); + a68_op (A68_STD, "~", m, a68_lower_bitnot2); + m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "AND", m, a68_lower_bitand3); + a68_op (A68_STD, "OR", m, a68_lower_bitior3); + m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, M_INT, NO_MOID); + a68_op (A68_STD, "SHL", m, a68_lower_shl3); + a68_op (A68_STD, "UP", m, a68_lower_shl3); + a68_op (A68_STD, "SHR", m, a68_lower_shr3); + a68_op (A68_STD, "DOWN", m, a68_lower_shr3); + m = a68_proc (M_BOOL, M_INT, M_SHORT_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "ELEM", m, a68_lower_bitelem3); + m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_INT, NO_MOID); + a68_op (A68_STD, "BIN", m, a68_lower_bin2); + m = a68_proc (M_SHORT_SHORT_INT, M_SHORT_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "ABS", m, a68_lower_bitabs2); + m = a68_proc (M_SHORT_BITS, M_SHORT_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "LENG", m, a68_lower_bitleng2); + /* SHORT BITS operatos. */ + m = a68_proc (M_SHORT_INT, M_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "ABS", m, a68_lower_bitabs2); + m = a68_proc (M_SHORT_BITS, M_SHORT_INT, NO_MOID); + a68_op (A68_STD, "BIN", m, a68_lower_bin2); + m = a68_proc (M_SHORT_BITS, M_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "NOT", m, a68_lower_bitnot2); + a68_op (A68_STD, "~", m, a68_lower_bitnot2); + m = a68_proc (M_BOOL, M_SHORT_BITS, M_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_bit_eq3); + a68_op (A68_STD, "EQ", m, a68_lower_bit_eq3); + a68_op (A68_STD, "/=", m, a68_lower_bit_ne3); + a68_op (A68_STD, "NE", m, a68_lower_bit_ne3); + a68_op (A68_STD, "<=", m, a68_lower_bit_le3); + a68_op (A68_STD, "LE", m, a68_lower_bit_le3); + a68_op (A68_STD, ">=", m, a68_lower_bit_ge3); + a68_op (A68_STD, "GE", m, a68_lower_bit_ge3); + m = a68_proc (M_SHORT_BITS, M_SHORT_BITS, M_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "AND", m, a68_lower_bitand3); + a68_op (A68_STD, "OR", m, a68_lower_bitior3); + m = a68_proc (M_SHORT_BITS, M_SHORT_BITS, M_INT, NO_MOID); + a68_op (A68_STD, "SHL", m, a68_lower_shl3); + a68_op (A68_STD, "UP", m, a68_lower_shl3); + a68_op (A68_STD, "SHR", m, a68_lower_shr3); + a68_op (A68_STD, "DOWN", m, a68_lower_shr3); + m = a68_proc (M_BOOL, M_INT, M_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "ELEM", m, a68_lower_bitelem3); + m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "SHORTEN", m, a68_lower_bitshorten2); + m = a68_proc (M_BITS, M_SHORT_BITS, NO_MOID); + a68_op (A68_STD, "LENG", m, a68_lower_bitleng2); + /* BITS operators. */ + m = a68_proc (M_INT, M_BITS, NO_MOID); + a68_op (A68_STD, "ABS", m, a68_lower_bitabs2); + m = a68_proc (M_BITS, M_INT, NO_MOID); + a68_op (A68_STD, "BIN", m, a68_lower_bin2); + m = a68_proc (M_BITS, M_BITS, NO_MOID); + a68_op (A68_STD, "NOT", m, a68_lower_bitnot2); + a68_op (A68_STD, "~", m, a68_lower_bitnot2); + m = a68_proc (M_BOOL, M_BITS, M_BITS, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_bit_eq3); + a68_op (A68_STD, "/=", m, a68_lower_bit_ne3); + a68_op (A68_STD, "<=", m, a68_lower_bit_le3); + a68_op (A68_STD, ">=", m, a68_lower_bit_ge3); + a68_op (A68_STD, "EQ", m, a68_lower_bit_eq3); + a68_op (A68_STD, "NE", m, a68_lower_bit_ne3); + a68_op (A68_STD, "LE", m, a68_lower_bit_le3); + a68_op (A68_STD, "GE", m, a68_lower_bit_ge3); + m = a68_proc (M_BITS, M_BITS, M_BITS, NO_MOID); + a68_op (A68_STD, "AND", m, a68_lower_bitand3); + a68_op (A68_STD, "OR", m, a68_lower_bitior3); + m = a68_proc (M_BITS, M_BITS, M_INT, NO_MOID); + a68_op (A68_STD, "SHL", m, a68_lower_shl3); + a68_op (A68_STD, "UP", m, a68_lower_shl3); + a68_op (A68_STD, "SHR", m, a68_lower_shr3); + a68_op (A68_STD, "DOWN", m, a68_lower_shr3); + m = a68_proc (M_BOOL, M_INT, M_BITS, NO_MOID); + a68_op (A68_STD, "ELEM", m, a68_lower_bitelem3); + m = a68_proc (M_LONG_BITS, M_BITS, NO_MOID); + a68_op (A68_STD, "LENG", m, a68_lower_bitleng2); + m = a68_proc (M_SHORT_BITS, M_BITS, NO_MOID); + a68_op (A68_STD, "SHORTEN", m, a68_lower_bitshorten2); + /* LONG BITS operatos. */ + m = a68_proc (M_LONG_INT, M_LONG_BITS, NO_MOID); + a68_op (A68_STD, "ABS", m, a68_lower_bitabs2); + m = a68_proc (M_LONG_BITS, M_LONG_INT, NO_MOID); + a68_op (A68_STD, "BIN", m, a68_lower_bin2); + m = a68_proc (M_LONG_BITS, M_LONG_BITS, NO_MOID); + a68_op (A68_STD, "NOT", m, a68_lower_bitnot2); + a68_op (A68_STD, "~", m, a68_lower_bitnot2); + m = a68_proc (M_BOOL, M_LONG_BITS, M_LONG_BITS, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_bit_eq3); + a68_op (A68_STD, "EQ", m, a68_lower_bit_eq3); + a68_op (A68_STD, "/=", m, a68_lower_bit_ne3); + a68_op (A68_STD, "NE", m, a68_lower_bit_ne3); + a68_op (A68_STD, "<=", m, a68_lower_bit_le3); + a68_op (A68_STD, "LE", m, a68_lower_bit_le3); + a68_op (A68_STD, ">=", m, a68_lower_bit_ge3); + a68_op (A68_STD, "GE", m, a68_lower_bit_ge3); + m = a68_proc (M_LONG_BITS, M_LONG_BITS, M_LONG_BITS, NO_MOID); + a68_op (A68_STD, "AND", m, a68_lower_bitand3); + a68_op (A68_STD, "OR", m, a68_lower_bitior3); + m = a68_proc (M_LONG_BITS, M_LONG_BITS, M_INT, NO_MOID); + a68_op (A68_STD, "SHL", m, a68_lower_shl3); + a68_op (A68_STD, "UP", m, a68_lower_shl3); + a68_op (A68_STD, "SHR", m, a68_lower_shr3); + a68_op (A68_STD, "DOWN", m, a68_lower_shr3); + m = a68_proc (M_BOOL, M_INT, M_LONG_BITS, NO_MOID); + a68_op (A68_STD, "ELEM", m, a68_lower_bitelem3); + m = a68_proc (M_BITS, M_LONG_BITS, NO_MOID); + a68_op (A68_STD, "SHORTEN", m, a68_lower_bitshorten2); + m = a68_proc (M_LONG_LONG_BITS, M_LONG_BITS, NO_MOID); + a68_op (A68_STD, "LENG", m, a68_lower_bitleng2); + /* LONG LONG BITS operators */ + m = a68_proc (M_BOOL, M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_bit_eq3); + a68_op (A68_STD, "EQ", m, a68_lower_bit_eq3); + a68_op (A68_STD, "/=", m, a68_lower_bit_ne3); + a68_op (A68_STD, "NE", m, a68_lower_bit_ne3); + a68_op (A68_STD, "<=", m, a68_lower_bit_le3); + a68_op (A68_STD, "LE", m, a68_lower_bit_le3); + a68_op (A68_STD, ">=", m, a68_lower_bit_ge3); + a68_op (A68_STD, "GE", m, a68_lower_bit_ge3); + m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID); + a68_op (A68_STD, "NOT", m, a68_lower_bitnot2); + a68_op (A68_STD, "~", m, a68_lower_bitnot2); + m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID); + a68_op (A68_STD, "AND", m, a68_lower_bitand3); + a68_op (A68_STD, "OR", m, a68_lower_bitior3); + m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, M_INT, NO_MOID); + a68_op (A68_STD, "SHL", m, a68_lower_shl3); + a68_op (A68_STD, "UP", m, a68_lower_shl3); + a68_op (A68_STD, "SHR", m, a68_lower_shr3); + a68_op (A68_STD, "DOWN", m, a68_lower_shr3); + m = a68_proc (M_BOOL, M_INT, M_LONG_LONG_BITS, NO_MOID); + a68_op (A68_STD, "ELEM", m, a68_lower_bitelem3); + m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_INT, NO_MOID); + a68_op (A68_STD, "BIN", m, a68_lower_bin2); + m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_BITS, NO_MOID); + a68_op (A68_STD, "ABS", m, a68_lower_bitabs2); + m = a68_proc (M_LONG_BITS, M_LONG_LONG_BITS, NO_MOID); + a68_op (A68_STD, "SHORTEN", m, a68_lower_bitshorten2); + /* REAL operators. */ + m = A68_MCACHE (proc_real_real); + a68_op (A68_STD, "+", m, a68_lower_confirm2); + a68_op (A68_STD, "-", m, a68_lower_negate2); + a68_op (A68_STD, "ABS", m, a68_lower_realabs2); + m = a68_proc (M_INT, M_REAL, NO_MOID); + a68_op (A68_STD, "SIGN", m, a68_lower_realsign2); + a68_op (A68_STD, "ROUND", m, a68_lower_round2); + a68_op (A68_STD, "ENTIER", m, a68_lower_entier2); + m = a68_proc (M_BOOL, M_REAL, M_REAL, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_real_eq3); + a68_op (A68_STD, "/=", m, a68_lower_real_ne3); + a68_op (A68_STD, "<", m, a68_lower_real_lt3); + a68_op (A68_STD, "<=", m, a68_lower_real_le3); + a68_op (A68_STD, ">", m, a68_lower_real_gt3); + a68_op (A68_STD, ">=", m, a68_lower_real_ge3); + a68_op (A68_STD, "EQ", m, a68_lower_real_eq3); + a68_op (A68_STD, "NE", m, a68_lower_real_ne3); + a68_op (A68_STD, "LT", m, a68_lower_real_lt3); + a68_op (A68_STD, "LE", m, a68_lower_real_le3); + a68_op (A68_STD, "GT", m, a68_lower_real_gt3); + a68_op (A68_STD, "GE", m, a68_lower_real_ge3); + m = A68_MCACHE (proc_real_real_real); + a68_op (A68_STD, "+", m, a68_lower_plus_real); + a68_op (A68_STD, "-", m, a68_lower_minus_real); + a68_op (A68_STD, "*", m, a68_lower_mult_real); + a68_op (A68_STD, "/", m, a68_lower_div3); + a68_op (A68_STD, "**", m, a68_lower_pow_real); + a68_op (A68_STD, "^", m, a68_lower_pow_real); + m = a68_proc (M_REAL, M_REAL, M_INT, NO_MOID); + a68_op (A68_STD, "**", m, a68_lower_pow_real); + a68_op (A68_STD, "^", m, a68_lower_pow_real); + m = a68_proc (M_REF_REAL, M_REF_REAL, M_REAL, NO_MOID); + a68_op (A68_STD, "+:=", m, a68_lower_plusab3); + a68_op (A68_STD, "-:=", m, a68_lower_minusab3); + a68_op (A68_STD, "*:=", m, a68_lower_multab3); + a68_op (A68_STD, "/:=", m, a68_lower_divab3); + a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3); + a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3); + a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3); + a68_op (A68_STD, "DIVAB", m, a68_lower_divab3); + m = a68_proc (M_LONG_REAL, M_REAL, NO_MOID); + a68_op (A68_STD, "LENG", m, a68_lower_lengreal2); + /* LONG REAL operators */ + m = a68_proc (M_LONG_LONG_REAL, M_LONG_REAL, NO_MOID); + a68_op (A68_STD, "LENG", m, a68_lower_lengreal2); + m = a68_proc (M_REAL, M_LONG_REAL, NO_MOID); + a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenreal2); + m = a68_proc (M_LONG_REAL, M_LONG_REAL, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_confirm2); + a68_op (A68_STD, "-", m, a68_lower_negate2); + a68_op (A68_STD, "ABS", m, a68_lower_realabs2); + m = a68_proc (M_INT, M_LONG_REAL, NO_MOID); + a68_op (A68_STD, "SIGN", m, a68_lower_realsign2); + m = a68_proc (M_LONG_INT, M_LONG_REAL, NO_MOID); + a68_op (A68_STD, "ENTIER", m, a68_lower_entier2); + a68_op (A68_STD, "ROUND", m, a68_lower_round2); + m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_plus_real); + a68_op (A68_STD, "-", m, a68_lower_minus_real); + a68_op (A68_STD, "*", m, a68_lower_mult_real); + a68_op (A68_STD, "/", m, a68_lower_div3); + a68_op (A68_STD, "**", m, a68_lower_pow_real); + a68_op (A68_STD, "^", m, a68_lower_pow_real); + m = a68_proc (M_REF_LONG_REAL, M_REF_LONG_REAL, M_LONG_REAL, NO_MOID); + a68_op (A68_STD, "+:=", m, a68_lower_plusab3); + a68_op (A68_STD, "-:=", m, a68_lower_minusab3); + a68_op (A68_STD, "*:=", m, a68_lower_multab3); + a68_op (A68_STD, "/:=", m, a68_lower_divab3); + a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3); + a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3); + a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3); + a68_op (A68_STD, "DIVAB", m, a68_lower_divab3); + m = a68_proc (M_BOOL, M_LONG_REAL, M_LONG_REAL, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_real_eq3); + a68_op (A68_STD, "EQ", m, a68_lower_real_eq3); + a68_op (A68_STD, "/=", m, a68_lower_real_ne3); + a68_op (A68_STD, "NE", m, a68_lower_real_ne3); + a68_op (A68_STD, "<", m, a68_lower_real_lt3); + a68_op (A68_STD, "LT", m, a68_lower_real_lt3); + a68_op (A68_STD, "<=", m, a68_lower_real_le3); + a68_op (A68_STD, "LE", m, a68_lower_real_le3); + a68_op (A68_STD, ">", m, a68_lower_real_gt3); + a68_op (A68_STD, "GT", m, a68_lower_real_gt3); + a68_op (A68_STD, ">=", m, a68_lower_real_ge3); + a68_op (A68_STD, "GE", m, a68_lower_real_ge3); + m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_INT, NO_MOID); + a68_op (A68_STD, "**", m, a68_lower_pow_real); + a68_op (A68_STD, "^", m, a68_lower_pow_real); + /* LONG LONG REAL operators. */ + m = a68_proc (M_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); + a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenreal2); + m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); + a68_op (A68_STD, "ABS", m, a68_lower_realabs2); + a68_op (A68_STD, "+", m, a68_lower_confirm2); + a68_op (A68_STD, "-", m, a68_lower_negate2); + m = a68_proc (M_INT, M_LONG_LONG_REAL, NO_MOID); + a68_op (A68_STD, "SIGN", m, a68_lower_realsign2); + m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_REAL, NO_MOID); + a68_op (A68_STD, "ENTIER", m, a68_lower_entier2); + a68_op (A68_STD, "ROUND", m, a68_lower_round2); + m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); + a68_op (A68_STD, "+", m, a68_lower_plus_real); + a68_op (A68_STD, "-", m, a68_lower_minus_real); + a68_op (A68_STD, "*", m, a68_lower_mult_real); + a68_op (A68_STD, "/", m, a68_lower_div3); + a68_op (A68_STD, "**", m, a68_lower_pow_real); + a68_op (A68_STD, "^", m, a68_lower_pow_real); + m = a68_proc (M_REF_LONG_LONG_REAL, M_REF_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); + a68_op (A68_STD, "+:=", m, a68_lower_plusab3); + a68_op (A68_STD, "-:=", m, a68_lower_minusab3); + a68_op (A68_STD, "*:=", m, a68_lower_multab3); + a68_op (A68_STD, "/:=", m, a68_lower_divab3); + a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3); + a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3); + a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3); + a68_op (A68_STD, "DIVAB", m, a68_lower_divab3); + m = a68_proc (M_BOOL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); + a68_op (A68_STD, "=", m, a68_lower_real_eq3); + a68_op (A68_STD, "EQ", m, a68_lower_real_eq3); + a68_op (A68_STD, "/=", m, a68_lower_real_ne3); + a68_op (A68_STD, "NE", m, a68_lower_real_ne3); + a68_op (A68_STD, "<", m, a68_lower_real_lt3); + a68_op (A68_STD, "LT", m, a68_lower_real_lt3); + a68_op (A68_STD, "<=", m, a68_lower_real_le3); + a68_op (A68_STD, "LE", m, a68_lower_real_le3); + a68_op (A68_STD, ">", m, a68_lower_real_gt3); + a68_op (A68_STD, "GT", m, a68_lower_real_gt3); + a68_op (A68_STD, ">=", m, a68_lower_real_ge3); + a68_op (A68_STD, "GE", m, a68_lower_real_ge3); + m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_INT, NO_MOID); + a68_op (A68_STD, "**", m, a68_lower_pow_real); + a68_op (A68_STD, "^", m, a68_lower_pow_real); + /* ROWS operators. */ + m = a68_proc (M_INT, M_ROWS, NO_MOID); + a68_op (A68_STD, "LWB", m, a68_lower_lwb2); + a68_op (A68_STD, "UPB", m, a68_lower_upb2); + m = a68_proc (M_INT, M_INT, M_ROWS, NO_MOID); + a68_op (A68_STD, "LWB", m, a68_lower_lwb3); + a68_op (A68_STD, "UPB", m, a68_lower_upb3); + /* BYTES operators. */ + m = a68_proc (M_BYTES, M_STRING, NO_MOID); + a68_idf (A68_STD, "bytespack", m); + m = a68_proc (M_CHAR, M_INT, M_BYTES, NO_MOID); + a68_op (A68_STD, "ELEM", m); + m = a68_proc (M_BYTES, M_BYTES, M_BYTES, NO_MOID); + a68_op (A68_STD, "+", m); + m = a68_proc (M_REF_BYTES, M_REF_BYTES, M_BYTES, NO_MOID); + a68_op (A68_STD, "+:=", m); + a68_op (A68_STD, "PLUSAB", m); + m = a68_proc (M_BOOL, M_BYTES, M_BYTES, NO_MOID); + a68_op (A68_STD, "=", m); + a68_op (A68_STD, "/=", m); + a68_op (A68_STD, "<", m); + a68_op (A68_STD, "<=", m); + a68_op (A68_STD, ">", m); + a68_op (A68_STD, ">=", m); + a68_op (A68_STD, "EQ", m); + a68_op (A68_STD, "NE", m); + a68_op (A68_STD, "LT", m); + a68_op (A68_STD, "LE", m); + a68_op (A68_STD, "GT", m); + a68_op (A68_STD, "GE", m); + /* LONG BYTES operators. */ + m = a68_proc (M_LONG_BYTES, M_BYTES, NO_MOID); + a68_op (A68_STD, "LENG", m); + m = a68_proc (M_BYTES, M_LONG_BYTES, NO_MOID); + a68_idf (A68_STD, "SHORTEN", m); + m = a68_proc (M_LONG_BYTES, M_STRING, NO_MOID); + a68_idf (A68_STD, "longbytespack", m); + m = a68_proc (M_CHAR, M_INT, M_LONG_BYTES, NO_MOID); + a68_op (A68_STD, "ELEM", m); + m = a68_proc (M_LONG_BYTES, M_LONG_BYTES, M_LONG_BYTES, NO_MOID); + a68_op (A68_STD, "+", m); + m = a68_proc (M_REF_LONG_BYTES, M_REF_LONG_BYTES, M_LONG_BYTES, NO_MOID); + a68_op (A68_STD, "+:=", m); + a68_op (A68_STD, "PLUSAB", m); + m = a68_proc (M_BOOL, M_LONG_BYTES, M_LONG_BYTES, NO_MOID); + a68_op (A68_STD, "=", m); + a68_op (A68_STD, "/=", m); + a68_op (A68_STD, "<", m); + a68_op (A68_STD, "<=", m); + a68_op (A68_STD, ">", m); + a68_op (A68_STD, ">=", m); + a68_op (A68_STD, "EQ", m); + a68_op (A68_STD, "NE", m); + a68_op (A68_STD, "LT", m); + a68_op (A68_STD, "LE", m); + a68_op (A68_STD, "GT", m); + a68_op (A68_STD, "GE", m); + /* COMPLEX operators. */ + m = a68_proc (M_COMPLEX, M_REAL, M_REAL, NO_MOID); + a68_op (A68_STD, "I", m, a68_lower_reali); + a68_op (A68_STD, "+*", m, a68_lower_reali); + m = a68_proc (M_COMPLEX, M_INT, M_INT, NO_MOID); + a68_op (A68_STD, "I", m, a68_lower_inti); + a68_op (A68_STD, "+*", m, a68_lower_inti); + m = a68_proc (M_REAL, M_COMPLEX, NO_MOID); + a68_op (A68_STD, "RE", m, a68_lower_re2); + a68_op (A68_STD, "IM", m, a68_lower_im2); + a68_op (A68_STD, "ABS", m); + a68_op (A68_STD, "ARG", m); + m = A68_MCACHE (proc_complex_complex); + a68_op (A68_STD, "+", m); + a68_op (A68_STD, "-", m); + a68_op (A68_STD, "CONJ", m, a68_lower_conj2); + m = a68_proc (M_BOOL, M_COMPLEX, M_COMPLEX, NO_MOID); + a68_op (A68_STD, "=", m); + a68_op (A68_STD, "/=", m); + a68_op (A68_STD, "EQ", m); + a68_op (A68_STD, "NE", m); + m = a68_proc (M_COMPLEX, M_COMPLEX, M_COMPLEX, NO_MOID); + a68_op (A68_STD, "+", m); + a68_op (A68_STD, "-", m); + a68_op (A68_STD, "*", m); + a68_op (A68_STD, "/", m); + m = a68_proc (M_COMPLEX, M_COMPLEX, M_INT, NO_MOID); + a68_op (A68_STD, "**", m); + a68_op (A68_STD, "UP", m); + a68_op (A68_STD, "^", m); + m = a68_proc (M_REF_COMPLEX, M_REF_COMPLEX, M_COMPLEX, NO_MOID); + a68_op (A68_STD, "+:=", m); + a68_op (A68_STD, "-:=", m); + a68_op (A68_STD, "*:=", m); + a68_op (A68_STD, "/:=", m); + a68_op (A68_STD, "PLUSAB", m); + a68_op (A68_STD, "MINUSAB", m); + a68_op (A68_STD, "TIMESAB", m); + a68_op (A68_STD, "DIVAB", m); + m = a68_proc (M_COMPLEX, M_COMPLEX, NO_MOID); + a68_op (A68_STD, "SHORTEN", m); + /* LONG COMPLEX operators */ + m = a68_proc (M_LONG_COMPLEX, M_LONG_INT, M_LONG_INT, NO_MOID); + a68_op (A68_STD, "I", m, a68_lower_longinti); + a68_op (A68_STD, "+*", m, a68_lower_longinti); + m = a68_proc (M_LONG_COMPLEX, M_LONG_REAL, M_LONG_REAL, NO_MOID); + a68_op (A68_STD, "I", m, a68_lower_longreali); + a68_op (A68_STD, "+*", m, a68_lower_longreali); + m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "LENG", m); + m = a68_proc (M_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "SHORTEN", m); + m = a68_proc (M_LONG_COMPLEX, M_COMPLEX, NO_MOID); + a68_op (A68_STD, "LENG", m); + m = a68_proc (M_COMPLEX, M_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "SHORTEN", m); + m = a68_proc (M_LONG_REAL, M_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "RE", m, a68_lower_re2); + a68_op (A68_STD, "IM", m, a68_lower_im2); + a68_op (A68_STD, "ARG", m); + a68_op (A68_STD, "ABS", m); + m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "+", m); + a68_op (A68_STD, "-", m); + a68_op (A68_STD, "CONJ", m, a68_lower_conj2); + m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "+", m); + a68_op (A68_STD, "-", m); + a68_op (A68_STD, "*", m); + a68_op (A68_STD, "/", m); + m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, M_INT, NO_MOID); + a68_op (A68_STD, "**", m); + a68_op (A68_STD, "UP", m); + a68_op (A68_STD, "^", m); + m = a68_proc (M_BOOL, M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "=", m); + a68_op (A68_STD, "EQ", m); + a68_op (A68_STD, "/=", m); + a68_op (A68_STD, "NE", m); + m = a68_proc (M_REF_LONG_COMPLEX, M_REF_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "+:=", m); + a68_op (A68_STD, "-:=", m); + a68_op (A68_STD, "*:=", m); + a68_op (A68_STD, "/:=", m); + a68_op (A68_STD, "PLUSAB", m); + a68_op (A68_STD, "MINUSAB", m); + a68_op (A68_STD, "TIMESAB", m); + a68_op (A68_STD, "DIVAB", m); + /* LONG LONG COMPLEX operators. */ + m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID); + a68_op (A68_STD, "I", m, a68_lower_longlonginti); + a68_op (A68_STD, "+*", m, a68_lower_longlonginti); + m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); + a68_op (A68_STD, "I", m, a68_lower_longlongreali); + a68_op (A68_STD, "+*", m, a68_lower_longlongreali); + m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "RE", m, a68_lower_re2); + a68_op (A68_STD, "IM", m, a68_lower_im2); + a68_op (A68_STD, "ARG", m); + a68_op (A68_STD, "ABS", m); + m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "+", m); + a68_op (A68_STD, "-", m); + a68_op (A68_STD, "CONJ", m, a68_lower_conj2); + m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "+", m); + a68_op (A68_STD, "-", m); + a68_op (A68_STD, "*", m); + a68_op (A68_STD, "/", m); + m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, M_INT, NO_MOID); + a68_op (A68_STD, "**", m); + a68_op (A68_STD, "UP", m); + a68_op (A68_STD, "^", m); + m = a68_proc (M_BOOL, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "=", m); + a68_op (A68_STD, "EQ", m); + a68_op (A68_STD, "/=", m); + a68_op (A68_STD, "NE", m); + m = a68_proc (M_REF_LONG_LONG_COMPLEX, M_REF_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "+:=", m); + a68_op (A68_STD, "-:=", m); + a68_op (A68_STD, "*:=", m); + a68_op (A68_STD, "/:=", m); + a68_op (A68_STD, "PLUSAB", m); + a68_op (A68_STD, "MINUSAB", m); + a68_op (A68_STD, "TIMESAB", m); + a68_op (A68_STD, "DIVAB", m); + m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID); + a68_op (A68_STD, "LENG", m); + /* SEMA operators. */ + m = a68_proc (M_SEMA, M_INT, NO_MOID); + a68_op (A68_STD, "LEVEL", m); + m = a68_proc (M_INT, M_SEMA, NO_MOID); + a68_op (A68_STD, "LEVEL", m); + m = a68_proc (M_VOID, M_SEMA, NO_MOID); + a68_op (A68_STD, "UP", m); + a68_op (A68_STD, "DOWN", m); +} + +/* GNU extensions for the standenv. */ + +static void +gnu_prelude (void) +{ + MOID_T *m = NO_MOID; + /* Priorities. */ + a68_prio ("ELEMS", 8); + /* Identifiers. */ + a68_idf (A68_EXT, "infinity", M_REAL, a68_lower_infinity); + a68_idf (A68_EXT, "minusinfinity", M_REAL, a68_lower_minusinfinity); + a68_idf (A68_EXT, "longlonginfinity", M_LONG_LONG_REAL); + a68_idf (A68_EXT, "longlongminusinfinity", M_LONG_LONG_REAL); + a68_idf (A68_EXT, "longinfinity", M_LONG_REAL); + a68_idf (A68_EXT, "longminusinfinity", M_LONG_REAL); + a68_idf (A68_EXT, "minint", M_INT, a68_lower_minint); + a68_idf (A68_EXT, "longminint", M_LONG_INT, a68_lower_minint); + a68_idf (A68_EXT, "longlongminint", M_LONG_LONG_INT, a68_lower_minint); + a68_idf (A68_EXT, "shortminint", M_SHORT_INT, a68_lower_minint); + a68_idf (A68_EXT, "shortshortminint", M_SHORT_SHORT_INT, a68_lower_minint); + a68_idf (A68_EXT, "minreal", M_REAL, a68_lower_minreal); + a68_idf (A68_EXT, "longminreal", M_LONG_REAL, a68_lower_minreal); + a68_idf (A68_EXT, "longlongminreal", M_LONG_LONG_REAL, a68_lower_minreal); + a68_idf (A68_EXT, "eofchar", M_CHAR, a68_lower_eofchar); + a68_idf (A68_EXT, "replacementchar", M_CHAR, a68_lower_replacementchar); + /* REAL procedures. */ + m = A68_MCACHE (proc_real_real); + a68_idf (A68_EXT, "log", m, a68_lower_log); + /* LONG REAL procedures. */ + m = a68_proc (M_LONG_REAL, M_LONG_REAL, NO_MOID); + a68_idf (A68_EXT, "longlog", m, a68_lower_long_log); + /* LONG LONG REAL procedures. */ + m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID); + a68_idf (A68_EXT, "longlonglog", m, a68_lower_long_long_log); + /* BOOL operators. */ + m = a68_proc (M_BOOL, M_BOOL, M_BOOL, NO_MOID); + a68_op (A68_EXT, "XOR", m, a68_lower_xor3); + /* SHORT SHORT BITS operators. */ + m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, NO_MOID); + a68_op (A68_EXT, "XOR", m, a68_lower_bitxor3); + /* SHORT BITS operators. */ + m = a68_proc (M_SHORT_BITS, M_SHORT_BITS, M_SHORT_BITS, NO_MOID); + a68_op (A68_EXT, "XOR", m, a68_lower_bitxor3); + /* BITS operators. */ + m = a68_proc (M_BITS, M_BITS, M_BITS, NO_MOID); + a68_op (A68_EXT, "XOR", m, a68_lower_bitxor3); + /* LONG BITS operators. */ + m = a68_proc (M_LONG_BITS, M_LONG_BITS, M_LONG_BITS, NO_MOID); + a68_op (A68_EXT, "XOR", m, a68_lower_bitxor3); + /* LONG LONG BITS operators. */ + m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID); + a68_op (A68_EXT, "XOR", m, a68_lower_bitxor3); + /* ROWS operators. */ + m = a68_proc (M_INT, M_ROWS, NO_MOID); + a68_op (A68_EXT, "ELEMS", m, a68_lower_elems2); + m = a68_proc (M_INT, M_INT, M_ROWS, NO_MOID); + a68_op (A68_EXT, "ELEMS", m, a68_lower_elems3); +} + +/* POSIX prelude. */ + +static void +posix_prelude (void) +{ + MOID_T *m = NO_MOID; + + /* Environment variables. */ + m = a68_proc (M_STRING, M_STRING, NO_MOID); + a68_idf (A68_EXT, "getenv", m, a68_lower_posixgetenv); + /* Exit status handling. */ + m = a68_proc (M_VOID, M_INT, NO_MOID); + a68_idf (A68_EXT, "setexitstatus", m, a68_lower_setexitstatus); + /* Argument handling. */ + m = A68_MCACHE (proc_int); + a68_idf (A68_EXT, "argc", m, a68_lower_posixargc); + m = a68_proc (M_STRING, M_INT, NO_MOID); + a68_idf (A68_EXT, "argv", m, a68_lower_posixargv); + /* Error procedures. */ + m = A68_MCACHE (proc_int); + a68_idf (A68_EXT, "errno", m, a68_lower_posixerrno); + m = a68_proc (M_VOID, M_STRING, NO_MOID); + a68_idf (A68_EXT, "perror", m, a68_lower_posixperror); + m = a68_proc (M_STRING, M_INT, NO_MOID); + a68_idf (A68_EXT, "strerror", m, a68_lower_posixstrerror); + /* I/O identifiers. */ + a68_idf (A68_EXT, "stdin", M_INT, a68_lower_posixstdinfiledes); + a68_idf (A68_EXT, "stdout", M_INT, a68_lower_posixstdoutfiledes); + a68_idf (A68_EXT, "stderr", M_INT, a68_lower_posixstderrfiledes); + a68_idf (A68_EXT, "fileodefault", M_BITS, a68_lower_posixfileodefault); + a68_idf (A68_EXT, "fileordwr", M_BITS, a68_lower_posixfileordwr); + a68_idf (A68_EXT, "fileordonly", M_BITS, a68_lower_posixfileordonly); + a68_idf (A68_EXT, "fileowronly", M_BITS, a68_lower_posixfileowronly); + a68_idf (A68_EXT, "fileotrunc", M_BITS, a68_lower_posixfileotrunc); + /* Opening and closing files. */ + m = a68_proc (M_INT, M_STRING, M_BITS, NO_MOID); + a68_idf (A68_EXT, "fopen", m, a68_lower_posixfopen); + a68_idf (A68_EXT, "fcreate", m, a68_lower_posixfcreate); + m = A68_MCACHE (proc_int_int); + a68_idf (A68_EXT, "fclose", m, a68_lower_posixfclose); + /* Getting properties of files. */ + m = a68_proc (M_LONG_LONG_INT, M_INT, NO_MOID); + a68_idf (A68_EXT, "fsize", m, a68_lower_posixfsize); + m = a68_proc (M_LONG_LONG_INT, M_INT, M_LONG_LONG_INT, M_INT, NO_MOID); + a68_idf (A68_EXT, "lseek", m, a68_lower_posixlseek); + a68_idf (A68_EXT, "seekcur", M_INT, a68_lower_posixseekcur); + a68_idf (A68_EXT, "seekend", M_INT, a68_lower_posixseekend); + a68_idf (A68_EXT, "seekset", M_INT, a68_lower_posixseekset); + /* Sockets. */ + m = a68_proc (M_INT, M_STRING, M_INT, NO_MOID); + a68_idf (A68_EXT, "fconnect", m, a68_lower_posixfconnect); + /* String and character output. */ + m = a68_proc (M_CHAR, M_CHAR, NO_MOID); + a68_idf (A68_EXT, "putchar", m, a68_lower_posixputchar); + m = a68_proc (M_VOID, M_STRING, NO_MOID); + a68_idf (A68_EXT, "puts", m, a68_lower_posixputs); + m = a68_proc (M_CHAR, M_INT, M_CHAR, NO_MOID); + a68_idf (A68_EXT, "fputc", m, a68_lower_posixfputc); + m = a68_proc (M_INT, M_INT, M_STRING, NO_MOID); + a68_idf (A68_EXT, "fputs", m, a68_lower_posixfputs); + /* String and character input. */ + m = A68_MCACHE (proc_char); + a68_idf (A68_EXT, "getchar", m, a68_lower_posixgetchar); + m = a68_proc (M_CHAR, M_INT, NO_MOID); + a68_idf (A68_EXT, "fgetc", m, a68_lower_posixfgetc); + m = a68_proc (M_REF_STRING, M_INT, NO_MOID); + a68_idf (A68_EXT, "gets", m, a68_lower_posixgets); + m = a68_proc (M_REF_STRING, M_INT, M_INT, NO_MOID); + a68_idf (A68_EXT, "fgets", m, a68_lower_posixfgets); +} + +/* Transput. */ + +static void +stand_transput (void) +{ + PACK_T *z = NO_PACK; + MOID_T *m = NO_MOID; + + /* Modes. */ + + /* NUMBER */ + z = NO_PACK; + (void) a68_add_mode_to_pack (&z, M_INT, NO_TEXT, NO_NODE); + (void) a68_add_mode_to_pack (&z, M_LONG_INT, NO_TEXT, NO_NODE); + (void) a68_add_mode_to_pack (&z, M_LONG_LONG_INT, NO_TEXT, NO_NODE); + (void) a68_add_mode_to_pack (&z, M_SHORT_INT, NO_TEXT, NO_NODE); + (void) a68_add_mode_to_pack (&z, M_SHORT_SHORT_INT, NO_TEXT, NO_NODE); + (void) a68_add_mode_to_pack (&z, M_REAL, NO_TEXT, NO_NODE); + (void) a68_add_mode_to_pack (&z, M_LONG_REAL, NO_TEXT, NO_NODE); + (void) a68_add_mode_to_pack (&z, M_LONG_LONG_REAL, NO_TEXT, NO_NODE); + M_NUMBER = a68_add_mode (&TOP_MOID (&A68_JOB), UNION_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z); + + /* Layout procedures. */ + + /* Conversion procedures. */ + m = a68_proc (M_STRING, M_NUMBER, M_INT, NO_MOID); + a68_idf (A68_STD, "whole", m); +} + +/* Build the standard environ symbol table. */ + +void +a68_make_standard_environ (void) +{ + stand_moids (); + A68_MCACHE (proc_bool) = a68_proc (M_BOOL, NO_MOID); + A68_MCACHE (proc_char) = a68_proc (M_CHAR, NO_MOID); + A68_MCACHE (proc_complex_complex) = a68_proc (M_COMPLEX, M_COMPLEX, NO_MOID); + A68_MCACHE (proc_int) = a68_proc (M_INT, NO_MOID); + A68_MCACHE (proc_int_int) = a68_proc (M_INT, M_INT, NO_MOID); + A68_MCACHE (proc_int_int_real) = a68_proc (M_REAL, M_INT, M_INT, NO_MOID); + A68_MCACHE (proc_int_real) = a68_proc (M_REAL, M_INT, NO_MOID); + A68_MCACHE (proc_int_real_real) = a68_proc (M_REAL, M_INT, M_REAL, NO_MOID); + A68_MCACHE (proc_int_real_real_real) = a68_proc (M_REAL, M_INT, M_REAL, M_REAL, NO_MOID); + A68_MCACHE (proc_real) = a68_proc (M_REAL, NO_MOID); + A68_MCACHE (proc_real_int_real) = a68_proc (M_REAL, M_REAL, M_INT, NO_MOID); + A68_MCACHE (proc_real_real_int_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_INT, NO_MOID); + A68_MCACHE (proc_real_real) = M_PROC_REAL_REAL; + A68_MCACHE (proc_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, NO_MOID); + A68_MCACHE (proc_real_real_real_int) = a68_proc (M_INT, M_REAL, M_REAL, M_REAL, NO_MOID); + A68_MCACHE (proc_real_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, NO_MOID); + A68_MCACHE (proc_real_real_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, NO_MOID); + A68_MCACHE (proc_real_real_real_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, NO_MOID); + A68_MCACHE (proc_real_ref_real_ref_int_void) = a68_proc (M_VOID, M_REAL, M_REF_REAL, M_REF_INT, NO_MOID); + A68_MCACHE (proc_void) = a68_proc (M_VOID, NO_MOID); + stand_prelude (); + if (!OPTION_STRICT (&A68_JOB)) + { + gnu_prelude (); + posix_prelude (); + } + stand_transput (); +} diff --git a/gcc/algol68/a68-parser-scanner.cc b/gcc/algol68/a68-parser-scanner.cc new file mode 100644 index 000000000000..966ebdf6ed1d --- /dev/null +++ b/gcc/algol68/a68-parser-scanner.cc @@ -0,0 +1,2346 @@ +/* Context-dependent ALGOL 68 tokeniser. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* Context-dependent ALGOL 68 tokeniser. */ + + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "diagnostic.h" +#include "options.h" +#include "vec.h" + +#include "a68.h" + +/* A few forward references of static functions defined in this file. */ + +static void include_files (LINE_T *top); + +/* Standard prelude and postlude for source files. + + These are used for particular programs only. Not for prelude packets. + We need several versions for the several supported stropping regimes. */ + +static const char * +upper_prelude_start[] = { + "BEGIN", + " BEGIN", + NO_TEXT +}; + +static const char * +upper_postlude[] = { + " END;", + " stop: SKIP", + "END", + NO_TEXT +}; + +static const char * +supper_prelude_start[] = { + "begin", + " begin", + NO_TEXT +}; + +static const char * +supper_postlude[] = { + " end;", + " stop: skip", + "end", + NO_TEXT +}; + +/* Macros. */ + +#define NULL_CHAR '\0' +#define STOP_CHAR 127 +#define FORMFEED_CHAR '\f' +#define CR_CHAR '\r' +#define QUOTE_CHAR '"' +#define APOSTROPHE_CHAR '\'' +#define BACKSLASH_CHAR '\\' +#define NEWLINE_CHAR '\n' +#define EXPONENT_CHAR 'e' +#define RADIX_CHAR 'r' +#define POINT_CHAR '.' +#define TAB_CHAR '\t' + +#define MAX_RESTART 256 + +#define EOL(c) ((c) == NEWLINE_CHAR || (c) == NULL_CHAR) +#define SCAN_ERROR(c, u, v, txt) if (c) \ + do \ + { \ + a68_scan_error (u, v, txt); \ + } \ + while (0) + + +#define SCAN_DIGITS(c) \ + while (ISDIGIT (c)) \ + { \ + (sym++)[0] = (c); \ + (c) = next_char (ref_l, ref_s, true); \ + } + +#define SCAN_EXPONENT_PART(c) \ + do \ + { \ + (sym++)[0] = EXPONENT_CHAR; \ + (c) = next_char (ref_l, ref_s, true); \ + if ((c) == '+' || (c) == '-') { \ + (sym++)[0] = (c); \ + (c) = next_char (ref_l, ref_s, true); \ + } \ + SCAN_ERROR (!ISDIGIT (c), *start_l, *start_c, \ + "invalid exponent digit"); \ + SCAN_DIGITS (c); \ + } \ + while (0) + +/* Read bytes from file into buffer. */ + +static ssize_t +io_read (FILE *file, void *buf, size_t n) +{ + int fd = fileno (file); + size_t to_do = n; + int restarts = 0; + char *z = (char *) buf; + while (to_do > 0) + { + ssize_t bytes_read; + + errno = 0; + bytes_read = read (fd, z, to_do); + if (bytes_read < 0) + { + if (errno == EINTR) + { + /* interrupt, retry. */ + bytes_read = 0; + if (restarts++ > MAX_RESTART) + { + return -1; + } + } + else + { + /* read error. */ + return -1; + } + } + else if (bytes_read == 0) + { + /* EOF_CHAR */ + break; + } + to_do -= (size_t) bytes_read; + z += bytes_read; + } + + /* return >= 0 */ + return (ssize_t) n - (ssize_t) to_do; +} + +/* Save scanner state, for character look-ahead. */ + +static void +save_state (LINE_T *ref_l, char *ref_s, char ch) +{ + SCAN_STATE_L (&A68_JOB) = ref_l; + SCAN_STATE_S (&A68_JOB) = ref_s; + SCAN_STATE_C (&A68_JOB) = ch; +} + +/* Restore scanner state, for character look-ahead. */ + +static void +restore_state (LINE_T **ref_l, char **ref_s, char *ch) +{ + *ref_l = SCAN_STATE_L (&A68_JOB); + *ref_s = SCAN_STATE_S (&A68_JOB); + *ch = SCAN_STATE_C (&A68_JOB); +} + +/* New_source_line. */ + +static LINE_T * +new_source_line (void) +{ + LINE_T *z = ggc_cleared_alloc (); + + MARKER (z)[0] = '\0'; + STRING (z) = NO_TEXT; + FILENAME (z) = NO_TEXT; + NUMBER (z) = 0; + NEXT (z) = NO_LINE; + PREVIOUS (z) = NO_LINE; + return z; +} + +/* Append a source line to the internal source file. */ + +static void +append_source_line (const char *str, LINE_T **ref_l, int *line_num, + const char *filename) +{ + LINE_T *z = new_source_line (); + + /* Link line into the chain. */ + STRING (z) = xstrdup (str); + FILENAME (z) = ggc_strdup (filename); + NUMBER (z) = (*line_num)++; + NEXT (z) = NO_LINE; + PREVIOUS (z) = *ref_l; + if (TOP_LINE (&A68_JOB) == NO_LINE) + TOP_LINE (&A68_JOB) = z; + if (*ref_l != NO_LINE) + NEXT (*ref_l) = z; + *ref_l = z; +} + +/* Append environment source lines. */ + +static void +append_environ (const char *str[], LINE_T **ref_l, int *line_num, const char *name) +{ + for (int k = 0; str[k] != NO_TEXT; k++) + { + int zero_line_num = 0; + (*line_num)++; + append_source_line (str[k], ref_l, &zero_line_num, name); + } +} + +/* + * Scanner, tokenises the source code. + */ + +/* Emit a diagnostic if CH is an unworthy character. */ + +static void +unworthy (LINE_T *u, char *v, char ch) +{ + if (ISPRINT (ch)) + { + if (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*%s", + "unworthy character") < 0) + gcc_unreachable (); + } + else + { + if (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*%s %c", + "unworthy character", ch) < 0) + gcc_unreachable (); + } + + a68_scan_error (u, v, A68 (edit_line)); +} + +/* Concatenate lines that terminate in '\' with next line. */ + +static void +concatenate_lines (LINE_T * top) +{ + LINE_T *q; + /* Work from bottom backwards. */ + for (q = top; q != NO_LINE && NEXT (q) != NO_LINE; FORWARD (q)) + ; + + for (; q != NO_LINE; BACKWARD (q)) + { + char *z = STRING (q); + size_t len = strlen (z); + + if (len >= 2 + && z[len - 2] == BACKSLASH_CHAR + && z[len - 1] == NEWLINE_CHAR + && NEXT (q) != NO_LINE + && STRING (NEXT (q)) != NO_TEXT) + { + z[len - 2] = '\0'; + len += (int) strlen (STRING (NEXT (q))); + z = (char *) xmalloc (len + 1); + a68_bufcpy (z, STRING (q), len + 1); + a68_bufcat (z, STRING (NEXT (q)), len + 1); + STRING (NEXT (q))[0] = '\0'; + STRING (q) = z; + } + } +} + +/* Size of source file. */ + +static int +get_source_size (void) +{ + FILE *f = FILE_SOURCE_FD (&A68_JOB); + return (int) lseek (fileno (f), 0, SEEK_END); +} + +/* Read source file FILENAME and make internal copy. */ + +static bool +read_source_file (const char *filename) +{ + struct stat statbuf; + LINE_T *ref_l = NO_LINE; + int line_num = 0; + size_t k; + size_t bytes_read; + ssize_t l; + size_t source_file_size; + char *buffer; + FILE *f; + bool ret = true; + + /* First open the given file. */ + if (!(FILE_SOURCE_FD (&A68_JOB) = fopen (filename, "r"))) + fatal_error (UNKNOWN_LOCATION, "could not open source file %s", + filename); + FILE_SOURCE_NAME (&A68_JOB) = ggc_strdup (filename); + f = FILE_SOURCE_FD (&A68_JOB); + + if (fstat (fileno (f), &statbuf) + || !(S_ISREG (statbuf.st_mode) || S_ISCHR (statbuf.st_mode))) + fatal_error (UNKNOWN_LOCATION, "specified file %s is a directory", + filename); + + if ((source_file_size = get_source_size ()) == 0) + { + /* The source file is empty. */ + ret = false; + goto done; + } + + /* Allocate A68_PARSER (scan_buf), which is an auxiliary buffer used by the + scanner known to be big enough to hold any string contained in the source + file. */ + A68_PARSER (max_scan_buf_length) = source_file_size + 1; + A68_PARSER (max_scan_buf_length) += 1024; /* For the environment. */ + A68_PARSER (scan_buf) = (char *) xmalloc (A68_PARSER (max_scan_buf_length)); + + /* Prelude. */ + append_environ (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING + ? upper_prelude_start : supper_prelude_start, + &ref_l, &line_num, "prelude"); + + /* Read the file into a single buffer, so we save on system calls. */ + line_num = 1; + errno = 0; + buffer = (char *) xmalloc (8 + source_file_size); + if (lseek (fileno (f), 0, SEEK_SET) < 0) + gcc_unreachable (); + errno = 0; + bytes_read = io_read (f, buffer, source_file_size); + gcc_assert (errno == 0 && bytes_read == source_file_size); + + /* Link all lines into the list. */ + k = 0; + while (k < source_file_size) + { + l = 0; + A68_PARSER (scan_buf)[0] = '\0'; + while (k < source_file_size && buffer[k] != NEWLINE_CHAR) + { + if (k < source_file_size - 1 + && buffer[k] == CR_CHAR && buffer[k + 1] == NEWLINE_CHAR) + k++; + else + { + A68_PARSER (scan_buf)[l++] = buffer[k++]; + A68_PARSER (scan_buf)[l] = '\0'; + } + } + A68_PARSER (scan_buf)[l++] = NEWLINE_CHAR; + A68_PARSER (scan_buf)[l] = '\0'; + if (k < source_file_size) + k++; + append_source_line (A68_PARSER (scan_buf), &ref_l, &line_num, + FILE_SOURCE_NAME (&A68_JOB)); + SCAN_ERROR (l != (ssize_t) strlen (A68_PARSER (scan_buf)), + NO_LINE, NO_TEXT, "invalid characters in source file"); + } + + /* Postlude. */ + append_environ (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING + ? upper_postlude : supper_postlude, + &ref_l, &line_num, "postlude"); + + /* Concatenate lines that end with \. */ + concatenate_lines (TOP_LINE (&A68_JOB)); + + /* Include files. */ + include_files (TOP_LINE (&A68_JOB)); + + done: + if (fclose (FILE_SOURCE_FD (&A68_JOB)) != 0) + gcc_unreachable (); + return ret; +} + +/* Get next character from internal copy of source file. + + If ALLOW_TYPO is true then typographical display features are skipped. + + If ALLOW_ONE_UNDER is true then a single underscore character is + skipped. */ + +static char +next_char (LINE_T **ref_l, char **ref_s, bool allow_typo, + bool allow_one_under = false, bool *found_under = NULL) +{ + char ch; + + /* Empty source. */ + if (*ref_l == NO_LINE) + return STOP_CHAR; + + if ((*ref_s)[0] == NEWLINE_CHAR || (*ref_s)[0] == '\0') + { + /* Go to new line. */ + *ref_l = NEXT (*ref_l); + if (*ref_l == NO_LINE) + return STOP_CHAR; + *ref_s = STRING (*ref_l); + } + else + (*ref_s)++; + + /* Deliver next char. */ + ch = (*ref_s)[0]; + if ((allow_typo && (ISSPACE (ch) || ch == FORMFEED_CHAR)) + || (allow_one_under && ch == '_')) + { + if (ch == '_' && found_under != NULL) + *found_under = true; + ch = next_char (ref_l, ref_s, allow_typo); + } + return ch; +} + +/* Find first character that can start a valid symbol. */ + +static void +get_good_char (char *ref_c, LINE_T **ref_l, char **ref_s) +{ + while (*ref_c != STOP_CHAR && (ISSPACE (*ref_c) || (*ref_c == '\0'))) + *ref_c = next_char (ref_l, ref_s, false); +} + +/* Case insensitive strncmp for at most the number of chars in V. */ + +static int +streq (const char *u, const char *v) +{ + int diff; + for (diff = 0; diff == 0 && u[0] != NULL_CHAR && v[0] != NULL_CHAR; u++, v++) + diff = ((int) TOLOWER (u[0])) - ((int) TOLOWER (v[0])); + return diff; +} + +/* Case insensitive strncmp for at most N chars. */ + +static int +strneq (const char *u, const char *v, size_t n) +{ + int diff; + size_t pos = 0; + for (diff = 0; + diff == 0 && u[0] != NULL_CHAR && v[0] != NULL_CHAR && pos < n; + u++, v++, pos++) + diff = ((int) TOLOWER (u[0])) - ((int) TOLOWER (v[0])); + return diff; +} + + +/* Determine whether u is bold tag v, independent of stropping regime. */ + +static bool +is_bold (char *u, const char *v) +{ + size_t len = strlen (v); + + if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) + /* UPPER stropping. */ + return strncmp (u, v, len) == 0 && !ISUPPER (u[len]); + else + /* SUPPER stropping. */ + return (strlen (u) >= len + && ISLOWER (u[0]) + && strneq (u, v, len) == 0 + && !ISALPHA (u[len]) + && !ISDIGIT (u[len])); +} + +/* Skip a string denotation. + + This function returns true if the end of the string denotation is found. + Returns false otherwise. */ + +static bool +skip_string (LINE_T **top, char **ch) +{ + LINE_T *u = *top; + char *v = *ch; + v++; + while (u != NO_LINE) + { + while (v[0] != NULL_CHAR) + { + if (v[0] == QUOTE_CHAR && v[1] != QUOTE_CHAR) + { + *top = u; + *ch = &v[1]; + return true; + } + else if (v[0] == QUOTE_CHAR && v[1] == QUOTE_CHAR) + { + v += 2; + } + else + { + v++; + } + } + FORWARD (u); + if (u != NO_LINE) { + v = &(STRING (u)[0]); + } else { + v = NO_TEXT; + } + } + return false; +} + +/* Skip a comment. + + This function returns true if the end of the comment is found. Returns + false otherwise. */ + +static bool +skip_comment (LINE_T **top, char **ch, int delim) +{ + LINE_T *u = *top; + char *v = *ch; + int nesting_level = 1; + v++; + while (u != NO_LINE) + { + while (v[0] != NULL_CHAR) + { + LINE_T *l = u; + char *c = v; + + if (v[0] == QUOTE_CHAR && skip_string (&l, &c) + && (delim == BOLD_COMMENT_BEGIN_SYMBOL || delim == BRIEF_COMMENT_BEGIN_SYMBOL)) + { + u = l; + v = c; + } + else if (is_bold (v, "COMMENT") && delim == BOLD_COMMENT_SYMBOL) + { + *top = u; + *ch = &v[1]; + return true; + } + else if (is_bold (v, "CO") && delim == STYLE_I_COMMENT_SYMBOL) + { + *top = u; + *ch = &v[1]; + return true; + } + else if (v[0] == '#' && delim == STYLE_II_COMMENT_SYMBOL) + { + *top = u; + *ch = &v[1]; + return true; + } + else if (is_bold (v, "ETON") && delim == BOLD_COMMENT_BEGIN_SYMBOL) + { + gcc_assert (nesting_level > 0); + nesting_level -= 1; + if (nesting_level == 0) + { + *top = u; + *ch = &v[1]; + return true; + } + } + else if (v[0] == '}' && delim == BRIEF_COMMENT_BEGIN_SYMBOL) + { + gcc_assert (nesting_level > 0); + nesting_level -= 1; + if (nesting_level == 0) + { + *top = u; + *ch = &v[1]; + return true; + } + } + else + { + if ((is_bold (v, "NOTE") && delim == BOLD_COMMENT_BEGIN_SYMBOL) + || (v[0] == '{' && delim == BRIEF_COMMENT_BEGIN_SYMBOL)) + { + nesting_level += 1; + } + + v++; + } + } + FORWARD (u); + if (u != NO_LINE) + v = &(STRING (u)[0]); + else + v = NO_TEXT; + } + + return false; +} + +/* Skip rest of pragmat. + + This function returns true if the end of the pragmat is found, false + otherwise. */ + +static bool +skip_pragmat (LINE_T **top, char **ch, int delim, bool whitespace) +{ + LINE_T *u = *top; + char *v = *ch; + while (u != NO_LINE) + { + while (v[0] != NULL_CHAR) + { + if (is_bold (v, "PRAGMAT") && delim == BOLD_PRAGMAT_SYMBOL) + { + *top = u; + *ch = &v[1]; + return true; + } + else if (is_bold (v, "PR") && delim == STYLE_I_PRAGMAT_SYMBOL) + { + *top = u; + *ch = &v[1]; + return true; + } + else + { + if (whitespace && !ISSPACE (v[0]) && v[0] != NEWLINE_CHAR) + { + SCAN_ERROR (true, u, v, "error in pragment"); + } + else if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING && ISUPPER (v[0])) + { + /* Skip a bold word as you may trigger on REPR, for + instance. */ + while (ISUPPER (v[0])) + v++; + } + else if (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING && ISLOWER (v[0])) + { + /* Skip a tag as you may trigger on expr, for instance. */ + while (ISLOWER (v[0]) || ISDIGIT (v[0]) || v[0] == '_') + v++; + } + else + { + v++; + } + } + } + + FORWARD (u); + if (u != NO_LINE) + v = &(STRING (u)[0]); + else + v = NO_TEXT; + } + + return false; +} + +/* Return pointer to next token within pragmat. */ + +static char * +get_pragmat_item (LINE_T **top, char **ch) +{ + LINE_T *u = *top; + char *v = *ch; + while (u != NO_LINE) + { + while (v[0] != NULL_CHAR) + { + if (!ISSPACE (v[0]) && v[0] != NEWLINE_CHAR) + { + *top = u; + *ch = v; + return v; + } + else + { + v++; + } + } + FORWARD (u); + if (u != NO_LINE) + v = &(STRING (u)[0]); + else + v = NO_TEXT; + } + + return NO_TEXT; +} + +/* Scan for the next pragmat and yield the first item within it. */ + +static char * +next_preprocessor_item (LINE_T **top, char **ch, int *delim) +{ + LINE_T *u = *top; + char *v = *ch; + *delim = 0; + while (u != NO_LINE) + { + while (v[0] != NULL_CHAR) + { + LINE_T *start_l = u; + char *start_c = v; + + if (v[0] == QUOTE_CHAR) + { + /* Skip string denotation. */ + SCAN_ERROR (!skip_string (&u, &v), start_l, start_c, + "unterminated string"); + } + else if (a68_find_keyword (A68 (top_keyword), "COMMENT") != NO_KEYWORD + && is_bold (v, "COMMENT")) + { + /* Skip comment. */ + SCAN_ERROR (!skip_comment (&u, &v, BOLD_COMMENT_SYMBOL), start_l, start_c, + "unterminated comment"); + } + else if (a68_find_keyword (A68 (top_keyword), "CO") != NO_KEYWORD + && is_bold (v, "CO")) + { + /* skip comment. */ + SCAN_ERROR (!skip_comment (&u, &v, STYLE_I_COMMENT_SYMBOL), start_l, start_c, + "unterminated comment"); + } + else if (a68_find_keyword (A68 (top_keyword), "#") != NO_KEYWORD + && v[0] == '#') + { + SCAN_ERROR (!skip_comment (&u, &v, STYLE_II_COMMENT_SYMBOL), start_l, start_c, + "unterminated comment"); + } + else if (a68_find_keyword (A68 (top_keyword), "NOTE") != NO_KEYWORD + && is_bold (v, "NOTE")) + { + SCAN_ERROR (!skip_comment (&u, &v, BOLD_COMMENT_BEGIN_SYMBOL), start_l, start_c, + "unterminated comment"); + } + else if (a68_find_keyword (A68 (top_keyword), "{") != NO_KEYWORD + && v[0] == '{') + { + SCAN_ERROR (!skip_comment (&u, &v, BRIEF_COMMENT_BEGIN_SYMBOL), start_l, start_c, + "unterminated comment"); + } + else if (is_bold (v, "PRAGMAT") || is_bold (v, "PR")) + { + /* We caught a PRAGMAT. */ + char *item; + if (is_bold (v, "PRAGMAT")) + { + *delim = BOLD_PRAGMAT_SYMBOL; + v = &v[strlen ("PRAGMAT")]; + } + else if (is_bold (v, "PR")) + { + *delim = STYLE_I_PRAGMAT_SYMBOL; + v = &v[strlen ("PR")]; + } + item = get_pragmat_item (&u, &v); + SCAN_ERROR (item == NO_TEXT, start_l, start_c, + "unterminated pragmat"); + + if (streq (item, "INCLUDE") == 0) + { + /* Item "INCLUDE" includes a file. */ + *top = u; + *ch = v; + return item; + } + else + { + /* Unrecognised item - probably options handled later by the + tokeniser. */ + SCAN_ERROR (!skip_pragmat (&u, &v, *delim, false), start_l, start_c, + "unterminated pragmat"); + } + } + else if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING && ISUPPER (v[0])) + { + /* Skip a bold word as you may trigger on REPR, for instance. */ + while (ISUPPER (v[0])) + v++; + } + else if (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING && ISLOWER (v[0])) + { + /* Skip a tag as you may trigger on expr, for instance. */ + while (ISLOWER (v[0]) || ISDIGIT (v[0]) || v[0] == '_') + v++; + } + else + { + v++; + } + } + + FORWARD (u); + if (u != NO_LINE) + v = &(STRING (u)[0]); + else + v = NO_TEXT; + } + + *top = u; + *ch = v; + return NO_TEXT; +} + +/* Concatenate the two paths P1 and P2. */ + +static char * +a68_relpath (const char *p1, const char *p2, const char *fn) +{ +#if defined(__GNU__) + /* The Hurd doesn't define PATH_MAX. */ +# define PATH_MAX 4096 +#endif + + char q[PATH_MAX + 1]; + a68_bufcpy (q, p1, PATH_MAX); + a68_bufcat (q, "/", PATH_MAX); + a68_bufcat (q, p2, PATH_MAX); + a68_bufcat (q, "/", PATH_MAX); + a68_bufcat (q, fn, PATH_MAX); + /* Home directory shortcut ~ is a shell extension. */ + if (strchr (q, '~') != NO_TEXT) { + return NO_TEXT; + } + char *r = (char *) xmalloc (PATH_MAX + 1); + gcc_assert (r != NULL); + /* Error handling in the caller! */ + errno = 0; + r = lrealpath (q); + return r; +} + +/* Return true if we can open the file for reading. False otherwise. */ + +static bool +file_read_p (const char *filename) +{ + return access (filename, R_OK) == 0 ? true : false; +} + +/* Find a file to include into the current source being parsed. Search the file + system for FILENAME and return a string with the file path. If the file is + not found, return NULL. + + When FILENAME is not an absolute path we first try to find it relative to the + current file being parsed (CURFILE). Failing to do that we use the search + paths provided by the -I option. */ + +static char * +find_include_file (const char *curfile, const char *filename) +{ + char *filepath = NO_TEXT; + char *tmpfpath = NO_TEXT; + char *fnbdir = ldirname (filename); + const char *incfile = lbasename (filename); + + if (fnbdir == NULL || incfile == NULL) + gcc_unreachable (); + + if (!IS_ABSOLUTE_PATH (filename)) + { + char *sourcedir = ldirname (curfile); + + if (sourcedir == NULL || fnbdir == NULL) + gcc_unreachable (); + + if (strlen (sourcedir) == 0 && strlen (fnbdir) == 0) + { + free (sourcedir); + sourcedir = (char *) xmalloc (2); + a68_bufcpy (sourcedir, ".", 2); + } + + tmpfpath = a68_relpath (sourcedir, fnbdir, incfile); + if (file_read_p (tmpfpath)) + { + filepath = tmpfpath; + goto cleanup; + } + + for (unsigned ix = 0; ix != vec_safe_length (A68_INCLUDE_PATHS); ix++) + { + const char *include_dir = (*(A68_INCLUDE_PATHS))[ix]; + tmpfpath = a68_relpath (include_dir, fnbdir, incfile); + if (!IS_ABSOLUTE_PATH (tmpfpath)) + tmpfpath = a68_relpath (sourcedir, fnbdir, incfile); + if (file_read_p (tmpfpath)) + { + filepath = tmpfpath; + goto cleanup; + } + } + + cleanup: + free (sourcedir); + goto end; + } + else + { + size_t fnwid = (int) strlen (filename) + 1; + tmpfpath = (char *) xmalloc ((size_t) fnwid); + a68_bufcpy (tmpfpath, filename, fnwid); + + if (file_read_p (tmpfpath)) + { + filepath = tmpfpath; + goto end; + } + } + +end: + free (fnbdir); + return filepath; +} + +/* Include files. + This function handles the INCLUDE pragmat in the source file. */ + +static void +include_files (LINE_T *top) +{ + /* syntax: PR include "filename" PR + + The file gets inserted before the line containing the pragmat. In this way + correct line numbers are preserved which helps diagnostics. A file that + has been included will not be included a second time - it will be ignored. + A rigorous fail-safe, but there is no mechanism to prevent recursive + includes in A68 source code. User reports do not indicate sophisticated + use of INCLUDE, so this is fine for now. + */ + + bool make_pass = true; + while (make_pass) + { + LINE_T *s, *t, *u = top; + char *v = &(STRING (u)[0]); + make_pass = false; + errno = 0; + while (u != NO_LINE) + { + int pr_lim; + char *item = next_preprocessor_item (&u, &v, &pr_lim); + LINE_T *start_l = u; + char *start_c = v; + /* Search for PR include "filename" PR. */ + if (item != NO_TEXT && streq (item, "INCLUDE") == 0) + { + FILE *fp; + int fd; + size_t fsize, k; + int n, linum, bytes_read; + char *fbuf, delim; + BUFFER fnb; + char *fn = NO_TEXT; + /* Skip to filename. */ + while (ISALPHA (v[0])) + v++; + while (ISSPACE (v[0])) + v++; + /* Scan quoted filename. */ + SCAN_ERROR ((v[0] != QUOTE_CHAR && v[0] != '\''), start_l, start_c, + "incorrect filename"); + delim = (v++)[0]; + n = 0; + fnb[0] = NULL_CHAR; + /* Scan Algol 68 string (note: "" denotes a ", while in C it + concatenates). */ + do + { + SCAN_ERROR (EOL (v[0]), start_l, start_c, + "incorrect filename"); + SCAN_ERROR (n == BUFFER_SIZE - 1, start_l, start_c, + "incorrect filename"); + if (v[0] == delim) + { + while (v[0] == delim && v[1] == delim) + { + SCAN_ERROR (n == BUFFER_SIZE - 1, start_l, start_c, + "incorrect filename"); + fnb[n++] = delim; + fnb[n] = NULL_CHAR; + v += 2; + } + } + else if (ISPRINT (v[0])) + { + fnb[n++] = *(v++); + fnb[n] = NULL_CHAR; + } + else + { + SCAN_ERROR (true, start_l, start_c, + "incorrect filename"); + } + } + while (v[0] != delim); + + /* Insist that the pragmat is closed properly. */ + v = &v[1]; + SCAN_ERROR (!skip_pragmat (&u, &v, pr_lim, true), start_l, start_c, + "unterminated pragmat"); + SCAN_ERROR (n == 0, start_l, start_c, + "incorrect filename"); + + char *sourcefile = NO_TEXT; + if (FILENAME (u) != NO_TEXT) + { + sourcefile = xstrdup (FILENAME (u)); + } + else + { + sourcefile = (char *) xmalloc (2); + a68_bufcpy (sourcefile, ".", 1); + } + fn = find_include_file (sourcefile, fnb); + free (sourcefile); + + /* Do not check errno, since errno may be undefined here + after a successful call. */ + if (fn != NO_TEXT) + a68_bufcpy (fnb, fn, BUFFER_SIZE); + else + { + SCAN_ERROR (true, start_l, start_c, + "included file not found"); + } + size_t fnwid = (int) strlen (fnb) + 1; + fn = (char *) xmalloc ((size_t) fnwid); + a68_bufcpy (fn, fnb, fnwid); + + /* Ignore the file when included more than once. */ + for (t = top; t != NO_LINE; t = NEXT (t)) + { + if (strcmp (FILENAME (t), fn) == 0) + goto search_next_pragmat; + } + t = NO_LINE; + + /* Access the file. */ + errno = 0; + fp = fopen (fn, "r"); + SCAN_ERROR (fp == NULL, start_l, start_c, + "error opening included file"); + fd = fileno (fp); + errno = 0; + off_t off = lseek (fd, 0, SEEK_END); + gcc_assert (off >= 0); + fsize = (size_t) off; + SCAN_ERROR (errno != 0, start_l, start_c, + "error while reading file"); + fbuf = (char *) xmalloc (8 + fsize); + errno = 0; + if (lseek (fd, 0, SEEK_SET) < 0) + gcc_unreachable (); + SCAN_ERROR (errno != 0, start_l, start_c, + "error while reading file"); + errno = 0; + bytes_read = (int) io_read (fp, fbuf, (size_t) fsize); + SCAN_ERROR (errno != 0 || (size_t) bytes_read != fsize, start_l, start_c, + "error while reading file"); + + /* Buffer still usable?. */ + if (fsize > A68_PARSER (max_scan_buf_length)) + { + A68_PARSER (max_scan_buf_length) = fsize; + A68_PARSER (scan_buf) = (char *) xmalloc (8 + A68_PARSER (max_scan_buf_length)); + } + + /* Link all lines into the list. */ + linum = 1; + s = u; + t = PREVIOUS (u); + k = 0; + if (fsize == 0) + { + /* If file is empty, insert single empty line. */ + A68_PARSER (scan_buf)[0] = NEWLINE_CHAR; + A68_PARSER (scan_buf)[1] = NULL_CHAR; + append_source_line (A68_PARSER (scan_buf), &t, &linum, fn); + } + else + { + while (k < fsize) + { + n = 0; + A68_PARSER (scan_buf)[0] = NULL_CHAR; + while (k < fsize && fbuf[k] != NEWLINE_CHAR) + { + SCAN_ERROR ((ISCNTRL (fbuf[k]) && !ISSPACE (fbuf[k])) + || fbuf[k] == STOP_CHAR, + start_l, start_c, + "invalid characters in included file"); + A68_PARSER (scan_buf)[n++] = fbuf[k++]; + A68_PARSER (scan_buf)[n] = NULL_CHAR; + } + A68_PARSER (scan_buf)[n++] = NEWLINE_CHAR; + A68_PARSER (scan_buf)[n] = NULL_CHAR; + if (k < fsize) + k++; + append_source_line (A68_PARSER (scan_buf), &t, &linum, fn); + } + } + + /* Conclude and go find another include directive, if any. */ + NEXT (t) = s; + PREVIOUS (s) = t; + concatenate_lines (top); + if (fclose (fp) != 0) + gcc_unreachable (); + make_pass = true; + } + search_next_pragmat: + { (void) 0; }; + } + } +} + +/* Handle a pragment (pragmat or comment). */ + +static char * +pragment (int type, LINE_T **ref_l, char **ref_c) +{ +#define INIT_BUFFER \ + do \ + { \ + chars_in_buf = 0; \ + A68_PARSER (scan_buf)[chars_in_buf] = '\0'; \ + } \ + while (0) + +#define ADD_ONE_CHAR(CH) \ + do \ + { \ + A68_PARSER (scan_buf)[chars_in_buf ++] = (CH); \ + A68_PARSER (scan_buf)[chars_in_buf] = '\0'; \ + } \ + while (0) + + const char *term_s = NO_TEXT; + const char *beg_s = NO_TEXT; + char c = **ref_c, *start_c = *ref_c; + char *z = NO_TEXT; + LINE_T *start_l = *ref_l; + int beg_s_length, term_s_length, chars_in_buf; + bool stop, pragmat = false; + + /* Set terminator to look for. */ + if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) + { + if (type == STYLE_I_COMMENT_SYMBOL) + term_s = "CO"; + else if (type == STYLE_II_COMMENT_SYMBOL) + term_s = "#"; + else if (type == BOLD_COMMENT_SYMBOL) + term_s = "COMMENT"; + else if (type == BOLD_COMMENT_BEGIN_SYMBOL) + { + beg_s = "NOTE"; + term_s = "ETON"; + } + else if (type == BRIEF_COMMENT_BEGIN_SYMBOL) + { + beg_s = "{"; + term_s = "}"; + } + else if (type == STYLE_I_PRAGMAT_SYMBOL) + { + term_s = "PR"; + pragmat = true; + } + else if (type == BOLD_PRAGMAT_SYMBOL) + { + term_s = "PRAGMAT"; + pragmat = true; + } + } + else + { + /* SUPPER stropping. */ + if (type == STYLE_I_COMMENT_SYMBOL) + term_s = "co"; + else if (type == STYLE_II_COMMENT_SYMBOL) + term_s = "#"; + else if (type == BOLD_COMMENT_SYMBOL) + term_s = "comment"; + else if (type == BOLD_COMMENT_BEGIN_SYMBOL) + { + beg_s = "note"; + term_s = "eton"; + } + else if (type == BRIEF_COMMENT_BEGIN_SYMBOL) + { + beg_s = "{"; + term_s = "}"; + } + else if (type == STYLE_I_PRAGMAT_SYMBOL) + { + term_s = "pr"; + pragmat = true; + } + else if (type == BOLD_PRAGMAT_SYMBOL) + { + term_s = "pragmat"; + pragmat = true; + } + } + + beg_s_length = (beg_s != NO_TEXT ? (int) strlen (beg_s) : 0); + term_s_length = (int) strlen (term_s); + + /* Scan for terminator. */ + bool nestable_comment = (beg_s != NO_TEXT); + int nesting_level = 1; + INIT_BUFFER; + stop = false; + while (stop == false) + { + SCAN_ERROR (c == STOP_CHAR, start_l, start_c, + "unterminated pragment"); + + /* A ".." or '..' delimited string in a PRAGMAT, or + a ".." in a nestable comment. */ + if ((pragmat && (c == QUOTE_CHAR || c == '\'')) + || (nestable_comment && c == QUOTE_CHAR)) + { + char delim = c; + bool eos = false; + ADD_ONE_CHAR (c); + c = next_char (ref_l, ref_c, false); + while (!eos) + { + SCAN_ERROR (EOL (c), start_l, start_c, + "string within pragment exceeds end of line"); + + if (c == delim) + { + ADD_ONE_CHAR (delim); + save_state (*ref_l, *ref_c, c); + c = next_char (ref_l, ref_c, false); + if (c == delim) + c = next_char (ref_l, ref_c, false); + else + { + restore_state (ref_l, ref_c, &c); + eos = true; + } + } + else if (ISPRINT (c)) + { + ADD_ONE_CHAR (c); + c = next_char (ref_l, ref_c, false); + } + else + unworthy (start_l, start_c, c); + } + } + else if (EOL (c)) + ADD_ONE_CHAR (NEWLINE_CHAR); + else if (ISPRINT (c) || ISSPACE (c)) + ADD_ONE_CHAR (c); + + if (nestable_comment && chars_in_buf >= beg_s_length) + { + /* If we find another instance of the nestable begin mark, bump the + nesting level and continue scanning. */ + if (strcmp (beg_s, + &(A68_PARSER (scan_buf)[chars_in_buf - beg_s_length])) == 0) + { + nesting_level += 1; + goto nextchar; + } + } + + if (chars_in_buf >= term_s_length) + { + /* Check whether we encountered the terminator. Mind nesting if + necessary. */ + if (strcmp (term_s, + &(A68_PARSER (scan_buf)[chars_in_buf - term_s_length])) == 0) + { + if (nestable_comment) + { + gcc_assert (nesting_level > 0); + nesting_level -= 1; + stop = (nesting_level == 0); + } + else + stop = true; + } + } + + nextchar: + c = next_char (ref_l, ref_c, false); + } + + A68_PARSER (scan_buf)[chars_in_buf - term_s_length] = '\0'; + z = a68_new_string (term_s, A68_PARSER (scan_buf), term_s, NO_TEXT); + return z; +#undef ADD_ONE_CHAR +#undef INIT_BUFFER +} + +/* Whether input shows exponent character. */ + +static bool +is_exp_char (LINE_T **ref_l, char **ref_s, char *ch) +{ + bool ret = false; + + char exp_syms[3]; + + /* Note that this works for both UPPER and SUPPER stropping regimes. */ + exp_syms[0] = EXPONENT_CHAR; + exp_syms[1] = TOUPPER (EXPONENT_CHAR); + exp_syms[2] = '\0'; + + save_state (*ref_l, *ref_s, *ch); + if (strchr (exp_syms, *ch) != NO_TEXT) + { + *ch = next_char (ref_l, ref_s, true); + ret = (strchr ("+-0123456789", *ch) != NO_TEXT); + } + restore_state (ref_l, ref_s, ch); + return ret; +} + +/* Whether input shows radix character. */ + +static bool +is_radix_char (LINE_T **ref_l, char **ref_s, char *ch) +{ + bool ret = false; + + save_state (*ref_l, *ref_s, *ch); + /* Note that this works for both UPPER and SUPPER stropping regimes. */ + if (*ch == RADIX_CHAR) + { + *ch = next_char (ref_l, ref_s, true); + ret = (strchr ("0123456789abcdef", *ch) != NO_TEXT); + } + restore_state (ref_l, ref_s, ch); + return ret; +} + +/* Whether input shows decimal point. */ + +static bool +is_decimal_point (LINE_T **ref_l, char **ref_s, char *ch) +{ + bool ret = false; + + save_state (*ref_l, *ref_s, *ch); + if (*ch == POINT_CHAR) + { + char exp_syms[3]; + + /* Note that this works for both UPPER and SUPPER stropping regimes. */ + exp_syms[0] = EXPONENT_CHAR; + exp_syms[1] = TOUPPER (EXPONENT_CHAR); + exp_syms[2] = '\0'; + + *ch = next_char (ref_l, ref_s, true); + if (strchr (exp_syms, *ch) != NO_TEXT) + { + *ch = next_char (ref_l, ref_s, true); + ret = (strchr ("+-0123456789", *ch) != NO_TEXT); + } + else + ret = (strchr ("0123456789", *ch) != NO_TEXT); + } + restore_state (ref_l, ref_s, ch); + return ret; +} + +/* Attribute for format item. */ + +static enum a68_attribute +get_format_item (char ch) +{ + switch (TOLOWER (ch)) + { + case 'a': + return FORMAT_ITEM_A; + case 'b': + return FORMAT_ITEM_B; + case 'c': + return FORMAT_ITEM_C; + case 'd': + return FORMAT_ITEM_D; + case 'e': + return FORMAT_ITEM_E; + case 'f': + return FORMAT_ITEM_F; + case 'g': + return FORMAT_ITEM_G; + case 'h': + return FORMAT_ITEM_H; + case 'i': + return FORMAT_ITEM_I; + case 'j': + return FORMAT_ITEM_J; + case 'k': + return FORMAT_ITEM_K; + case 'l': + case '/': + return FORMAT_ITEM_L; + case 'm': + return FORMAT_ITEM_M; + case 'n': + return FORMAT_ITEM_N; + case 'o': + return FORMAT_ITEM_O; + case 'p': + return FORMAT_ITEM_P; + case 'q': + return FORMAT_ITEM_Q; + case 'r': + return FORMAT_ITEM_R; + case 's': + return FORMAT_ITEM_S; + case 't': + return FORMAT_ITEM_T; + case 'u': + return FORMAT_ITEM_U; + case 'v': + return FORMAT_ITEM_V; + case 'w': + return FORMAT_ITEM_W; + case 'x': + return FORMAT_ITEM_X; + case 'y': + return FORMAT_ITEM_Y; + case 'z': + return FORMAT_ITEM_Z; + case '+': + return FORMAT_ITEM_PLUS; + case '-': + return FORMAT_ITEM_MINUS; + case POINT_CHAR: + return FORMAT_ITEM_POINT; + case '%': + return FORMAT_ITEM_ESCAPE; + default: + return STOP; + } +} + +/* Get next token from internal copy of source file. + + The kind of token is set via the passed pointer ATTR. + The contents of token is set in the scan_buf via SYM. + + The recognized tokens are, by reported ATTR: + + + End of file. + FORMAT_ITEM_* + Item in a format. + STATIC_REPLICATOR + INT denotation for a static replicator in a format. + BOLD_TAG + Bold tag. + IDENTIFIER + A "lower case" identifier. + IDENTIFIER_WITH_UNDERSCORES + A "lower case" identifier whose's at least one taggle + was found adjacent to an underscore. + REAL_DENOTATION + A REAL denotation. + POINT_SYMBOL + . + BITS_DENOTATION + A BITS denotation like 16rffff + INT_DENOTATION + An INT denotation. + ROW_CHAR_DENOTATION + A STRING denotation. + LITERAL + A literal denotation in a format. + STOP + Single-character symbols #$()[]{},;@|: + := /= :=: :/=: + The character is placed in SYM. + EQUALS_SYMBOL + The equality symbol. + OPERATOR + A predefined operator. +*/ + +static void +get_next_token (bool in_format, + LINE_T **ref_l, char **ref_s, + LINE_T **start_l, char **start_c, enum a68_attribute *att) +{ + char c = **ref_s; + char *sym = A68_PARSER (scan_buf); + + sym[0] = '\0'; + get_good_char (&c, ref_l, ref_s); + *start_l = *ref_l; + *start_c = *ref_s; + if (c == STOP_CHAR) + { + /* We are at EOF. */ + (sym++)[0] = STOP_CHAR; + sym[0] = '\0'; + return; + } + + if (in_format) + { + /* In a format. */ + const char *format_items = "/%\\+-.abcdefghijklmnopqrstuvwxyz"; + if (strchr (format_items, c) != NO_TEXT) + { + /* General format items. */ + (sym++)[0] = c; + sym[0] = NULL_CHAR; + *att = get_format_item (c); + (void) next_char (ref_l, ref_s, false); + return; + } + if (ISDIGIT (c)) + { + /* INT denotation for static replicator. */ + SCAN_DIGITS (c); + sym[0] = NULL_CHAR; + *att = STATIC_REPLICATOR; + return; + } + } + + if (ISUPPER (c)) + { + /* Bold taggles are enabled only in gnu68. */ + bool allow_one_under = !OPTION_STRICT (&A68_JOB); + + if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) + { + /* In UPPER stropping a bold tag is an upper case word. */ + while (ISUPPER (c)) + { + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false, allow_one_under); + } + sym[0] = '\0'; + *att = BOLD_TAG; + } + else + { + /* In SUPPER stropping a bold tag is a capitalized word that may + contain letters and digits. */ + while (ISALPHA (c) || ISDIGIT (c)) + { + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false, allow_one_under); + } + sym[0] = '\0'; + *att = BOLD_TAG; + } + } + else if (ISLOWER (c)) + { + /* In both UPPER and SUPPER stropping regimes a tag is a lower case word + which may contain letters and digits. + + In SUPPER stropping, however, it is not allowed to have blanks + separating the taggles within tags. */ + + bool allow_one_under = true; + bool found_under = false; + bool allow_typo = OPTION_STROPPING (&A68_JOB) != SUPPER_STROPPING; + + /* Lower case word - identifier. */ + while (ISLOWER (c) || ISDIGIT (c)) + { + (sym++)[0] = c; + c = next_char (ref_l, ref_s, allow_typo, allow_one_under, + &found_under); + } + + sym[0] = '\0'; + *att = found_under ? IDENTIFIER_WITH_UNDERSCORES : IDENTIFIER; + } + else if (c == POINT_CHAR) + { + /* Begins with a point symbol - point, L REAL denotation. */ + if (is_decimal_point (ref_l, ref_s, &c)) + { + (sym++)[0] = '0'; + (sym++)[0] = POINT_CHAR; + c = next_char (ref_l, ref_s, true); + SCAN_DIGITS (c); + if (is_exp_char (ref_l, ref_s, &c)) + SCAN_EXPONENT_PART (c); + sym[0] = '\0'; + *att = REAL_DENOTATION; + } + else + { + c = next_char (ref_l, ref_s, true); + (sym++)[0] = POINT_CHAR; + sym[0] = '\0'; + *att = POINT_SYMBOL; + } + } + else if (ISDIGIT (c)) + { + /* Something that begins with a digit: + L INT denotation, L REAL denotation. */ + SCAN_DIGITS (c); + + if (is_decimal_point (ref_l, ref_s, &c)) + { + c = next_char (ref_l, ref_s, true); + if (is_exp_char (ref_l, ref_s, &c)) + { + (sym++)[0] = POINT_CHAR; + (sym++)[0] = '0'; + SCAN_EXPONENT_PART (c); + *att = REAL_DENOTATION; + } + else + { + (sym++)[0] = POINT_CHAR; + SCAN_DIGITS (c); + if (is_exp_char (ref_l, ref_s, &c)) + SCAN_EXPONENT_PART (c); + *att = REAL_DENOTATION; + } + } + else if (is_exp_char (ref_l, ref_s, &c)) + { + SCAN_EXPONENT_PART (c); + *att = REAL_DENOTATION; + } + else if (is_radix_char (ref_l, ref_s, &c)) + { + (sym++)[0] = c; + c = next_char (ref_l, ref_s, true); + /* This is valid for both UPPER and SUPPER stropping. */ + while (ISDIGIT (c) || strchr ("abcdef", c) != NO_TEXT) + { + (sym++)[0] = c; + c = next_char (ref_l, ref_s, true); + } + *att = BITS_DENOTATION; + } + else + { + *att = INT_DENOTATION; + } + sym[0] = '\0'; + } + else if (c == QUOTE_CHAR) + { + /* STRING denotation. */ + bool stop = false; + + while (!stop) + { + c = next_char (ref_l, ref_s, false); + while (c != QUOTE_CHAR && c != STOP_CHAR) + { + if (c == APOSTROPHE_CHAR) + { + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false); + switch (c) + { + case APOSTROPHE_CHAR: + case 'n': + case 'f': + case 'r': + case 't': + (sym++)[0] = c; + break; + case '(': + { + unsigned int num_code_points = 0; + + (sym++)[0] = c; + /* Process code points. */ + while (1) + { + /* Skip white spaces. */ + while (1) + { + c = next_char (ref_l, ref_s, false); + if (!ISSPACE (c)) + break; + } + + /* See if we are done. */ + if (c == ')') + { + SCAN_ERROR (num_code_points == 0, *start_l, *ref_s, + "expected at least one character point in string break"); + (sym++)[0] = c; + break; + } + else if (c == 'u' || c == 'U') + { + (sym++)[0] = c; + /* Process a code point. */ + char u = c; + int numdigits = (u == 'u' ? 4 : 8); + char *startpos = *ref_s; + int i = 0; + do + { + c = next_char (ref_l, ref_s, false); + if (!(ISDIGIT (c) + || ((c >= 'a') && (c <= 'f')) + || ((c >= 'A') && (c <= 'F')))) + { + SCAN_ERROR (true, *start_l, startpos, + (u == 'u' + ? "expected four hex digits in \ +string break character point" + : "expected eight hex digits in \ +string break character point")); + } + (sym++)[0] = c; + i += 1; + } + while (i < numdigits); + + /* Skip white spaces. */ + while (1) + { + c = next_char (ref_l, ref_s, false); + if (!ISSPACE (c)) + break; + } + + /* Comma or end of list. */ + if (c == ')') + { + (sym++)[0] = c; + break; + } + + SCAN_ERROR (c != ',', *start_l, *ref_s, + "expected , or ) in string break"); + } + else + { + SCAN_ERROR (true, *start_l, *ref_s, + "unterminated list of character codes"); + } + } + break; + } + default: + SCAN_ERROR (true, *start_l, *ref_s, "invalid string break sequence"); + } + } + else + { + SCAN_ERROR (EOL (c), *start_l, *start_c, "string exceeds end of line"); + (sym++)[0] = c; + } + c = next_char (ref_l, ref_s, false); + } + SCAN_ERROR (*ref_l == NO_LINE, *start_l, *start_c, "unterminated string"); + c = next_char (ref_l, ref_s, false); + if (c == QUOTE_CHAR) + (sym++)[0] = QUOTE_CHAR; + else + stop = true; + } + sym[0] = '\0'; + *att = (in_format ? LITERAL : ROW_CHAR_DENOTATION); + } + else if (strchr ("#$()[]{},;@", c) != NO_TEXT) + { + /* Single character symbols. */ + (sym++)[0] = c; + (void) next_char (ref_l, ref_s, false); + sym[0] = '\0'; + *att = STOP; + } + else if (c == '|') + { + /* Bar. */ + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false); + if (c == ':') + { + (sym++)[0] = c; + (void) next_char (ref_l, ref_s, false); + } + sym[0] = '\0'; + *att = STOP; + } + else if (c == ':') + { + /* Colon, semicolon, IS, ISNT. */ + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false); + if (c == '=') + { + (sym++)[0] = c; + if ((c = next_char (ref_l, ref_s, false)) == ':') + { + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false); + } + } + else if (c == '/') + { + (sym++)[0] = c; + if ((c = next_char (ref_l, ref_s, false)) == '=') + { + (sym++)[0] = c; + if ((c = next_char (ref_l, ref_s, false)) == ':') + { + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false); + } + } + } + else if (c == ':') + { + (sym++)[0] = c; + if ((c = next_char (ref_l, ref_s, false)) == '=') + (sym++)[0] = c; + } + + sym[0] = '\0'; + *att = STOP; + + } + else if (c == '=') + { + /* Operator starting with "=". */ + char *scanned = sym; + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false); + if (strchr (NOMADS, c) != NO_TEXT) + { + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false); + } + if (c == '=') + { + (sym++)[0] = c; + if (next_char (ref_l, ref_s, false) == ':') + { + (sym++)[0] = ':'; + c = next_char (ref_l, ref_s, false); + if (strlen (sym) < 4 && c == '=') + { + (sym++)[0] = '='; + (void) next_char (ref_l, ref_s, false); + } + } + } + else if (c == ':') + { + (sym++)[0] = c; + sym[0] = '\0'; + if (next_char (ref_l, ref_s, false) == '=') + { + (sym++)[0] = '='; + (void) next_char (ref_l, ref_s, false); + } + else + { + SCAN_ERROR (!(strcmp (scanned, "=:") == 0 || strcmp (scanned, "==:") == 0), + *start_l, *start_c, "invalid operator tag"); + } + } + sym[0] = '\0'; + if (strcmp (scanned, "=") == 0) + *att = EQUALS_SYMBOL; + else + *att = OPERATOR; + } + else if (strchr (MONADS, c) != NO_TEXT || strchr (NOMADS, c) != NO_TEXT) + { + /* Operator. */ + char *scanned = sym; + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false); + if (strchr (NOMADS, c) != NO_TEXT) + { + (sym++)[0] = c; + c = next_char (ref_l, ref_s, false); + } + if (c == '=') + { + (sym++)[0] = c; + if (next_char (ref_l, ref_s, false) == ':') + { + (sym++)[0] = ':'; + c = next_char (ref_l, ref_s, false); + if (strlen (scanned) < 4 && c == '=') + { + (sym++)[0] = '='; + (void) next_char (ref_l, ref_s, false); + } + } + } + else if (c == ':') + { + (sym++)[0] = c; + sym[0] = '\0'; + if (next_char (ref_l, ref_s, false) == '=') + { + (sym++)[0] = '='; + sym[0] = '\0'; + (void) next_char (ref_l, ref_s, false); + } + else + { + SCAN_ERROR (strcmp (&(scanned[1]), "=:") != 0, + *start_l, *start_c, "invalid operator tag"); + } + } + sym[0] = '\0'; + *att = OPERATOR; + } + else + { + /* Afuuus ... strange characters!. */ + unworthy (*start_l, *start_c, (int) c); + } +} + +/* Whether att opens an embedded clause. */ + +static bool +open_nested_clause (int att) +{ + switch (att) + { + case OPEN_SYMBOL: + case BEGIN_SYMBOL: + case PAR_SYMBOL: + case IF_SYMBOL: + case CASE_SYMBOL: + case FOR_SYMBOL: + case FROM_SYMBOL: + case BY_SYMBOL: + case TO_SYMBOL: + case WHILE_SYMBOL: + case DO_SYMBOL: + case SUB_SYMBOL: + return true; + } + return false; +} + +/* Whether att closes an embedded clause. */ + +static bool +close_nested_clause (int att) +{ + switch (att) + { + case CLOSE_SYMBOL: + case END_SYMBOL: + case FI_SYMBOL: + case ESAC_SYMBOL: + case OD_SYMBOL: + case BUS_SYMBOL: + return true; + } + return false; +} + +/* Cast a string to lower case. */ + +static void +make_lower_case (char *p) +{ + for (; p != NO_TEXT && p[0] != '\0'; p++) + p[0] = TOLOWER (p[0]); +} + +/* Cast a string to upper case. */ + +static void +make_upper_case (char *p) +{ + for (; p != NO_TEXT && p[0] != '\0'; p++) + p[0] = TOUPPER (p[0]); +} + +/* Construct a linear list of tokens. */ + +static void +tokenise_source (NODE_T **root, int level, bool in_format, + LINE_T **l, char **s, LINE_T **start_l, + char **start_c) +{ + char *pragmat_lpr = NO_TEXT; + int pragmat_lprt = 0; + LINE_T *pragmat_lprl = NO_LINE; + char *pragmat_lprc = NULL; + + char *comment_lpr = NO_TEXT; + int comment_lprt = 0; + LINE_T *comment_lprl = NO_LINE; + char *comment_lprc = NULL; + + while (l != NO_VAR && !A68_PARSER (stop_scanner)) + { + enum a68_attribute att = STOP; + get_next_token (in_format, l, s, start_l, start_c, &att); + + if (A68_PARSER (scan_buf)[0] == STOP_CHAR) + A68_PARSER (stop_scanner) = true; + else if (strlen (A68_PARSER (scan_buf)) > 0 || att == ROW_CHAR_DENOTATION || att == LITERAL) + { + KEYWORD_T *kw; + const char *c = NO_TEXT; + bool make_node = true; + const char *trailing = NO_TEXT; + + if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) + { + /* In UPPER stropping all symbols in R9.4.1 are expressed as bold + tags like "BEGIN", or symbols like "@". */ + + /* In this stropping regime there is no need to handle + identifiers for which taggles were adjacent to underscores + specially. */ + if (att != IDENTIFIER && att != IDENTIFIER_WITH_UNDERSCORES) + kw = a68_find_keyword (A68 (top_keyword), A68_PARSER (scan_buf)); + else + kw = NO_KEYWORD; + } + else + { + /* In SUPPER stropping all symbols in R9.4.1 are expressed as + tags like "begin", or symbols like "@". */ + + /* Normalize bold tags to all upper-case letters. */ + if (att == BOLD_TAG) + make_upper_case (A68_PARSER (scan_buf)); + + /* If any of the taggles of the scanned identifier were adjacent + to an underscore, that inhibits interpreting it as a + keyword. */ + if (att != BOLD_TAG && att != IDENTIFIER_WITH_UNDERSCORES) + kw = a68_find_keyword (A68 (top_keyword), A68_PARSER (scan_buf)); + else + kw = NO_KEYWORD; + } + + /* Beyond this point it is irrelevant whether an identifier had + taggles adjacent to an underscore. */ + if (att == IDENTIFIER_WITH_UNDERSCORES) + att = IDENTIFIER; + + if (kw == NO_KEYWORD || att == ROW_CHAR_DENOTATION) + { + if (att == IDENTIFIER) + make_lower_case (A68_PARSER (scan_buf)); + if (att != ROW_CHAR_DENOTATION && att != LITERAL) + { + size_t len = strlen (A68_PARSER (scan_buf)); + while (len >= 1 && A68_PARSER (scan_buf)[len - 1] == '_') + { + trailing = "_"; + A68_PARSER (scan_buf)[len - 1] = NULL_CHAR; + len--; + } + } + c = TEXT (a68_add_token (&A68 (top_token), A68_PARSER (scan_buf))); + } + else + { + if (IS (kw, TO_SYMBOL)) + { + /* Merge GO and TO to GOTO. */ + if (*root != NO_NODE && IS (*root, GO_SYMBOL)) + { + ATTRIBUTE (*root) = GOTO_SYMBOL; + NSYMBOL (*root) = TEXT (a68_find_keyword (A68 (top_keyword), "GOTO")); + make_node = false; + } + else + { + att = ATTRIBUTE (kw); + c = TEXT (kw); + } + } + else + { + if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING) + { + if (att == 0 || att == BOLD_TAG) + att = ATTRIBUTE (kw); + } + else + { + if (att == 0 || att == IDENTIFIER) + att = ATTRIBUTE (kw); + } + + c = TEXT (kw); + /* Handle pragments. */ + if (att == STYLE_II_COMMENT_SYMBOL + || att == STYLE_I_COMMENT_SYMBOL + || att == BOLD_COMMENT_SYMBOL + || att == BOLD_COMMENT_BEGIN_SYMBOL + || att == BRIEF_COMMENT_BEGIN_SYMBOL) + { + char *nlpr = pragment (ATTRIBUTE (kw), l, s); + + if (comment_lpr == NO_TEXT + || (int) strlen (comment_lpr) == 0) + comment_lpr = nlpr; + else + { + char *stale = comment_lpr; + comment_lpr + = a68_new_string (comment_lpr, "n\n", nlpr, NO_TEXT); + free (stale); + } + comment_lprt = att; + comment_lprl = *start_l; + comment_lprc = *start_c; + make_node = false; + } + else if (att == STYLE_I_PRAGMAT_SYMBOL + || att == BOLD_PRAGMAT_SYMBOL) + { + char *nlpr = pragment (ATTRIBUTE (kw), l, s); + if (pragmat_lpr == NO_TEXT + || (int) strlen (pragmat_lpr) == 0) + pragmat_lpr = nlpr; + else + { + char *stale = pragmat_lpr; + pragmat_lpr + = a68_new_string (pragmat_lpr, " ", nlpr, NO_TEXT); + free (stale); + } + pragmat_lprt = att; + pragmat_lprl = *start_l; + pragmat_lprc = *start_c; + if (!A68_PARSER (stop_scanner)) + make_node = false; + } + } + } + /* Add token to the tree. */ + if (make_node) + { + NODE_T *q = a68_new_node (); + INFO (q) = a68_new_node_info (); + + switch (att) + { + case ASSIGN_SYMBOL: + case END_SYMBOL: + case ESAC_SYMBOL: + case OD_SYMBOL: + case OF_SYMBOL: + case FI_SYMBOL: + case CLOSE_SYMBOL: + case BUS_SYMBOL: + case COLON_SYMBOL: + case COMMA_SYMBOL: + case SEMI_SYMBOL: + GINFO (q) = NO_GINFO; + break; + default: + GINFO (q) = a68_new_genie_info (); + break; + } + + STATUS (q) = (STATUS_MASK_T) 0; + LINE (INFO (q)) = *start_l; + CHAR_IN_LINE (INFO (q)) = *start_c; + PRIO (INFO (q)) = 0; + PROCEDURE_LEVEL (INFO (q)) = 0; + ATTRIBUTE (q) = att; + NSYMBOL (q) = c; + PREVIOUS (q) = *root; + SUB (q) = NEXT (q) = NO_NODE; + TABLE (q) = NO_TABLE; + MOID (q) = NO_MOID; + TAX (q) = NO_TAG; + if (pragmat_lpr != NO_TEXT) + { + NPRAGMAT (q) = pragmat_lpr; + NPRAGMAT_TYPE (q) = pragmat_lprt; + NPRAGMAT_LINE (q) = pragmat_lprl; + NPRAGMAT_CHAR_IN_LINE (q) = pragmat_lprc; + pragmat_lpr = NO_TEXT; + pragmat_lprt = 0; + } + if (comment_lpr != NO_TEXT) + { + NCOMMENT (q) = comment_lpr; + NCOMMENT_TYPE (q) = comment_lprt; + NCOMMENT_LINE (q) = comment_lprl; + NCOMMENT_CHAR_IN_LINE (q) = comment_lprc; + comment_lpr = NO_TEXT; + comment_lprt = 0; + } + if (*root != NO_NODE) + NEXT (*root) = q; + if (TOP_NODE (&A68_JOB) == NO_NODE) + TOP_NODE (&A68_JOB) = q; + *root = q; + if (trailing != NO_TEXT) + a68_warning (q, 0, + "ignoring trailing character H in A", + trailing, att); + } + /* Redirection in tokenising formats. The scanner is a recursive-descent type as + to know when it scans a format text and when not. */ + if (in_format && att == FORMAT_DELIMITER_SYMBOL) + return; + else if (!in_format && att == FORMAT_DELIMITER_SYMBOL) + tokenise_source (root, level + 1, true, l, s, start_l, start_c); + else if (in_format && open_nested_clause (att)) + { + NODE_T *z = PREVIOUS (*root); + + if (z != NO_NODE && a68_is_one_of (z, FORMAT_ITEM_N, FORMAT_ITEM_G, FORMAT_ITEM_H, + FORMAT_ITEM_F, STOP)) + { + tokenise_source (root, level, false, l, s, start_l, start_c); + } + else if (att == OPEN_SYMBOL) + ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL; + else if (OPTION_BRACKETS (&A68_JOB) && att == SUB_SYMBOL) + ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL; + } + else if (!in_format && level > 0 && open_nested_clause (att)) + tokenise_source (root, level + 1, false, l, s, start_l, start_c); + else if (!in_format && level > 0 && close_nested_clause (att)) + return; + else if (in_format && att == CLOSE_SYMBOL) + ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL; + else if (OPTION_BRACKETS (&A68_JOB) && in_format && att == BUS_SYMBOL) + ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL; + } + } +} + +/* Tokenise source file, build initial syntax tree. */ + +bool +a68_lexical_analyser (const char *filename) +{ + LINE_T *l = NO_LINE, *start_l = NO_LINE; + char *s = NO_TEXT, *start_c = NO_TEXT; + NODE_T *root = NO_NODE; + + /* Read the source file into lines. */ + if (!read_source_file (filename)) + return false; + + /* Start tokenising. */ + A68_PARSER (stop_scanner) = false; + if ((l = TOP_LINE (&A68_JOB)) != NO_LINE) + s = STRING (l); + tokenise_source (&root, 0, false, &l, &s, &start_l, &start_c); + + /* If the source is a prelude packet then we should remove the prelude and + postlude nodes from the token stream. We distinguish these nodes by + location. + + Yes this is crude and creepy but it works and it is less annoying than not + adding the prelude/postlude in read_source_file and I got other fish to + fry at this moment. Somebody please fix this in a decent way, thanks - + jemarch. */ + + NODE_T *p = TOP_NODE (&A68_JOB); + for (; p != NO_NODE; FORWARD (p)) + { + LINE_T *l = LINE (INFO (p)); + if (strcmp (FILENAME (l), "prelude") != 0) + break; + } + + if (p != NO_NODE && IS (p, MODULE_SYMBOL)) + { + p = TOP_NODE (&A68_JOB); + while (p != NO_NODE) + { + LINE_T *l = LINE (INFO (p)); + if (strcmp (FILENAME (l), "prelude") == 0 + || strcmp (FILENAME (l), "postlude") == 0) + { + if (PREVIOUS (p) != NO_NODE) + NEXT (PREVIOUS (p)) = NEXT (p); + else + TOP_NODE (&A68_JOB) = NEXT (p); + + if (NEXT (p) != NO_NODE) + PREVIOUS (NEXT (p)) = PREVIOUS (p); + + NODE_T *next = NEXT (p); + p = next; + } + else + p = FORWARD (p); + } + } + + /* Note that A68_PARSER (scan_buf) and A68_PARSER (max_scan_buf_length) are + allocated by read_source_line. */ + free (A68_PARSER (scan_buf)); + A68_PARSER (scan_buf) = NULL; + A68_PARSER (max_scan_buf_length) = 0; + return true; +} diff --git a/gcc/algol68/a68-parser-scope.cc b/gcc/algol68/a68-parser-scope.cc new file mode 100644 index 000000000000..ad542ed3a150 --- /dev/null +++ b/gcc/algol68/a68-parser-scope.cc @@ -0,0 +1,986 @@ +/* Static scope checker. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* A static scope checker inspects the source. Note that ALGOL 68 also needs + dynamic scope checking. This phase concludes the parser. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" + +#include "a68.h" + +typedef struct TUPLE_T TUPLE_T; +typedef struct SCOPE_T SCOPE_T; + +struct TUPLE_T +{ + int level; + bool transient; +}; + +struct SCOPE_T +{ + NODE_T *where; + TUPLE_T tuple; + SCOPE_T *next; +}; + +enum { NOT_TRANSIENT = 0, TRANSIENT }; + +static void gather_scopes_for_youngest (NODE_T *, SCOPE_T **); +static void scope_statement (NODE_T *, SCOPE_T **); +static void scope_enclosed_clause (NODE_T *, SCOPE_T **); +static void scope_formula (NODE_T *, SCOPE_T **); +static void scope_routine_text (NODE_T *, SCOPE_T **); + +/* + * Static scope checker. + */ + +/* Scope_make_tuple. */ + +static TUPLE_T +scope_make_tuple (int e, int t) +{ + static TUPLE_T z; + LEVEL (&z) = e; + TRANSIENT (&z) = t; + return z; +} + +/* Link scope information into the list. */ + +static void +scope_add (SCOPE_T **sl, NODE_T *p, TUPLE_T tup) +{ + if (sl != NO_VAR) + { + SCOPE_T *ns = (SCOPE_T *) xmalloc (sizeof (SCOPE_T)); + WHERE (ns) = p; + TUPLE (ns) = tup; + NEXT (ns) = *sl; + *sl = ns; + } +} + +/* Scope_check. */ + +static bool +scope_check (SCOPE_T *top, int mask, int dest) +{ + int errors = 0; + + /* Transient names cannot be stored. */ + if (mask & TRANSIENT) + { + for (SCOPE_T *s = top; s != NO_SCOPE; FORWARD (s)) + { + if (TRANSIENT (&TUPLE (s)) & TRANSIENT) + { + a68_error (WHERE (s), "attempt at storing a transient name"); + STATUS_SET (WHERE (s), SCOPE_ERROR_MASK); + errors++; + } + } + } + + /* Potential scope violations. */ + for (SCOPE_T *s = top; s != NO_SCOPE; FORWARD (s)) + { + if (dest < LEVEL (&TUPLE (s)) && !STATUS_TEST (WHERE (s), SCOPE_ERROR_MASK)) + { + MOID_T *ws = MOID (WHERE (s)); + + if (ws != NO_MOID) + { + if (IS_REF (ws) || IS (ws, PROC_SYMBOL) || IS (ws, FORMAT_SYMBOL) || IS (ws, UNION_SYMBOL)) + a68_warning (WHERE (s), OPT_Wscope, "M A is a potential scope violation", + MOID (WHERE (s)), ATTRIBUTE (WHERE (s))); + } + STATUS_SET (WHERE (s), SCOPE_ERROR_MASK); + errors++; + } + } + return (errors == 0); +} + +/* Scope_check_multiple. */ + +static bool +scope_check_multiple (SCOPE_T *top, int mask, SCOPE_T *dest) +{ + bool no_err = true; + + for (; dest != NO_SCOPE; FORWARD (dest)) + no_err = no_err && scope_check (top, mask, LEVEL (&TUPLE (dest))); + return no_err; +} + +/* Check_identifier_usage. */ + +static void +check_identifier_usage (TAG_T *t, NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, IDENTIFIER) && TAX (p) == t && ATTRIBUTE (MOID (t)) != PROC_SYMBOL) + a68_warning (p, OPT_Wuninitialized, "identifier S might be used uninitialised"); + check_identifier_usage (t, SUB (p)); + } +} + +/* Scope_find_youngest_outside. */ + +static TUPLE_T +scope_find_youngest_outside (SCOPE_T *s, int treshold) +{ + TUPLE_T z = scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT); + + for (; s != NO_SCOPE; FORWARD (s)) + { + if (LEVEL (&TUPLE (s)) > LEVEL (&z) && LEVEL (&TUPLE (s)) <= treshold) + z = TUPLE (s); + } + return z; +} + +/* Scope_find_youngest. */ + +static TUPLE_T +scope_find_youngest (SCOPE_T *s) +{ + return scope_find_youngest_outside (s, INT_MAX); +} + +/* + * Routines for determining scope of ROUTINE TEXT or FORMAT TEXT. + */ + +/* Get_declarer_elements. */ + +static void +get_declarer_elements (NODE_T *p, SCOPE_T **r, bool no_ref) +{ + if (p != NO_NODE) + { + if (IS (p, BOUNDS)) + gather_scopes_for_youngest (SUB (p), r); + else if (IS (p, INDICANT)) + { + if (MOID (p) != NO_MOID && TAX (p) != NO_TAG && HAS_ROWS (MOID (p)) && no_ref) + scope_add (r, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT)); + } + else if (IS_REF (p)) + get_declarer_elements (NEXT (p), r, false); + else if (a68_is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) + ; + else + { + get_declarer_elements (SUB (p), r, no_ref); + get_declarer_elements (NEXT (p), r, no_ref); + } + } +} + +/* Gather_scopes_for_youngest. */ + +static void +gather_scopes_for_youngest (NODE_T *p, SCOPE_T **s) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if ((a68_is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP)) + && (YOUNGEST_ENVIRON (TAX (p)) == PRIMAL_SCOPE)) + { + SCOPE_T *t = NO_SCOPE; + TUPLE_T tup; + + gather_scopes_for_youngest (SUB (p), &t); + tup = scope_find_youngest_outside (t, LEX_LEVEL (p)); + YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup); + /* Direct link into list iso "gather_scopes_for_youngest (SUB (p), + s);". */ + if (t != NO_SCOPE) + { + SCOPE_T *u = t; + while (NEXT (u) != NO_SCOPE) { + FORWARD (u); + } + NEXT (u) = *s; + (*s) = t; + } + } + else if (a68_is_one_of (p, IDENTIFIER, OPERATOR, STOP)) + { + if (TAX (p) != NO_TAG && TAG_LEX_LEVEL (TAX (p)) != PRIMAL_SCOPE) + scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT)); + } + else if (IS (p, DECLARER)) + get_declarer_elements (p, s, true); + else + gather_scopes_for_youngest (SUB (p), s); + } +} + +/* Get_youngest_environs. */ + +static void +get_youngest_environs (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (a68_is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP)) + { + SCOPE_T *s = NO_SCOPE; + TUPLE_T tup; + gather_scopes_for_youngest (SUB (p), &s); + tup = scope_find_youngest_outside (s, LEX_LEVEL (p)); + YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup); + } + else + get_youngest_environs (SUB (p)); + } +} + +/* Bind_scope_to_tag. */ + +static void +bind_scope_to_tag (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, DEFINING_IDENTIFIER) && MOID (p) == M_FORMAT) + { + if (IS (NEXT_NEXT (p), FORMAT_TEXT)) + { + SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p))); + SCOPE_ASSIGNED (TAX (p)) = true; + } + return; + } + else if (IS (p, DEFINING_IDENTIFIER)) + { + if (IS (NEXT_NEXT (p), ROUTINE_TEXT)) + { + SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p))); + SCOPE_ASSIGNED (TAX (p)) = true; + } + return; + } + else + bind_scope_to_tag (SUB (p)); + } +} + +/* Bind_scope_to_tags. */ + +static void +bind_scope_to_tags (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (a68_is_one_of (p, PROCEDURE_DECLARATION, IDENTITY_DECLARATION, STOP)) + bind_scope_to_tag (SUB (p)); + else + bind_scope_to_tags (SUB (p)); + } +} + +/* Scope_bounds. */ + +static void +scope_bounds (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + scope_statement (p, NO_VAR); + else + scope_bounds (SUB (p)); + } +} + +/* Scope_declarer. */ + +static void +scope_declarer (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, BOUNDS)) + scope_bounds (SUB (p)); + else if (IS (p, INDICANT)) + ; + else if (IS_REF (p)) + scope_declarer (NEXT (p)); + else if (a68_is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) + ; + else + { + scope_declarer (SUB (p)); + scope_declarer (NEXT (p)); + } + } +} + +/* Scope_identity_declaration. */ + +static void +scope_identity_declaration (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + scope_identity_declaration (SUB (p)); + + if (IS (p, DEFINING_IDENTIFIER)) + { + NODE_T *unit = NEXT_NEXT (p); + SCOPE_T *s = NO_SCOPE; + TUPLE_T tup; + int z = PRIMAL_SCOPE; + + if (ATTRIBUTE (MOID (TAX (p))) != PROC_SYMBOL) + check_identifier_usage (TAX (p), unit); + scope_statement (unit, &s); + (void) scope_check (s, TRANSIENT, LEX_LEVEL (p)); + tup = scope_find_youngest (s); + z = LEVEL (&tup); + if (z < LEX_LEVEL (p)) + { + SCOPE (TAX (p)) = z; + SCOPE_ASSIGNED (TAX (p)) = true; + } + return; + } + } +} + +/* Scope_variable_declaration. */ + +static void +scope_variable_declaration (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + scope_variable_declaration (SUB (p)); + if (IS (p, DECLARER)) + scope_declarer (SUB (p)); + else if (IS (p, DEFINING_IDENTIFIER)) + { + if (a68_whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) + { + NODE_T *unit = NEXT_NEXT (p); + SCOPE_T *s = NO_SCOPE; + check_identifier_usage (TAX (p), unit); + scope_statement (unit, &s); + (void) scope_check (s, TRANSIENT, LEX_LEVEL (p)); + return; + } + } + } +} + +/* Scope_procedure_declaration. */ + +static void +scope_procedure_declaration (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + scope_procedure_declaration (SUB (p)); + + if (a68_is_one_of (p, DEFINING_IDENTIFIER, DEFINING_OPERATOR, STOP)) + { + NODE_T *unit = NEXT_NEXT (p); + SCOPE_T *s = NO_SCOPE; + + scope_statement (unit, &s); + (void) scope_check (s, NOT_TRANSIENT, LEX_LEVEL (p)); + return; + } + } +} + +/* Scope_declaration_list. */ + +static void +scope_declaration_list (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, IDENTITY_DECLARATION)) + scope_identity_declaration (SUB (p)); + else if (IS (p, VARIABLE_DECLARATION)) + scope_variable_declaration (SUB (p)); + else if (IS (p, MODE_DECLARATION)) + scope_declarer (SUB (p)); + else if (IS (p, PRIORITY_DECLARATION)) + ; + else if (IS (p, PROCEDURE_DECLARATION)) + scope_procedure_declaration (SUB (p)); + else if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) + scope_procedure_declaration (SUB (p)); + else if (a68_is_one_of (p, BRIEF_OPERATOR_DECLARATION, OPERATOR_DECLARATION, STOP)) + scope_procedure_declaration (SUB (p)); + else + { + scope_declaration_list (SUB (p)); + scope_declaration_list (NEXT (p)); + } + } +} + +/* Scope_arguments. */ + +static void +scope_arguments (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + { + SCOPE_T *s = NO_SCOPE; + scope_statement (p, &s); + (void) scope_check (s, TRANSIENT, LEX_LEVEL (p)); + } + else + scope_arguments (SUB (p)); + } +} + +/* Is_coercion. */ + +static bool +is_coercion (NODE_T *p) +{ + if (p != NO_NODE) + { + switch (ATTRIBUTE (p)) + { + case DEPROCEDURING: + case DEREFERENCING: + case UNITING: + case ROWING: + case WIDENING: + case VOIDING: + case PROCEDURING: + return true; + default: + return false; + } + } + else + return false; +} + +/* Scope_coercion. */ + +static void +scope_coercion (NODE_T *p, SCOPE_T **s) +{ + if (is_coercion (p)) + { + if (IS (p, VOIDING)) + scope_coercion (SUB (p), NO_VAR); + else if (IS (p, DEREFERENCING)) + /* Leave this to the dynamic scope checker. */ + scope_coercion (SUB (p), NO_VAR); + else if (IS (p, DEPROCEDURING)) + scope_coercion (SUB (p), NO_VAR); + else if (IS (p, ROWING)) + { + SCOPE_T *z = NO_SCOPE; + + scope_coercion (SUB (p), &z); + (void) scope_check (z, TRANSIENT, LEX_LEVEL (p)); + if (IS_REF_FLEX (MOID (SUB (p)))) + scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); + else + scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT)); + } + else if (IS (p, PROCEDURING)) + { + /* Can only be a JUMP. */ + NODE_T *q = SUB_SUB (p); + if (IS (q, GOTO_SYMBOL)) + FORWARD (q); + + scope_add (s, q, scope_make_tuple (TAG_LEX_LEVEL (TAX (q)), NOT_TRANSIENT)); + } + else if (IS (p, UNITING)) + { + SCOPE_T *z = NO_SCOPE; + + scope_coercion (SUB (p), &z); + if (z != NO_SCOPE) + { + (void) scope_check (z, TRANSIENT, LEX_LEVEL (p)); + scope_add (s, p, scope_find_youngest (z)); + } + } + else + scope_coercion (SUB (p), s); + } + else + scope_statement (p, s); +} + +/* Scope_format_text. */ + +static void +scope_format_text (NODE_T *p, SCOPE_T **s) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, FORMAT_PATTERN)) + scope_enclosed_clause (SUB (NEXT_SUB (p)), s); + else if (IS (p, FORMAT_ITEM_G) && NEXT (p) != NO_NODE) + scope_enclosed_clause (SUB_NEXT (p), s); + else if (IS (p, DYNAMIC_REPLICATOR)) + scope_enclosed_clause (SUB (NEXT_SUB (p)), s); + else + scope_format_text (SUB (p), s); + } +} + +/* Scope_operand. */ + +static void +scope_operand (NODE_T *p, SCOPE_T **s) +{ + if (IS (p, MONADIC_FORMULA)) + scope_operand (NEXT_SUB (p), s); + else if (IS (p, FORMULA)) + scope_formula (p, s); + else if (IS (p, SECONDARY)) + scope_statement (SUB (p), s); +} + +/* Scope_formula. */ + +static void +scope_formula (NODE_T *p, SCOPE_T **s) +{ + NODE_T *q = SUB (p); + SCOPE_T *s2 = NO_SCOPE; + + scope_operand (q, &s2); + (void) scope_check (s2, TRANSIENT, LEX_LEVEL (p)); + if (NEXT (q) != NO_NODE) + { + SCOPE_T *s3 = NO_SCOPE; + scope_operand (NEXT_NEXT (q), &s3); + (void) scope_check (s3, TRANSIENT, LEX_LEVEL (p)); + } + (void) s; +} + +/* Scope_routine_text. */ + +static void +scope_routine_text (NODE_T *p, SCOPE_T **s) +{ + NODE_T *q = SUB (p); + NODE_T *routine = (IS (q, PARAMETER_PACK) ? NEXT (q) : q); + SCOPE_T *x = NO_SCOPE; + + scope_statement (NEXT_NEXT (routine), &x); + (void) scope_check (x, TRANSIENT, LEX_LEVEL (p)); + TUPLE_T routine_tuple = scope_make_tuple (YOUNGEST_ENVIRON (TAX (p)), NOT_TRANSIENT); + scope_add (s, p, routine_tuple); +} + +/* Scope_statement. */ + +static void +scope_statement (NODE_T *p, SCOPE_T **s) +{ + if (is_coercion (p)) + scope_coercion (p, s); + else if (a68_is_one_of (p, PRIMARY, SECONDARY, TERTIARY, UNIT, STOP)) + scope_statement (SUB (p), s); + else if (a68_is_one_of (p, NIHIL, STOP)) + scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); + else if (IS (p, DENOTATION)) + ; + else if (IS (p, IDENTIFIER)) + { + if (IS_REF (MOID (p))) + { + if (PRIO (TAX (p)) == PARAMETER_IDENTIFIER) + scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)) - 1, NOT_TRANSIENT)); + else + { + if (HEAP (TAX (p)) == HEAP_SYMBOL) + scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); + else if (SCOPE_ASSIGNED (TAX (p))) + scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); + else + scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT)); + } + } + else if (ATTRIBUTE (MOID (p)) == PROC_SYMBOL && SCOPE_ASSIGNED (TAX (p)) == true) + scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); + else if (MOID (p) == M_FORMAT && SCOPE_ASSIGNED (TAX (p)) == true) + scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); + } + else if (IS (p, ENCLOSED_CLAUSE)) + scope_enclosed_clause (SUB (p), s); + else if (IS (p, CALL)) + { + SCOPE_T *x = NO_SCOPE; + + scope_statement (SUB (p), &x); + (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); + scope_arguments (NEXT_SUB (p)); + } + else if (IS (p, SLICE)) + { + SCOPE_T *x = NO_SCOPE; + MOID_T *m = MOID (SUB (p)); + + if (IS_REF (m)) + { + if (ATTRIBUTE (SUB (p)) == PRIMARY && ATTRIBUTE (SUB_SUB (p)) == SLICE) + scope_statement (SUB (p), s); + else + { + scope_statement (SUB (p), &x); + (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); + } + if (IS_FLEX (SUB (m))) + scope_add (s, SUB (p), scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); + scope_bounds (SUB (NEXT_SUB (p))); + } + if (IS_REF (MOID (p))) + scope_add (s, p, scope_find_youngest (x)); + } + else if (IS (p, FORMAT_TEXT)) + { + SCOPE_T *x = NO_SCOPE; + scope_format_text (SUB (p), &x); + scope_add (s, p, scope_find_youngest (x)); + } + else if (IS (p, CAST)) + { + SCOPE_T *x = NO_SCOPE; + scope_enclosed_clause (SUB (NEXT_SUB (p)), &x); + (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p)); + scope_add (s, p, scope_find_youngest (x)); + } + else if (IS (p, SELECTION)) + { + SCOPE_T *ns = NO_SCOPE; + scope_statement (NEXT_SUB (p), &ns); + (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (p)); + if (a68_is_ref_refety_flex (MOID (NEXT_SUB (p)))) + scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); + scope_add (s, p, scope_find_youngest (ns)); + } + else if (IS (p, GENERATOR)) + { + if (IS (SUB (p), LOC_SYMBOL)) + { + if (NON_LOCAL (p) != NO_TABLE) + scope_add (s, p, scope_make_tuple (LEVEL (NON_LOCAL (p)), NOT_TRANSIENT)); + else + scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT)); + } + else + scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); + scope_declarer (SUB (NEXT_SUB (p))); + } + else if (IS (p, FORMULA)) + scope_formula (p, s); + else if (IS (p, ASSIGNATION)) + { + NODE_T *unit = NEXT (NEXT_SUB (p)); + SCOPE_T *ns = NO_SCOPE, *nd = NO_SCOPE; + TUPLE_T tup; + scope_statement (SUB_SUB (p), &nd); + scope_statement (unit, &ns); + (void) scope_check_multiple (ns, TRANSIENT, nd); + tup = scope_find_youngest (nd); + scope_add (s, p, scope_make_tuple (LEVEL (&tup), NOT_TRANSIENT)); + } + else if (IS (p, ROUTINE_TEXT)) + scope_routine_text (p, s); + else if (a68_is_one_of (p, IDENTITY_RELATION, AND_FUNCTION, OR_FUNCTION, STOP)) + { + SCOPE_T *n = NO_SCOPE; + scope_statement (SUB (p), &n); + scope_statement (NEXT (NEXT_SUB (p)), &n); + (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p)); + } + else if (IS (p, ASSERTION)) + { + SCOPE_T *n = NO_SCOPE; + scope_enclosed_clause (SUB (NEXT_SUB (p)), &n); + (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p)); + } + else if (a68_is_one_of (p, JUMP, SKIP, STOP)) + { + ; + } +} + +/* Scope_statement_list. */ + +static void +scope_statement_list (NODE_T *p, SCOPE_T **s) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, UNIT)) + scope_statement (p, s); + else + scope_statement_list (SUB (p), s); + } +} + +/* Scope_serial_clause. */ + +static void +scope_serial_clause (NODE_T *p, SCOPE_T **s, bool terminator) +{ + if (p != NO_NODE) + { + if (IS (p, INITIALISER_SERIES)) + { + scope_serial_clause (SUB (p), s, false); + scope_serial_clause (NEXT (p), s, terminator); + } + else if (IS (p, DECLARATION_LIST)) + scope_declaration_list (SUB (p)); + else if (a68_is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) + scope_serial_clause (NEXT (p), s, terminator); + else if (a68_is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP)) + { + if (NEXT (p) != NO_NODE) + { + int j = ATTRIBUTE (NEXT (p)); + if (j == EXIT_SYMBOL || j == END_SYMBOL || j == CLOSE_SYMBOL) + scope_serial_clause (SUB (p), s, true); + else + scope_serial_clause (SUB (p), s, false); + } + else + scope_serial_clause (SUB (p), s, true); + scope_serial_clause (NEXT (p), s, terminator); + } + else if (IS (p, LABELED_UNIT)) + scope_serial_clause (SUB (p), s, terminator); + else if (IS (p, UNIT)) + { + if (terminator) + scope_statement (p, s); + else + scope_statement (p, NO_VAR); + } + } +} + +/* Scope_closed_clause. */ + +static void +scope_closed_clause (NODE_T *p, SCOPE_T **s) +{ + if (p != NO_NODE) + { + if (IS (p, SERIAL_CLAUSE)) + scope_serial_clause (p, s, true); + else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) + scope_closed_clause (NEXT (p), s); + } +} + +/* Scope_collateral_clause. */ + +static void +scope_collateral_clause (NODE_T *p, SCOPE_T **s) +{ + if (p != NO_NODE) + { + if (!(a68_whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) + || a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))) + { + scope_statement_list (p, s); + } + } +} + +/* Scope_conditional_clause. */ + +static void +scope_conditional_clause (NODE_T *p, SCOPE_T **s) +{ + scope_serial_clause (NEXT_SUB (p), NO_VAR, true); + FORWARD (p); + scope_serial_clause (NEXT_SUB (p), s, true); + if ((FORWARD (p)) != NO_NODE) + { + if (a68_is_one_of (p, ELSE_PART, CHOICE, STOP)) + scope_serial_clause (NEXT_SUB (p), s, true); + else if (a68_is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) + scope_conditional_clause (SUB (p), s); + } +} + +/* Scope_case_clause. */ + +static void +scope_case_clause (NODE_T *p, SCOPE_T **s) +{ + SCOPE_T *n = NO_SCOPE; + scope_serial_clause (NEXT_SUB (p), &n, true); + (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p)); + FORWARD (p); + scope_statement_list (NEXT_SUB (p), s); + if ((FORWARD (p)) != NO_NODE) + { + if (a68_is_one_of (p, OUT_PART, CHOICE, STOP)) + scope_serial_clause (NEXT_SUB (p), s, true); + else if (a68_is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) + scope_case_clause (SUB (p), s); + else if (a68_is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) + scope_case_clause (SUB (p), s); + } +} + +/* Scope_loop_clause. */ + +static void +scope_loop_clause (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, FOR_PART)) + scope_loop_clause (NEXT (p)); + else if (a68_is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) + { + scope_statement (NEXT_SUB (p), NO_VAR); + scope_loop_clause (NEXT (p)); + } + else if (IS (p, WHILE_PART)) + { + scope_serial_clause (NEXT_SUB (p), NO_VAR, true); + scope_loop_clause (NEXT (p)); + } + else if (a68_is_one_of (p, DO_PART, ALT_DO_PART, STOP)) + { + NODE_T *do_p = NEXT_SUB (p); + + if (IS (do_p, SERIAL_CLAUSE)) + scope_serial_clause (do_p, NO_VAR, true); + } + } +} + +/* Scope_enclosed_clause. */ + +static void +scope_enclosed_clause (NODE_T *p, SCOPE_T **s) +{ + if (IS (p, ENCLOSED_CLAUSE)) + scope_enclosed_clause (SUB (p), s); + else if (IS (p, CLOSED_CLAUSE)) + scope_closed_clause (SUB (p), s); + else if (a68_is_one_of (p, COLLATERAL_CLAUSE, PARALLEL_CLAUSE, STOP)) + scope_collateral_clause (SUB (p), s); + else if (IS (p, CONDITIONAL_CLAUSE)) + scope_conditional_clause (SUB (p), s); + else if (a68_is_one_of (p, CASE_CLAUSE, CONFORMITY_CLAUSE, STOP)) + scope_case_clause (SUB (p), s); + else if (IS (p, LOOP_CLAUSE)) + scope_loop_clause (SUB (p)); +} + +/* Whether a symbol table contains no (anonymous) definition. */ + +static bool +empty_table (TABLE_T * t) +{ + if (IDENTIFIERS (t) == NO_TAG) + return (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG); + else if (PRIO (IDENTIFIERS (t)) == LOOP_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) + return (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG); + else if (PRIO (IDENTIFIERS (t)) == SPECIFIER_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) + return (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG); + else + return false; +} + +/* Indicate non-local environs. */ + +static void +get_non_local_environs (NODE_T *p, int max) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, ROUTINE_TEXT)) + get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p))); + else if (IS (p, FORMAT_TEXT)) + get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p))); + else + { + get_non_local_environs (SUB (p), max); + NON_LOCAL (p) = NO_TABLE; + if (TABLE (p) != NO_TABLE) + { + TABLE_T *q = TABLE (p); + while (q != NO_TABLE && empty_table (q) + && PREVIOUS (q) != NO_TABLE && LEVEL (PREVIOUS (q)) >= max) + { + NON_LOCAL (p) = PREVIOUS (q); + q = PREVIOUS (q); + } + } + } + } +} + +/* The static scope checker. */ + +void +a68_scope_checker (NODE_T *p) +{ + if (SUB (p)) + { + if (IS (SUB (p), PARTICULAR_PROGRAM)) + p = SUB (p); + else if (IS (SUB (p), PRELUDE_PACKET)) + { + /* XXX writeme. */ + return; + } + } + + /* Establish scopes of routine texts and format texts. */ + get_youngest_environs (p); + /* Find non-local environs. */ + get_non_local_environs (p, PRIMAL_SCOPE); + /* PROC and FORMAT identities can now be assigned a scope. */ + bind_scope_to_tags (p); + /* Now check evertyhing else. */ + scope_enclosed_clause (SUB (p), NO_VAR); +} diff --git a/gcc/algol68/a68-parser-serial-dsa.cc b/gcc/algol68/a68-parser-serial-dsa.cc new file mode 100644 index 000000000000..b48c13da3bf6 --- /dev/null +++ b/gcc/algol68/a68-parser-serial-dsa.cc @@ -0,0 +1,114 @@ +/* Check dynamic stack usage in serial clauses. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* This file implements a phase that determines what serial clauses contain + phrases whose elaboration may involve dynamic stack allocation. It + annotates the SERIAL_CLAUSE parse nodes by setting the DYNAMIC_STACK_ALLOCS + flag. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" + +#include "a68.h" + +/* Uncomment the following line for debugging traces. */ +/* #define SERIAL_DSA_DEBUG */ + +static void +serial_dsa_check_serial_clause (NODE_T *p, bool *dsa) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, GENERATOR)) + { + /* LOC generators always result in dyamic stack allocation regardless + of the mode of the allocated value. */ + if (IS (SUB (p), LOC_SYMBOL)) + { +#ifdef SERIAL_DSA_DEBUG + fprintf (stderr, "serial_dsa: %s:%d: loc generator implies DSA\n", + FILENAME (LINE (INFO (p))), + LINE_NUMBER (p)); +#endif + *dsa = true; + return; + } + } + else if (IS (p, DEFINING_IDENTIFIER)) + { + /* Variable declarations of values with sample loc generators will + result in dynamic stack allocation. + + Note that label declarations do no have a mode, so we have to + check for MOID (p). */ + + if (MOID (p) != NO_MOID && IS_REF (MOID (p))) + { + bool heap = HEAP (TAX (p)) == HEAP_SYMBOL; + if (HAS_ROWS (SUB (MOID (p))) && !heap) + { +#ifdef SERIAL_DSA_DEBUG + fprintf (stderr, + "serial_dsa: %s:%d: defining identifier %s implies DSA\n", + FILENAME (LINE (INFO (p))), + LINE_NUMBER (p), + NSYMBOL (p)); +#endif + *dsa = true; + return; + } + } + } + else + { + /* Inner serial clauses will take care of their own. Code in routine + texts will not impact the stack of the containing serial + clause. */ + if (!IS (p, SERIAL_CLAUSE) && !IS (p, ROUTINE_TEXT)) + serial_dsa_check_serial_clause (SUB (p), dsa); + } + } +} + +void +a68_serial_dsa (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + a68_serial_dsa (SUB (p)); + if (IS (p, SERIAL_CLAUSE)) + { + bool dsa = false; + serial_dsa_check_serial_clause (SUB (p), &dsa); + DYNAMIC_STACK_ALLOCS (p) = dsa; +#ifdef SERIAL_DSA_DEBUG + if (dsa) + { + fprintf (stderr, "serial_dsa: %s:%d: marking serial clause %p as DSA\n", + FILENAME (LINE (INFO (p))), + LINE_NUMBER (p), + (void *) p); + } + +#endif + } + } +} diff --git a/gcc/algol68/a68-parser-taxes.cc b/gcc/algol68/a68-parser-taxes.cc new file mode 100644 index 000000000000..fa9f9471d983 --- /dev/null +++ b/gcc/algol68/a68-parser-taxes.cc @@ -0,0 +1,1806 @@ +/* Symbol table management. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" + +#include "a68.h" + +/* + * Symbol table handling, managing TAGS. + */ + +/* Forward declarations for several functions defined below. */ + +static TAG_T *find_tag_local (TABLE_T *table, int a, const char *name); + +/* Set level for procedures. */ + +void +a68_set_proc_level (NODE_T *p, int n) +{ + for (; p != NO_NODE; FORWARD (p)) + { + PROCEDURE_LEVEL (INFO (p)) = n; + if (IS (p, ROUTINE_TEXT)) + a68_set_proc_level (SUB (p), n + 1); + else + a68_set_proc_level (SUB (p), n); + } +} + +/* Set nests for diagnostics. */ + +void +a68_set_nest (NODE_T *p, NODE_T *s) +{ + for (; p != NO_NODE; FORWARD (p)) + { + NEST (p) = s; + if (IS (p, PARTICULAR_PROGRAM)) + a68_set_nest (SUB (p), p); + else if (IS (p, CLOSED_CLAUSE) && LINE_NUMBER (p) != 0) + a68_set_nest (SUB (p), p); + else if (IS (p, COLLATERAL_CLAUSE) && LINE_NUMBER (p) != 0) + a68_set_nest (SUB (p), p); + else if (IS (p, CONDITIONAL_CLAUSE) && LINE_NUMBER (p) != 0) + a68_set_nest (SUB (p), p); + else if (IS (p, CASE_CLAUSE) && LINE_NUMBER (p) != 0) + a68_set_nest (SUB (p), p); + else if (IS (p, CONFORMITY_CLAUSE) && LINE_NUMBER (p) != 0) + a68_set_nest (SUB (p), p); + else if (IS (p, LOOP_CLAUSE) && LINE_NUMBER (p) != 0) + a68_set_nest (SUB (p), p); + else + a68_set_nest (SUB (p), s); + } +} + +/* + * Routines that work with tags and symbol tables. + */ + +static void tax_tags (NODE_T *); +static void tax_specifier_list (NODE_T *); +static void tax_parameter_list (NODE_T *); +static void tax_format_texts (NODE_T *); + +/* Find a tag, searching symbol tables towards the root. */ + +int +a68_first_tag_global (TABLE_T * table, const char *name) +{ + if (table != NO_TABLE) + { + for (TAG_T *s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + return IDENTIFIER; + } + for (TAG_T *s = INDICANTS (table); s != NO_TAG; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + return INDICANT; + } + for (TAG_T *s = LABELS (table); s != NO_TAG; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + return LABEL; + } + for (TAG_T *s = OPERATORS (table); s != NO_TAG; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + return OP_SYMBOL; + } + for (TAG_T *s = MODULES (table); s != NO_TAG; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + return MODULE_SYMBOL; + } + for (TAG_T *s = PRIO (table); s != NO_TAG; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + return PRIO_SYMBOL; + } + return a68_first_tag_global (PREVIOUS (table), name); + } + else + return STOP; +} + +/* Whether routine can be "lengthety-mapped". */ + +static bool +is_mappable_routine (const char *z) +{ +#define ACCEPT(u, v) {\ + if (strlen (u) >= strlen (v)) {\ + if (strcmp (&u[strlen (u) - strlen (v)], v) == 0) {\ + return true;\ + }}} + + /* Math routines. */ + ACCEPT (z, "arccos"); + ACCEPT (z, "arccosdg"); + ACCEPT (z, "arccot"); + ACCEPT (z, "arccotdg"); + ACCEPT (z, "arcsin"); + ACCEPT (z, "arcsindg"); + ACCEPT (z, "arctan"); + ACCEPT (z, "arctandg"); + ACCEPT (z, "beta"); + ACCEPT (z, "betainc"); + ACCEPT (z, "cbrt"); + ACCEPT (z, "cos"); + ACCEPT (z, "cosdg"); + ACCEPT (z, "cospi"); + ACCEPT (z, "cot"); + ACCEPT (z, "cot"); + ACCEPT (z, "cotdg"); + ACCEPT (z, "cotpi"); + ACCEPT (z, "curt"); + ACCEPT (z, "erf"); + ACCEPT (z, "erfc"); + ACCEPT (z, "exp"); + ACCEPT (z, "gamma"); + ACCEPT (z, "gammainc"); + ACCEPT (z, "gammaincg"); + ACCEPT (z, "gammaincgf"); + ACCEPT (z, "ln"); + ACCEPT (z, "log"); + ACCEPT (z, "pi"); + ACCEPT (z, "sin"); + ACCEPT (z, "sindg"); + ACCEPT (z, "sinpi"); + ACCEPT (z, "sqrt"); + ACCEPT (z, "tan"); + ACCEPT (z, "tandg"); + ACCEPT (z, "tanpi"); + /* Random generator. */ + ACCEPT (z, "nextrandom"); + ACCEPT (z, "random"); + /* BITS. */ + ACCEPT (z, "bitspack"); + /* Enquiries. */ + ACCEPT (z, "maxint"); + ACCEPT (z, "intwidth"); + ACCEPT (z, "maxreal"); + ACCEPT (z, "realwidth"); + ACCEPT (z, "expwidth"); + ACCEPT (z, "maxbits"); + ACCEPT (z, "bitswidth"); + ACCEPT (z, "byteswidth"); + ACCEPT (z, "smallreal"); + return false; +#undef ACCEPT +} + +/* Map "short sqrt" onto "sqrt" etcetera. */ + +static TAG_T * +bind_lengthety_identifier (const char *u) +{ +#define CAR(u, v) (strncmp (u, v, strlen(v)) == 0) + /* We can only map routines blessed by "is_mappable_routine", so there is no + "short print" or "long char in string". */ + if (CAR (u, "short")) + { + do + { + u = &u[strlen ("short")]; + const char *v = TEXT (a68_add_token (&A68 (top_token), u)); + TAG_T *w = find_tag_local (A68_STANDENV, IDENTIFIER, v); + if (w != NO_TAG && is_mappable_routine (v)) + return w; + } + while (CAR (u, "short")); + } + else if (CAR (u, "long")) + { + do + { + u = &u[strlen ("long")]; + const char *v = TEXT (a68_add_token (&A68 (top_token), u)); + TAG_T *w = find_tag_local (A68_STANDENV, IDENTIFIER, v); + if (w != NO_TAG && is_mappable_routine (v)) + return w; + } + while (CAR (u, "long")); + } + + return NO_TAG; +#undef CAR +} + +/* Bind identifier tags to the symbol table. */ + +static void +bind_identifier_tag_to_symbol_table (NODE_T * p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + bind_identifier_tag_to_symbol_table (SUB (p)); + + if (a68_is_one_of (p, IDENTIFIER, DEFINING_IDENTIFIER, STOP)) + { + int att = a68_first_tag_global (TABLE (p), NSYMBOL (p)); + + if (att == STOP) + { + TAG_T *z = bind_lengthety_identifier (NSYMBOL (p)); + + if (z != NO_TAG) + MOID (p) = MOID (z); + TAX (p) = z; + } + else + { + TAG_T *z = a68_find_tag_global (TABLE (p), att, NSYMBOL (p)); + + if (att == IDENTIFIER && z != NO_TAG) + MOID (p) = MOID (z); + else if (att == LABEL && z != NO_TAG) + ; + else if ((z = bind_lengthety_identifier (NSYMBOL (p))) != NO_TAG) + MOID (p) = MOID (z); + else + { + a68_error (p, "tag S has not been declared properly"); + z = a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER); + MOID (p) = M_ERROR; + } + TAX (p) = z; + if (IS (p, DEFINING_IDENTIFIER)) + NODE (z) = p; + } + } + } +} + +/* Tell whether the given tree refers to the applied indicant INDICANT in an + actual declarer. */ + +static bool +declarer_contains_indicant (NODE_T *p, NODE_T *indicant) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, DECLARER) + && IS (SUB (q), INDICANT) + && ((TAX (SUB (q)) && IS_RECURSIVE (TAX (SUB (q)))) + || IS_LITERALLY (SUB (q), NSYMBOL (indicant)))) + { + return true; + } + + if (declarer_contains_indicant (SUB (q), indicant)) + return true; + } + + return false; +} + +/* Bind indicant tags to the symbol table. */ + +static void +bind_indicant_tag_to_symbol_table (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + bind_indicant_tag_to_symbol_table (SUB (p)); + + if (a68_is_one_of (p, INDICANT, DEFINING_INDICANT, STOP)) + { + TAG_T *z = a68_find_tag_global (TABLE (p), INDICANT, NSYMBOL (p)); + + if (z != NO_TAG) + { + MOID (p) = MOID (z); + TAX (p) = z; + if (IS (p, DEFINING_INDICANT)) + { + NODE (z) = p; + IS_RECURSIVE (z) = declarer_contains_indicant (NEXT_NEXT (p), p); + } + } + } + } +} + +/* Enter specifier identifiers in the symbol table. */ + +static void +tax_specifiers (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + tax_specifiers (SUB (p)); + + if (SUB (p) != NO_NODE && IS (p, SPECIFIER)) + tax_specifier_list (SUB (p)); + } +} + +/* Enter specifier identifiers in the symbol table. */ + +static void +tax_specifier_list (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, OPEN_SYMBOL)) + tax_specifier_list (NEXT (p)); + else if (a68_is_one_of (p, CLOSE_SYMBOL, VOID_SYMBOL, STOP)) + ; + else if (IS (p, IDENTIFIER)) + { + TAG_T *z = a68_add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, SPECIFIER_IDENTIFIER); + HEAP (z) = LOC_SYMBOL; + } + else if (IS (p, DECLARER)) + { + tax_specifiers (SUB (p)); + tax_specifier_list (NEXT (p)); + /* last identifier entry is identifier with this declarer. */ + if (IDENTIFIERS (TABLE (p)) != NO_TAG + && PRIO (IDENTIFIERS (TABLE (p))) == SPECIFIER_IDENTIFIER) + MOID (IDENTIFIERS (TABLE (p))) = MOID (p); + } + } +} + +/* Enter parameter identifiers in the symbol table. */ + +static void +tax_parameters (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (SUB (p) != NO_NODE) + { + tax_parameters (SUB (p)); + if (IS (p, PARAMETER_PACK)) + tax_parameter_list (SUB (p)); + } + } +} + +/* Enter parameter identifiers in the symbol table. */ + +static void +tax_parameter_list (NODE_T *p) +{ + if (p != NO_NODE) + { + if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) + tax_parameter_list (NEXT (p)); + else if (IS (p, CLOSE_SYMBOL)) + ; + else if (a68_is_one_of (p, PARAMETER_LIST, PARAMETER, STOP)) + { + tax_parameter_list (NEXT (p)); + tax_parameter_list (SUB (p)); + } + else if (IS (p, IDENTIFIER)) + { + /* parameters are always local. */ + HEAP (a68_add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, PARAMETER_IDENTIFIER)) = LOC_SYMBOL; + } + else if (IS (p, DECLARER)) + { + tax_parameter_list (NEXT (p)); + /* last identifier entries are identifiers with this declarer. */ + for (TAG_T *s = IDENTIFIERS (TABLE (p)); s != NO_TAG && MOID (s) == NO_MOID; FORWARD (s)) + MOID (s) = MOID (p); + tax_parameters (SUB (p)); + } + } +} + +/* Enter FOR identifiers in the symbol table. */ + +static void +tax_for_identifiers (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + tax_for_identifiers (SUB (p)); + + if (IS (p, FOR_SYMBOL)) + { + if ((FORWARD (p)) != NO_NODE) + (void) a68_add_tag (TABLE (p), IDENTIFIER, p, M_INT, LOOP_IDENTIFIER); + } + } +} + +/* Enter routine texts in the symbol table. */ + +static void +tax_routine_texts (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + tax_routine_texts (SUB (p)); + + if (IS (p, ROUTINE_TEXT)) + { + TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, MOID (p), ROUTINE_TEXT); + TAX (p) = z; + HEAP (z) = LOC_SYMBOL; + USE (z) = true; + } + } +} + +/* Enter format texts in the symbol table. */ + +static void +tax_format_texts (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + tax_format_texts (SUB (p)); + + if (IS (p, FORMAT_TEXT)) + { + TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, M_FORMAT, FORMAT_TEXT); + TAX (p) = z; + USE (z) = true; + } + else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE) + { + TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, M_FORMAT, FORMAT_IDENTIFIER); + TAX (p) = z; + USE (z) = true; + } + } +} + +/* Enter FORMAT pictures in the symbol table. */ + +static void +tax_pictures (NODE_T * p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + tax_pictures (SUB (p)); + + if (IS (p, PICTURE)) + TAX (p) = a68_add_tag (TABLE (p), ANONYMOUS, p, M_COLLITEM, FORMAT_IDENTIFIER); + } +} + +/* Enter generators in the symbol table. */ + +static void +tax_generators (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + tax_generators (SUB (p)); + + if (IS (p, GENERATOR)) + { + if (IS (SUB (p), LOC_SYMBOL)) + { + TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (SUB (p)), GENERATOR); + HEAP (z) = LOC_SYMBOL; + USE (z) = true; + TAX (p) = z; + } + } + } +} + +/* Find a firmly related operator for operands. */ + +static TAG_T * +find_firmly_related_op (TABLE_T *c, const char *n, MOID_T *l, MOID_T *r, TAG_T *self) +{ + if (c != NO_TABLE) + { + TAG_T *s = OPERATORS (c); + + for (; s != NO_TAG; FORWARD (s)) + { + if (s != self && NSYMBOL (NODE (s)) == n) + { + PACK_T *t = PACK (MOID (s)); + if (t != NO_PACK && a68_is_firm (MOID (t), l)) + { + /* catch monadic operator. */ + if ((FORWARD (t)) == NO_PACK) + { + if (r == NO_MOID) + return s; + } + else + { + /* catch dyadic operator. */ + if (r != NO_MOID && a68_is_firm (MOID (t), r)) + return s; + } + } + } + } + } + return NO_TAG; +} + +/* Check for firmly related operators in this range. */ + +static void +test_firmly_related_ops_local (NODE_T *p, TAG_T *s) +{ + if (s != NO_TAG) + { + PACK_T *u = PACK (MOID (s)); + + if (u != NO_PACK) + { + MOID_T *l = MOID (u); + MOID_T *r = (NEXT (u) != NO_PACK ? MOID (NEXT (u)) : NO_MOID); + TAG_T *t = find_firmly_related_op (TAG_TABLE (s), NSYMBOL (NODE (s)), l, r, s); + + if (t != NO_TAG) + { + a68_error (p, "M Z is firmly related to M Z", + MOID (s), NSYMBOL (NODE (s)), MOID (t), + NSYMBOL (NODE (t))); + } + else + { + /* Warn for hidden firmly related operators defined in outer + ranges, if requested. */ + for (TABLE_T *prev = PREVIOUS (TAG_TABLE (s)); + prev != NO_TABLE; + prev = PREVIOUS (prev)) + { + TAG_T *t = find_firmly_related_op (prev, NSYMBOL (NODE (s)), l, r, + NO_TAG /* self */); + if (t != NO_TAG) + { + if (TAG_TABLE (t) == A68_STANDENV + && warn_algol68_hidden_declarations > 0) + { + if (a68_warning (p, OPT_Whidden_declarations_, + "Z hides a firmly related operator in a larger reach", + NSYMBOL (NODE (s)))) + { + a68_inform (NO_NODE, + "operator M Z defined in the standard prelude", + MOID (t), NSYMBOL (NODE (t))); + } + } + else if (warn_algol68_hidden_declarations > 1) + { + if (a68_warning (p, OPT_Whidden_declarations_, + "Z hides a firmly related operator in a larger reach", + NSYMBOL (NODE (s)))) + { + a68_inform (NODE (t), + "previous hidden declaration of S declared here", + NSYMBOL (NODE (s))); + } + } + + /* Report only one level of hidding or it gets messy. */ + break; + } + } + } + } + if (NEXT (s) != NO_TAG) + test_firmly_related_ops_local ((p == NO_NODE ? NO_NODE : NODE (NEXT (s))), NEXT (s)); + } +} + +/* Find firmly related operators in this program. */ + +static void +test_firmly_related_ops (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (SUB (p) != NO_NODE && a68_is_new_lexical_level (p)) + { + TAG_T *oops = OPERATORS (TABLE (SUB (p))); + + if (oops != NO_TAG) + test_firmly_related_ops_local (NODE (oops), oops); + } + test_firmly_related_ops (SUB (p)); + } +} + +/* Driver for the processing of TAXes. */ + +void +a68_collect_taxes (NODE_T *p) +{ + tax_tags (p); + tax_specifiers (p); + tax_parameters (p); + tax_for_identifiers (p); + tax_routine_texts (p); + tax_pictures (p); + tax_format_texts (p); + tax_generators (p); + bind_identifier_tag_to_symbol_table (p); + bind_indicant_tag_to_symbol_table (p); + test_firmly_related_ops (p); + test_firmly_related_ops_local (NO_NODE, OPERATORS (A68_STANDENV)); +} + +/* Whether tag has already been declared in this range. */ + +static void +already_declared (NODE_T *n, int a) +{ + if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) + a68_error (n, "multiple declaration of tag S"); +} + +/* Whether tag has already been declared in this range. */ + +static void +already_declared_hidden (NODE_T *n, int a) +{ + if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) + a68_error (n, "multiple declaration of tag S"); + + TAG_T *s = a68_find_tag_global (PREVIOUS (TABLE (n)), a, NSYMBOL (n)); + + if (s != NO_TAG + && ((TAG_TABLE (s) == A68_STANDENV && warn_algol68_hidden_declarations > 0) + || (TAG_TABLE (s) != A68_STANDENV && warn_algol68_hidden_declarations > 1))) + { + if (a68_warning (n, OPT_Whidden_declarations_, + "Z hides a declaration with larger reach", + NSYMBOL (n))) + { + if (TAG_TABLE (s) == A68_STANDENV) + a68_inform (NO_NODE, + "M Z defined in the standard prelude", + MOID (s), NSYMBOL (NODE (s))); + else + a68_inform (NODE (s), + "previous hidden declaration of S declared here", + NSYMBOL (n)); + } + } +} + +/* Add tag to local symbol table. */ + +TAG_T * +a68_add_tag (TABLE_T *s, int a, NODE_T *n, MOID_T *m, int p) +{ +#define INSERT_TAG(l, n) {NEXT (n) = *(l); *(l) = (n);} + if (s != NO_TABLE) + { + TAG_T *z = a68_new_tag (); + + TAG_TABLE (z) = s; + PRIO (z) = p; + MOID (z) = m; + NODE (z) = n; + /* TAX(n) = z;. */ + switch (a) + { + case IDENTIFIER: + already_declared_hidden (n, IDENTIFIER); + already_declared_hidden (n, LABEL); + INSERT_TAG (&IDENTIFIERS (s), z); + break; + case INDICANT: + already_declared_hidden (n, INDICANT); + already_declared (n, OP_SYMBOL); + already_declared (n, PRIO_SYMBOL); + INSERT_TAG (&INDICANTS (s), z); + break; + case LABEL: + already_declared_hidden (n, LABEL); + already_declared_hidden (n, IDENTIFIER); + INSERT_TAG (&LABELS (s), z); + break; + case OP_SYMBOL: + already_declared (n, INDICANT); + INSERT_TAG (&OPERATORS (s), z); + break; + case MODULE_SYMBOL: + already_declared (n, INDICANT); + INSERT_TAG (&MODULES (s), z); + break; + case PRIO_SYMBOL: + already_declared (n, PRIO_SYMBOL); + already_declared (n, INDICANT); + INSERT_TAG (&PRIO (s), z); + break; + case ANONYMOUS: + INSERT_TAG (&ANONYMOUS (s), z); + break; + default: + gcc_unreachable (); + } + return z; + } + else + return NO_TAG; +} + +/* Find a tag, searching symbol tables towards the root. */ + +TAG_T * +a68_find_tag_global (TABLE_T *table, int a, const char *name) +{ + if (table != NO_TABLE) + { + TAG_T *s = NO_TAG; + switch (a) + { + case IDENTIFIER: + s = IDENTIFIERS (table); + break; + case INDICANT: + s = INDICANTS (table); + break; + case LABEL: + s = LABELS (table); + break; + case OP_SYMBOL: + s = OPERATORS (table); + break; + case MODULE_SYMBOL: + s = MODULES (table); + break; + case PRIO_SYMBOL: + s = PRIO (table); + break; + default: + gcc_unreachable (); + break; + } + + for (; s != NO_TAG; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + return s; + } + return a68_find_tag_global (PREVIOUS (table), a, name); + } + else + return NO_TAG; +} + +/* Whether identifier or label global. */ + +int +a68_is_identifier_or_label_global (TABLE_T *table, const char *name) +{ + if (table != NO_TABLE) + { + for (TAG_T *s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + return IDENTIFIER; + } + for (TAG_T *s = LABELS (table); s != NO_TAG; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + return LABEL; + } + return a68_is_identifier_or_label_global (PREVIOUS (table), name); + } + else + return 0; +} + +/* Find a tag, searching only local symbol table. */ + +static TAG_T * +find_tag_local (TABLE_T *table, int a, const char *name) +{ + if (table != NO_TABLE) + { + TAG_T *s = NO_TAG; + + if (a == OP_SYMBOL) + s = OPERATORS (table); + else if (a == MODULE_SYMBOL) + s = MODULES (table); + else if (a == PRIO_SYMBOL) + s = PRIO (table); + else if (a == IDENTIFIER) + s = IDENTIFIERS (table); + else if (a == INDICANT) + s = INDICANTS (table); + else if (a == LABEL) + s = LABELS (table); + else + gcc_unreachable (); + + for (; s != NO_TAG; FORWARD (s)) + { + if (NSYMBOL (NODE (s)) == name || strcmp (NSYMBOL (NODE (s)), name) == 0) + return s; + } + } + return NO_TAG; +} + +/* Whether context specifies HEAP or LOC for an identifier. + + The boolean *E is set to true if an explicit qualifier was found, false + otherwise. */ + +static int +tab_qualifier (NODE_T *p, bool *e) +{ + *e = false; + if (p != NO_NODE) + { + if (a68_is_one_of (p, UNIT, ASSIGNATION, TERTIARY, SECONDARY, GENERATOR, STOP)) + return tab_qualifier (SUB (p), e); + else if (a68_is_one_of (p, LOC_SYMBOL, HEAP_SYMBOL, STOP)) + { + *e = true; + return ATTRIBUTE (p) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL; + } + else + return LOC_SYMBOL; + } + else + return LOC_SYMBOL; +} + +/* Enter identity declarations in the symbol table. + + E is true if HEAP or LOC got specified explicitly in the identity + declaration's formal parameter. */ + +static void +tax_identity_dec (NODE_T *p, MOID_T **m) +{ + if (p != NO_NODE) + { + if (IS (p, IDENTITY_DECLARATION)) + { + tax_identity_dec (SUB (p), m); + tax_identity_dec (NEXT (p), m); + } + else if (IS (p, DECLARER)) + { + tax_tags (SUB (p)); + *m = MOID (p); + tax_identity_dec (NEXT (p), m); + } + else if (IS (p, COMMA_SYMBOL)) + { + tax_identity_dec (NEXT (p), m); + } + else if (IS (p, DEFINING_IDENTIFIER)) + { + TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p)); + gcc_assert (entry != NO_TAG); + + MOID (p) = *m; + HEAP (entry) = LOC_SYMBOL; + TAX (p) = entry; + MOID (entry) = *m; + PUBLICIZED (entry) = PUBLICIZED (p); + bool e; + if (ATTRIBUTE (*m) == REF_SYMBOL) + { + HEAP (entry) = tab_qualifier (NEXT_NEXT (p), &e); + if (e && HEAP (entry) == LOC_SYMBOL && PUBLICIZED (entry)) + a68_warning (p, 0, "value of local generator will be out of scope"); + } + tax_identity_dec (NEXT_NEXT (p), m); + } + else + tax_tags (p); + } +} + +/* Enter variable declarations in the symbol table. + + E is true if an explicit sample generator was specified in the variable + declaration. */ + +static void +tax_variable_dec (NODE_T *p, int *q, MOID_T **m, bool e) +{ + if (p != NO_NODE) + { + if (IS (p, VARIABLE_DECLARATION)) + { + tax_variable_dec (SUB (p), q, m, e); + tax_variable_dec (NEXT (p), q, m, e); + } + else if (IS (p, DECLARER)) + { + tax_tags (SUB (p)); + *m = MOID (p); + tax_variable_dec (NEXT (p), q, m, e); + } + else if (IS (p, QUALIFIER)) + { + *q = ATTRIBUTE (SUB (p)); + tax_variable_dec (NEXT (p), q, m, true); + } + else if (IS (p, COMMA_SYMBOL)) + { + tax_variable_dec (NEXT (p), q, m, e); + } + else if (IS (p, DEFINING_IDENTIFIER)) + { + TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p)); + + MOID (p) = *m; + TAX (p) = entry; + PUBLICIZED (entry) = PUBLICIZED (p); + + if (PUBLICIZED (p) && e && *q == LOC_SYMBOL) + a68_error (p, "publicized variable should not be allocated on the stack"); + + if (PUBLICIZED (p)) + HEAP (entry) = STATIC_SYMBOL; + else + HEAP (entry) = *q; + + if (HEAP (entry) == LOC_SYMBOL) + { + TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, SUB (*m), GENERATOR); + HEAP (z) = LOC_SYMBOL; + USE (z) = true; + BODY (entry) = z; + } + else + { + BODY (entry) = NO_TAG; + } + MOID (entry) = *m; + tax_variable_dec (NEXT (p), q, m, e); + } + else + tax_tags (p); + } +} + +/* Enter procedure variable declarations in the symbol table. + + E is true if an explicit sample generator was specified in the procedure + variable declaration. */ + +static void +tax_proc_variable_dec (NODE_T *p, int *q, bool e) +{ + if (p != NO_NODE) + { + if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) + { + tax_proc_variable_dec (SUB (p), q, e); + tax_proc_variable_dec (NEXT (p), q, e); + } + else if (IS (p, QUALIFIER)) + { + *q = ATTRIBUTE (SUB (p)); + tax_proc_variable_dec (NEXT (p), q, true); + } + else if (a68_is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP)) + { + tax_proc_variable_dec (NEXT (p), q, e); + } + else if (IS (p, DEFINING_IDENTIFIER)) + { + TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p)); + + TAX (p) = entry; + MOID (entry) = MOID (p); + PUBLICIZED (entry) = PUBLICIZED (p); + + if (PUBLICIZED (p) && e && *q == LOC_SYMBOL) + a68_error (p, "publicized variable should not be allocated on the stack"); + + if (PUBLICIZED (p)) + HEAP (entry) = STATIC_SYMBOL; + else + HEAP (entry) = *q; + + if (HEAP (entry) == LOC_SYMBOL) + { + TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (p), GENERATOR); + HEAP (z) = LOC_SYMBOL; + USE (z) = true; + BODY (entry) = z; + } + else + { + BODY (entry) = NO_TAG; + } + tax_proc_variable_dec (NEXT (p), q, e); + } + else + tax_tags (p); + } +} + +/* Enter procedure declarations in the symbol table. */ + +static void +tax_proc_dec (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, PROCEDURE_DECLARATION)) + { + tax_proc_dec (SUB (p)); + tax_proc_dec (NEXT (p)); + } + else if (a68_is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP)) + { + tax_proc_dec (NEXT (p)); + } + else if (IS (p, DEFINING_IDENTIFIER)) + { + TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p)); + + MOID_T *m = MOID (NEXT_NEXT (p)); + MOID (p) = m; + TAX (p) = entry; + HEAP (entry) = LOC_SYMBOL; + MOID (entry) = m; + PUBLICIZED (entry) = PUBLICIZED (p); + tax_proc_dec (NEXT (p)); + } + else + tax_tags (p); + } +} + +/* Check validity of operator declaration. */ + +static void +check_operator_dec (NODE_T *p, MOID_T *u) +{ + int k = 0; + + if (u == NO_MOID) + { + NODE_T *pack = SUB_SUB (NEXT_NEXT (p)); /* Where the parameter pack + is. */ + if (ATTRIBUTE (NEXT_NEXT (p)) != ROUTINE_TEXT) + pack = SUB (pack); + k = 1 + a68_count_operands (pack); + } + else + k = a68_count_pack_members (PACK (u)); + + if (k < 1 || k > 2) + { + a68_error (p, "incorrect number of operands for S"); + k = 0; + } + + if (k == 1 && strchr (NOMADS, NSYMBOL (p)[0]) != NO_TEXT) + { + a68_error (p, "monadic S cannot start with a character from Z", NOMADS); + } + else if (k == 2 && !a68_find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) + { + a68_error (p, "dyadic S has no priority declaration"); + } +} + +/* Enter operator declarations in the symbol table. */ + +static void +tax_op_dec (NODE_T *p, MOID_T **m) +{ + if (p != NO_NODE) + { + if (IS (p, OPERATOR_DECLARATION)) + { + tax_op_dec (SUB (p), m); + tax_op_dec (NEXT (p), m); + } + else if (IS (p, OPERATOR_PLAN)) + { + tax_tags (SUB (p)); + *m = MOID (p); + tax_op_dec (NEXT (p), m); + } + else if (IS (p, OP_SYMBOL)) + { + tax_op_dec (NEXT (p), m); + } + else if (IS (p, COMMA_SYMBOL)) + { + tax_op_dec (NEXT (p), m); + } + else if (IS (p, DEFINING_OPERATOR)) + { + TAG_T *entry = OPERATORS (TABLE (p)); + check_operator_dec (p, *m); + while (entry != NO_TAG && NODE (entry) != p) + FORWARD (entry); + MOID (p) = *m; + TAX (p) = entry; + HEAP (entry) = LOC_SYMBOL; + MOID (entry) = *m; + PUBLICIZED (entry) = PUBLICIZED (p); + tax_op_dec (NEXT (p), m); + } + else + { + tax_tags (p); + } + } +} + +/* Enter module declarations in the symbol table. */ + +static void +tax_module_dec (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, MODULE_DECLARATION)) + { + tax_module_dec (SUB (p)); + tax_module_dec (NEXT (p)); + } + else if (IS (p, MODULE_SYMBOL)) + { + tax_module_dec (NEXT (p)); + } + else if (IS (p, COMMA_SYMBOL)) + { + tax_module_dec (NEXT (p)); + } + else if (IS (p, DEFINING_MODULE_INDICANT)) + { + TAG_T *entry = MODULES (TABLE (p)); + while (entry != NO_TAG && NODE (entry) != p) + FORWARD (entry); + MOID (p) = NO_MOID; + TAX (p) = entry; + HEAP (entry) = LOC_SYMBOL; + MOID (entry) = NO_MOID; + PUBLICIZED (entry) = PUBLICIZED (p); + tax_module_dec (NEXT (p)); + } + else + { + tax_tags (p); + } + } +} + +/* Enter brief operator declarations in the symbol table. */ + +static void +tax_brief_op_dec (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, BRIEF_OPERATOR_DECLARATION)) + { + tax_brief_op_dec (SUB (p)); + tax_brief_op_dec (NEXT (p)); + } + else if (a68_is_one_of (p, OP_SYMBOL, COMMA_SYMBOL, STOP)) + { + tax_brief_op_dec (NEXT (p)); + } + else if (IS (p, DEFINING_OPERATOR)) + { + TAG_T *entry = OPERATORS (TABLE (p)); + MOID_T *m = MOID (NEXT_NEXT (p)); + check_operator_dec (p, NO_MOID); + while (entry != NO_TAG && NODE (entry) != p) + FORWARD (entry); + MOID (p) = m; + TAX (p) = entry; + HEAP (entry) = LOC_SYMBOL; + MOID (entry) = m; + PUBLICIZED (entry) = PUBLICIZED (p); + tax_brief_op_dec (NEXT (p)); + } + else + { + tax_tags (p); + } + } +} + +/* Enter priority declarations in the symbol table. */ + +static void tax_prio_dec (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, PRIORITY_DECLARATION)) + { + tax_prio_dec (SUB (p)); + tax_prio_dec (NEXT (p)); + } + else if (a68_is_one_of (p, PRIO_SYMBOL, COMMA_SYMBOL, STOP)) + { + tax_prio_dec (NEXT (p)); + } + else if (IS (p, DEFINING_OPERATOR)) + { + TAG_T *entry = PRIO (TABLE (p)); + while (entry != NO_TAG && NODE (entry) != p) + FORWARD (entry); + MOID (p) = NO_MOID; + TAX (p) = entry; + HEAP (entry) = LOC_SYMBOL; + PUBLICIZED (entry) = PUBLICIZED (p); + tax_prio_dec (NEXT (p)); + } + else + { + tax_tags (p); + } + } +} + +/* Enter TAXes in the symbol table. */ + +static void +tax_tags (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + int heap = LOC_SYMBOL; + MOID_T *m = NO_MOID; + + if (IS (p, IDENTITY_DECLARATION)) + tax_identity_dec (p, &m); + else if (IS (p, VARIABLE_DECLARATION)) + tax_variable_dec (p, &heap, &m, false); + else if (IS (p, PROCEDURE_DECLARATION)) + tax_proc_dec (p); + else if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) + tax_proc_variable_dec (p, &heap, false); + else if (IS (p, OPERATOR_DECLARATION)) + tax_op_dec (p, &m); + else if (IS (p, BRIEF_OPERATOR_DECLARATION)) + tax_brief_op_dec (p); + else if (IS (p, PRIORITY_DECLARATION)) + tax_prio_dec (p); + else if (IS (p, MODULE_DECLARATION)) + tax_module_dec (p); + else + tax_tags (SUB (p)); + } +} + +/* Reset symbol table nest count. */ + +void +a68_reset_symbol_table_nest_count (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (SUB (p) != NO_NODE && a68_is_new_lexical_level (p)) + NEST (TABLE (SUB (p))) = A68 (symbol_table_count)++; + a68_reset_symbol_table_nest_count (SUB (p)); + } +} + +//! @brief Bind routines in symbol table to the tree. + +void +a68_bind_routine_tags_to_tree (NODE_T *p) +{ + /* By inserting coercions etc. some may have shifted. */ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, ROUTINE_TEXT) && TAX (p) != NO_TAG) + NODE (TAX (p)) = p; + a68_bind_routine_tags_to_tree (SUB (p)); + } +} + +/* Bind formats in symbol table to tree. */ + +static void +bind_format_tags_to_tree (NODE_T *p) +{ + /* By inserting coercions etc. some may have shifted. */ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, FORMAT_TEXT) && TAX (p) != NO_TAG) + NODE (TAX (p)) = p; + else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE && TAX (p) != NO_TAG) + NODE (TAX (p)) = p; + + bind_format_tags_to_tree (SUB (p)); + } +} + +/* Fill outer level of symbol table. */ + +void +a68_fill_symbol_table_outer (NODE_T *p, TABLE_T *s) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (TABLE (p) != NO_TABLE) + OUTER (TABLE (p)) = s; + + if (SUB (p) != NO_NODE && IS (p, ROUTINE_TEXT)) + a68_fill_symbol_table_outer (SUB (p), TABLE (SUB (p))); + else if (SUB (p) != NO_NODE && IS (p, FORMAT_TEXT)) + a68_fill_symbol_table_outer (SUB (p), TABLE (SUB (p))); + else if (SUB (p) != NO_NODE && IS (p, MODULE_TEXT)) + a68_fill_symbol_table_outer (SUB (p), TABLE (SUB (p))); + else + a68_fill_symbol_table_outer (SUB (p), s); + } +} + +/* Flood branch in tree with local symbol table S. */ + +static void +flood_with_symbol_table_restricted (NODE_T *p, TABLE_T *s) +{ + for (; p != NO_NODE; FORWARD (p)) + { + TABLE (p) = s; + if (ATTRIBUTE (p) != ROUTINE_TEXT && ATTRIBUTE (p) != SPECIFIED_UNIT) + { + if (a68_is_new_lexical_level (p)) + PREVIOUS (TABLE (SUB (p))) = s; + else + flood_with_symbol_table_restricted (SUB (p), s); + } + } +} + +/* Final structure of symbol table after parsing. */ + +void +a68_finalise_symbol_table_setup (NODE_T *p, int l) +{ + TABLE_T *s = TABLE (p); + NODE_T *q = p; + + while (q != NO_NODE) + { + /* routine texts are ranges. */ + if (IS (q, ROUTINE_TEXT)) + flood_with_symbol_table_restricted (SUB (q), a68_new_symbol_table (s)); + + /* specifiers are ranges. */ + else if (IS (q, SPECIFIED_UNIT)) + flood_with_symbol_table_restricted (SUB (q), a68_new_symbol_table (s)); + + /* level count and recursion. */ + if (SUB (q) != NO_NODE) + { + if (a68_is_new_lexical_level (q)) + { + LEX_LEVEL (SUB (q)) = l + 1; + gcc_assert (TABLE (SUB (q)) != s); + PREVIOUS (TABLE (SUB (q))) = s; + a68_finalise_symbol_table_setup (SUB (q), l + 1); + if (IS (q, WHILE_PART)) + { + /* This was a bug that went unnoticed for 15 years!. */ + TABLE_T *s2 = TABLE (SUB (q)); + if ((FORWARD (q)) == NO_NODE) + return; + if (IS (q, ALT_DO_PART)) + { + PREVIOUS (TABLE (SUB (q))) = s2; + LEX_LEVEL (SUB (q)) = l + 2; + a68_finalise_symbol_table_setup (SUB (q), l + 2); + } + } + if (IS (q, DEF_PART)) + { + TABLE_T *s2 = TABLE (SUB (q)); + if ((FORWARD (q)) == NO_NODE) + return; + if (IS (q, POSTLUDE_PART)) + { + PREVIOUS (TABLE (SUB (q))) = s2; + LEX_LEVEL (SUB (q)) = l + 2; + a68_finalise_symbol_table_setup (SUB (q), l + 2); + } + } + } + else + { + TABLE (SUB (q)) = s; + a68_finalise_symbol_table_setup (SUB (q), l); + } + } + TABLE (q) = s; + + if (IS (q, FOR_SYMBOL)) + FORWARD (q); + FORWARD (q); + } + + /* FOR identifiers are in the DO ... OD range. */ + for (q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, FOR_SYMBOL)) + TABLE (NEXT (q)) = TABLE (SEQUENCE (NEXT (q))); + } +} + +/* First structure of symbol table for parsing. */ + +void +a68_preliminary_symbol_table_setup (NODE_T *p) +{ + TABLE_T *s = TABLE (p); + bool not_a_for_range = false; + + /* Let the tree point to the current symbol table. */ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + TABLE (q) = s; + + /* insert new tables when required. */ + for (NODE_T *q = p; q != NO_NODE && !not_a_for_range; FORWARD (q)) + { + if (SUB (q) != NO_NODE) + { + /* BEGIN ... END, CODE ... EDOC, DO ... OD, $ ... $, { ... } are + ranges. */ + if (a68_is_one_of (q, BEGIN_SYMBOL, DO_SYMBOL, ALT_DO_SYMBOL, + FORMAT_DELIMITER_SYMBOL, STOP)) + { + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + } + /* ( ... ) is a range. */ + else if (IS (q, OPEN_SYMBOL)) + { + if (a68_whether (q, OPEN_SYMBOL, THEN_BAR_SYMBOL, STOP)) + { + TABLE (SUB (q)) = s; + a68_preliminary_symbol_table_setup (SUB (q)); + FORWARD (q); + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + if ((FORWARD (q)) == NO_NODE) + not_a_for_range = true; + else + { + if (IS (q, THEN_BAR_SYMBOL)) + { + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + } + if (IS (q, OPEN_SYMBOL)) + { + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + } + } + } + else + { + /* Don't worry about STRUCT (...), UNION (...), PROC (...) + yet. */ + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + } + } + /* IF ... THEN ... ELSE ... FI are ranges. */ + else if (IS (q, IF_SYMBOL)) + { + if (a68_whether (q, IF_SYMBOL, THEN_SYMBOL, STOP)) + { + TABLE (SUB (q)) = s; + a68_preliminary_symbol_table_setup (SUB (q)); + FORWARD (q); + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + if ((FORWARD (q)) == NO_NODE) + not_a_for_range = true; + else + if (IS (q, ELSE_SYMBOL)) + { + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + } + if (IS (q, IF_SYMBOL)) + { + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + } + } + else + { + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + } + } + /* CASE ... IN ... OUT ... ESAC are ranges. */ + else if (IS (q, CASE_SYMBOL)) + { + if (a68_whether (q, CASE_SYMBOL, IN_SYMBOL, STOP)) + { + TABLE (SUB (q)) = s; + a68_preliminary_symbol_table_setup (SUB (q)); + FORWARD (q); + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + if ((FORWARD (q)) == NO_NODE) + not_a_for_range = true; + else + { + if (IS (q, OUT_SYMBOL)) + { + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + } + if (IS (q, CASE_SYMBOL)) + { + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + } + } + } + else + { + TABLE (SUB (q)) = a68_new_symbol_table (s); + a68_preliminary_symbol_table_setup (SUB (q)); + } + } + /* WHILE ... DO ... OD are ranges. */ + else if (IS (q, WHILE_SYMBOL)) + { + TABLE_T *u = a68_new_symbol_table (s); + TABLE (SUB (q)) = u; + a68_preliminary_symbol_table_setup (SUB (q)); + if ((FORWARD (q)) == NO_NODE) + not_a_for_range = true; + else if (IS (q, ALT_DO_SYMBOL)) + { + TABLE (SUB (q)) = a68_new_symbol_table (u); + a68_preliminary_symbol_table_setup (SUB (q)); + } + } + /* ACCESS ... DEF ...POSTLUDE ...FED are ranges. */ + else if (IS (q, ALT_ACCESS_SYMBOL)) + { + TABLE_T *u = a68_new_symbol_table (s); + TABLE (SUB (q)) = u; + a68_preliminary_symbol_table_setup (SUB (q)); + if (NEXT (q) == NO_NODE) + not_a_for_range = true; + else if (IS ((FORWARD (q)), DEF_SYMBOL)) + { + TABLE_T *v = a68_new_symbol_table (u); + TABLE (SUB (q)) = v; + a68_preliminary_symbol_table_setup (SUB (q)); + } + } + /* DEF ... POSTLUDE ... FED are ranges. */ + else if (IS (q, DEF_SYMBOL)) + { + TABLE_T *u = a68_new_symbol_table (s); + PUBLIC_RANGE (u) = true; + TABLE (SUB (q)) = u; + a68_preliminary_symbol_table_setup (SUB (q)); + if (NEXT (q) == NO_NODE) + not_a_for_range = true; + else if (IS ((FORWARD (q)), POSTLUDE_SYMBOL)) + { + TABLE_T *v = a68_new_symbol_table (u); + TABLE (SUB (q)) = v; + a68_preliminary_symbol_table_setup (SUB (q)); + } + } + /* ACCESS ... CONTROLLED_CLAUSE are ranges. */ + else if (IS (q, ACCESS_SYMBOL)) + { + TABLE_T *u = a68_new_symbol_table (s); + TABLE (SUB (q)) = u; + a68_preliminary_symbol_table_setup (SUB (q)); + if (NEXT (q) == NO_NODE) + not_a_for_range = true; + } + else + { + TABLE (SUB (q)) = s; + a68_preliminary_symbol_table_setup (SUB (q)); + } + } + } + /* FOR identifiers will go to the DO ... OD range. */ + if (!not_a_for_range) + { + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, FOR_SYMBOL)) + { + NODE_T *r = q; + TABLE (NEXT (q)) = NO_TABLE; + for (; r != NO_NODE && TABLE (NEXT (q)) == NO_TABLE; FORWARD (r)) + { + if ((a68_is_one_of (r, WHILE_SYMBOL, ALT_DO_SYMBOL, STOP)) + && (NEXT (q) != NO_NODE && SUB (r) != NO_NODE)) + { + TABLE (NEXT (q)) = TABLE (SUB (r)); + SEQUENCE (NEXT (q)) = SUB (r); + } + } + } + } + } +} + +/* Mark a mode as in use. */ + +static void +mark_mode (MOID_T *m) +{ + if (m != NO_MOID && USE (m) == false) + { + PACK_T *p = PACK (m); + USE (m) = true; + for (; p != NO_PACK; FORWARD (p)) + { + mark_mode (MOID (p)); + mark_mode (SUB (m)); + mark_mode (SLICE (m)); + } + } +} + +//! @brief Traverse tree and mark modes as used. + +void +a68_mark_moids (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + a68_mark_moids (SUB (p)); + if (MOID (p) != NO_MOID) + mark_mode (MOID (p)); + } +} + +/* Mark various tags as used. */ + +void +a68_mark_auxilliary (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (SUB (p) != NO_NODE) + { + /* You get no warnings on unused PROC parameters. That is ok since + A68 has some parameters that you may not use at all - think of + PROC (REF FILE) BOOL event routines in transput. */ + a68_mark_auxilliary (SUB (p)); + } + else if (IS (p, OPERATOR)) + { + TAG_T *z; + + if (TAX (p) != NO_TAG) + USE (TAX (p)) = true; + + if ((z = a68_find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) != NO_TAG) + USE (z) = true; + } + else if (IS (p, INDICANT)) + { + TAG_T *z = a68_find_tag_global (TABLE (p), INDICANT, NSYMBOL (p)); + + if (z != NO_TAG) + { + TAX (p) = z; + USE (z) = true; + } + } + else if (IS (p, IDENTIFIER)) + { + if (TAX (p) != NO_TAG) + USE (TAX (p)) = true; + } + } +} + +/* Check a single tag. */ + +static void +unused (TAG_T *s) +{ + for (; s != NO_TAG; FORWARD (s)) + { + if (LINE_NUMBER (NODE (s)) > 0 && !USE (s)) + a68_warning (NODE (s), OPT_Wunused, "tag S is not used", NODE (s)); + } +} + +/* Driver for traversing tree and warn for unused tags. */ + +void +a68_warn_for_unused_tags (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (SUB (p) != NO_NODE) + { + if (a68_is_new_lexical_level (p)) + { + unused (MODULES (TABLE (SUB (p)))); + unused (OPERATORS (TABLE (SUB (p)))); + unused (PRIO (TABLE (SUB (p)))); + unused (IDENTIFIERS (TABLE (SUB (p)))); + unused (LABELS (TABLE (SUB (p)))); + unused (INDICANTS (TABLE (SUB (p)))); + } + } + a68_warn_for_unused_tags (SUB (p)); + } +} + +/* Mark jumps and procedured jumps. */ + +void +a68_jumps_from_procs (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, PROCEDURING)) + { + NODE_T *u = SUB_SUB (p); + + if (IS (u, GOTO_SYMBOL)) + FORWARD (u); + USE (TAX (u)) = true; + } + else if (IS (p, JUMP)) + { + NODE_T *u = SUB (p); + + if (IS (u, GOTO_SYMBOL)) + FORWARD (u); + if ((TAX (u) == NO_TAG) && (MOID (u) == NO_MOID) + && (a68_find_tag_global (TABLE (u), LABEL, NSYMBOL (u)) == NO_TAG)) + { + (void) a68_add_tag (TABLE (u), LABEL, u, NO_MOID, LOCAL_LABEL); + a68_error (u, "tag S has not been declared properly"); + } + else + USE (TAX (u)) = true; + } + else + a68_jumps_from_procs (SUB (p)); + } +} diff --git a/gcc/algol68/a68-parser-top-down.cc b/gcc/algol68/a68-parser-top-down.cc new file mode 100644 index 000000000000..79100a0a4af5 --- /dev/null +++ b/gcc/algol68/a68-parser-top-down.cc @@ -0,0 +1,894 @@ +/* Top-down parser for control structure. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +/* A few forward prototypes of functions defined below. */ + +static NODE_T *top_down_loop (NODE_T *p); +static NODE_T *top_down_skip_unit (NODE_T *p); +static NODE_T *top_down_def (NODE_T *def_p); + +/* Substitute brackets. + + Traditional ALGOL 68 syntax allows ( .. ) to replace [ .. ] in bounds and + slices. This top-down pass substitutes [ .. ] occurrences into ( .. ). */ + +void +a68_substitute_brackets (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + a68_substitute_brackets (SUB (p)); + + switch (ATTRIBUTE (p)) + { + case SUB_SYMBOL: + ATTRIBUTE (p) = OPEN_SYMBOL; + break; + case BUS_SYMBOL: + ATTRIBUTE (p) = CLOSE_SYMBOL; + break; + default: + break; + } + } +} + +/* Intelligible diagnostic from syntax tree branch. */ + +const char * +a68_phrase_to_text (NODE_T * p, NODE_T ** w) +{ +#define MAX_TERMINALS 8 + int count = 0, line = -1; + static BUFFER buffer; + + for (buffer[0] = '\0'; p != NO_NODE && count < MAX_TERMINALS; FORWARD (p)) + { + if (LINE_NUMBER (p) == 0) + continue; + + enum a68_attribute gatt = a68_get_good_attribute (p); + const char *z = a68_attribute_name (gatt); + + /* Where to put the error message? Bob Uzgalis noted that actual + content of a diagnostic is not as important as accurately + indicating *were* the problem is! */ + if (w != NO_VAR) + { + if (count == 0 || (*w) == NO_NODE) + *w = p; + else if (a68_dont_mark_here (*w)) + *w = p; + } + + /* Add initiation. */ + if (count == 0) + { + if (w != NO_VAR) + a68_bufcat (buffer, "construct beginning with", BUFFER_SIZE); + } + else if (count == 1) + a68_bufcat (buffer, " followed by", BUFFER_SIZE); + else if (count == 2) + a68_bufcat (buffer, " and then", BUFFER_SIZE); + else if (count >= 3) + a68_bufcat (buffer, " and", BUFFER_SIZE); + + /* Attribute or symbol. */ + if (z != NO_TEXT && SUB (p) != NO_NODE) + { + if (gatt == IDENTIFIER || gatt == OPERATOR || gatt == DENOTATION) + { + const char *strop_symbol = a68_strop_keyword (NSYMBOL (p)); + if (snprintf (A68 (edit_line), SNPRINTF_SIZE, " %%<%s%%>", strop_symbol) < 0) + gcc_unreachable (); + a68_bufcat (buffer, A68 (edit_line), BUFFER_SIZE); + } + else + { + if (strchr ("aeio", z[0]) != NO_TEXT) + a68_bufcat (buffer, " an", BUFFER_SIZE); + else + a68_bufcat (buffer, " a", BUFFER_SIZE); + + if (snprintf (A68 (edit_line), SNPRINTF_SIZE, " %s", z) < 0) + gcc_unreachable (); + a68_bufcat (buffer, A68 (edit_line), BUFFER_SIZE); + } + } + else if (z != NO_TEXT && SUB (p) == NO_NODE) + { + const char *strop_symbol = a68_strop_keyword (NSYMBOL (p)); + if (snprintf (A68 (edit_line), SNPRINTF_SIZE, " %%<%s%%>", strop_symbol) < 0) + gcc_unreachable (); + a68_bufcat (buffer, A68 (edit_line), BUFFER_SIZE); + } + else if (NSYMBOL (p) != NO_TEXT) + { + const char *strop_symbol = a68_strop_keyword (NSYMBOL (p)); + if (snprintf (A68 (edit_line), SNPRINTF_SIZE, " %%<%s%%>", strop_symbol) < 0) + gcc_unreachable (); + a68_bufcat (buffer, A68 (edit_line), BUFFER_SIZE); + } + /* Add "starting in line nn". */ + if (z != NO_TEXT && line != LINE_NUMBER (p)) + { + line = LINE_NUMBER (p); + if (gatt == SERIAL_CLAUSE || gatt == ENQUIRY_CLAUSE || gatt == INITIALISER_SERIES) + a68_bufcat (buffer, " starting", BUFFER_SIZE); + if (snprintf (A68 (edit_line), SNPRINTF_SIZE, " in line %d", line) < 0) + gcc_unreachable (); + a68_bufcat (buffer, A68 (edit_line), BUFFER_SIZE); + } + count++; + } + + if (p != NO_NODE && count == MAX_TERMINALS) + a68_bufcat (buffer, " etcetera", BUFFER_SIZE); + return buffer; +} + +/* Next is a top-down parser that branches out the basic blocks. + After this we can assign symbol tables to basic blocks. + This renders the two-level grammar LALR. */ + +/* Give diagnose from top-down parser. */ + +static void +top_down_diagnose (NODE_T *start, NODE_T *p, int clause, int expected) +{ + NODE_T *issue = (p != NO_NODE ? p : start); + const char *strop_keyword = a68_strop_keyword (NSYMBOL (start)); + + if (expected != 0) + a68_error (issue, "B expected in A, near Z L", + expected, clause, strop_keyword, LINE (INFO (start))); + else + a68_error (issue, "missing or unbalanced keyword in A, near Z L", + clause, strop_keyword, LINE (INFO (start))); +} + +/* Check for premature exhaustion of tokens. */ + +static void +tokens_exhausted (NODE_T *p, NODE_T *q) +{ + if (p == NO_NODE) + { + a68_error (q, "check for missing or unmatched keyword in clause starting at S"); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } +} + +/* + * This part specifically branches out loop clauses. + */ + +/* Whether in cast or formula with loop clause. */ + +static int +is_loop_cast_formula (NODE_T *p) +{ + /* Accept declarers that can appear in such casts but not much more. */ + if (IS (p, VOID_SYMBOL)) + return 1; + else if (IS (p, INT_SYMBOL)) + return 1; + else if (IS_REF (p)) + return 1; + else if (a68_is_one_of (p, OPERATOR, BOLD_TAG, STOP)) + return 1; + else if (a68_whether (p, UNION_SYMBOL, OPEN_SYMBOL, STOP)) + return 2; + else if (a68_is_one_of (p, OPEN_SYMBOL, SUB_SYMBOL, STOP)) + { + int k = 0; + for (; p != NO_NODE && (a68_is_one_of (p, OPEN_SYMBOL, SUB_SYMBOL, STOP)); FORWARD (p), k++) + ; + return p != NO_NODE && (a68_whether (p, UNION_SYMBOL, OPEN_SYMBOL, STOP) ? k : 0); + } + return 0; +} + +/* Skip a unit in a loop clause (FROM u BY u TO u). */ + +static NODE_T * +top_down_skip_loop_unit (NODE_T *p) +{ + /* Unit may start with, or consist of, a loop. */ + if (a68_is_loop_keyword (p)) + p = top_down_loop (p); + + /* Skip rest of unit. */ + while (p != NO_NODE) + { + int k = is_loop_cast_formula (p); + + if (k != 0) + { + /* operator-cast series ... */ + while (p != NO_NODE && k != 0) + { + while (k != 0) + { + FORWARD (p); + k--; + } + k = is_loop_cast_formula (p); + } + + /* ... may be followed by a loop clause. */ + if (a68_is_loop_keyword (p)) + p = top_down_loop (p); + } + else if (a68_is_loop_keyword (p) || IS (p, OD_SYMBOL)) + /* new loop or end-of-loop. */ + return p; + else if (IS (p, COLON_SYMBOL)) + { + FORWARD (p); + /* skip routine header: loop clause. */ + if (p != NO_NODE && a68_is_loop_keyword (p)) + p = top_down_loop (p); + } + else if (a68_is_one_of (p, SEMI_SYMBOL, COMMA_SYMBOL, STOP) || IS (p, EXIT_SYMBOL)) + /* Statement separators. */ + return p; + else + FORWARD (p); + } + return NO_NODE; +} + +/* Skip a loop clause. */ + +static NODE_T * +top_down_skip_loop_series (NODE_T *p) +{ + bool siga; + + do + { + p = top_down_skip_loop_unit (p); + siga = (p != NO_NODE && (a68_is_one_of (p, SEMI_SYMBOL, EXIT_SYMBOL, + COMMA_SYMBOL, COLON_SYMBOL, + STOP))); + if (siga) + FORWARD (p); + } + while (!(p == NO_NODE || !siga)); + + return p; +} + +/* Make branch of loop parts. */ + +static NODE_T * +top_down_loop (NODE_T *p) +{ + NODE_T *start = p, *q = p; + + if (IS (q, FOR_SYMBOL)) + { + tokens_exhausted (FORWARD (q), start); + + if (IS (q, IDENTIFIER)) + ATTRIBUTE (q) = DEFINING_IDENTIFIER; + else + { + top_down_diagnose (start, q, LOOP_CLAUSE, IDENTIFIER); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + tokens_exhausted (FORWARD (q), start); + + if (a68_is_one_of (q, FROM_SYMBOL, BY_SYMBOL, TO_SYMBOL, + WHILE_SYMBOL, STOP)) + ; + else if (IS (q, DO_SYMBOL)) + ATTRIBUTE (q) = ALT_DO_SYMBOL; + else + { + top_down_diagnose (start, q, LOOP_CLAUSE, STOP); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + } + + if (IS (q, FROM_SYMBOL)) + { + start = q; + q = top_down_skip_loop_unit (NEXT (q)); + tokens_exhausted (q, start); + if (a68_is_one_of (q, BY_SYMBOL, TO_SYMBOL, WHILE_SYMBOL, STOP)) + ; + else if (IS (q, DO_SYMBOL)) + ATTRIBUTE (q) = ALT_DO_SYMBOL; + else + { + top_down_diagnose (start, q, LOOP_CLAUSE, STOP); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (start, PREVIOUS (q), FROM_SYMBOL); + } + + if (IS (q, BY_SYMBOL)) + { + start = q; + q = top_down_skip_loop_series (NEXT (q)); + tokens_exhausted (q, start); + + if (a68_is_one_of (q, TO_SYMBOL, WHILE_SYMBOL, STOP)) + ; + else if (IS (q, DO_SYMBOL)) + ATTRIBUTE (q) = ALT_DO_SYMBOL; + else + { + top_down_diagnose (start, q, LOOP_CLAUSE, STOP); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (start, PREVIOUS (q), BY_SYMBOL); + } + + if (a68_is_one_of (q, TO_SYMBOL, STOP)) + { + start = q; + q = top_down_skip_loop_series (NEXT (q)); + tokens_exhausted (q, start); + + if (IS (q, WHILE_SYMBOL)) + ; + else if (IS (q, DO_SYMBOL)) + ATTRIBUTE (q) = ALT_DO_SYMBOL; + else + { + top_down_diagnose (start, q, LOOP_CLAUSE, STOP); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (start, PREVIOUS (q), TO_SYMBOL); + } + + if (IS (q, WHILE_SYMBOL)) + { + start = q; + q = top_down_skip_loop_series (NEXT (q)); + tokens_exhausted (q, start); + + if (IS (q, DO_SYMBOL)) + ATTRIBUTE (q) = ALT_DO_SYMBOL; + else + { + top_down_diagnose (start, q, LOOP_CLAUSE, DO_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (start, PREVIOUS (q), WHILE_SYMBOL); + } + + if (a68_is_one_of (q, DO_SYMBOL, ALT_DO_SYMBOL, STOP)) + { + enum a68_attribute k = ATTRIBUTE (q); + + start = q; + q = top_down_skip_loop_series (NEXT (q)); + tokens_exhausted (q, start); + + if (!IS (q, OD_SYMBOL)) + { + top_down_diagnose (start, q, LOOP_CLAUSE, OD_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (start, q, k); + } + + NODE_T *save = NEXT (start); + a68_make_sub (p, start, LOOP_CLAUSE); + return save; +} + +/* Driver for making branches of loop parts. */ + +static void +top_down_loops (NODE_T *p) +{ + NODE_T *q = p; + + for (; q != NO_NODE; FORWARD (q)) + { + if (SUB (q) != NO_NODE) + top_down_loops (SUB (q)); + } + + q = p; + while (q != NO_NODE) + { + if (a68_is_loop_keyword (q) != STOP) + q = top_down_loop (q); + else + FORWARD (q); + } +} + +/* + * Branch anything except parts of a loop. + */ + +/* Skip serial/enquiry clause (unit series). */ + +static NODE_T * +top_down_series (NODE_T *p) +{ + bool siga = true; + while (siga) + { + siga = false; + p = top_down_skip_unit (p); + if (p != NO_NODE) + { + if (a68_is_one_of (p, SEMI_SYMBOL, EXIT_SYMBOL, COMMA_SYMBOL, STOP)) + { + siga = true; + FORWARD (p); + } + } + } + return p; +} + +/* Make branch of DEF .. POSTLUDE .. FED. */ + +static NODE_T * +top_down_def (NODE_T *def_p) +{ + NODE_T *fed_p = top_down_series (NEXT (def_p)); + + if (fed_p == NO_NODE || !(IS (fed_p, FED_SYMBOL) || IS (fed_p, POSTLUDE_SYMBOL))) + { + top_down_diagnose (def_p, fed_p, MODULE_TEXT, FED_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (def_p, PREVIOUS (fed_p), DEF_SYMBOL); + + if (IS (fed_p, POSTLUDE_SYMBOL)) + { + NODE_T *postlude_p = top_down_series (NEXT (fed_p)); + + if (postlude_p == NO_NODE || !IS (postlude_p, FED_SYMBOL)) + { + top_down_diagnose (def_p, fed_p, MODULE_TEXT, FED_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (fed_p, PREVIOUS (postlude_p), POSTLUDE_SYMBOL); + } + + return NEXT (def_p); +} + +/* Make branch of + + ACCESS REVELATION [DEF_SYMBOL] + or + ACCESS REVELATION ENCLOSED_CLAUSE. */ + +static void +top_down_access (NODE_T *p) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (SUB (q) != NO_NODE) + top_down_access (SUB (q)); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, ACCESS_SYMBOL)) + { + NODE_T *end_p = NEXT (q); + + /* Skip joined list of revelations and make branch until the enclosed + clause, DEF_SYMBOL or POSTLUDE_SYMBOL. */ + while (a68_is_one_of (end_p, BOLD_TAG, PUBLIC_SYMBOL, COMMA_SYMBOL, STOP)) + FORWARD (end_p); + + if (IS (end_p, DEF_SYMBOL)) + { + FORWARD (end_p); + if (IS (end_p, POSTLUDE_SYMBOL)) + FORWARD (end_p); + if (IS (end_p, FED_SYMBOL)) + { + ATTRIBUTE (q) = ALT_ACCESS_SYMBOL; + a68_make_sub (q, end_p, ALT_ACCESS_SYMBOL); + } + } + else + a68_make_sub (q, end_p, ACCESS_SYMBOL); + } + } +} + +/* Make branch of BEGIN .. END. */ + +static NODE_T * +top_down_begin (NODE_T *begin_p) +{ + NODE_T *end_p = top_down_series (NEXT (begin_p)); + + if (end_p == NO_NODE || !IS (end_p, END_SYMBOL)) + { + top_down_diagnose (begin_p, end_p, ENCLOSED_CLAUSE, END_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + return NO_NODE; + } + else + { + a68_make_sub (begin_p, end_p, BEGIN_SYMBOL); + return NEXT (begin_p); + } +} + +/* Make branch of ( .. ). */ + +static NODE_T * +top_down_open (NODE_T *open_p) +{ + NODE_T *then_bar_p = top_down_series (NEXT (open_p)), *elif_bar_p; + + if (then_bar_p != NO_NODE && IS (then_bar_p, CLOSE_SYMBOL)) + { + a68_make_sub (open_p, then_bar_p, OPEN_SYMBOL); + return NEXT (open_p); + } + + if (then_bar_p == NO_NODE || !IS (then_bar_p, THEN_BAR_SYMBOL)) + { + top_down_diagnose (open_p, then_bar_p, ENCLOSED_CLAUSE, STOP); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (open_p, PREVIOUS (then_bar_p), OPEN_SYMBOL); + elif_bar_p = top_down_series (NEXT (then_bar_p)); + if (elif_bar_p != NO_NODE && IS (elif_bar_p, CLOSE_SYMBOL)) + { + a68_make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL); + a68_make_sub (open_p, elif_bar_p, OPEN_SYMBOL); + return NEXT (open_p); + } + + if (elif_bar_p != NO_NODE && IS (elif_bar_p, THEN_BAR_SYMBOL)) + { + NODE_T *close_p = top_down_series (NEXT (elif_bar_p)); + + if (close_p == NO_NODE || !IS (close_p, CLOSE_SYMBOL)) + { + top_down_diagnose (open_p, elif_bar_p, ENCLOSED_CLAUSE, CLOSE_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL); + a68_make_sub (elif_bar_p, PREVIOUS (close_p), THEN_BAR_SYMBOL); + a68_make_sub (open_p, close_p, OPEN_SYMBOL); + return NEXT (open_p); + } + + if (elif_bar_p != NO_NODE && IS (elif_bar_p, ELSE_BAR_SYMBOL)) + { + NODE_T *close_p = top_down_open (elif_bar_p); + a68_make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL); + a68_make_sub (open_p, elif_bar_p, OPEN_SYMBOL); + return close_p; + } + else + { + top_down_diagnose (open_p, elif_bar_p, ENCLOSED_CLAUSE, CLOSE_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + return NO_NODE; + } +} + +/* Make branch of [ .. ]. */ + +static NODE_T * +top_down_sub (NODE_T *sub_p) +{ + NODE_T *bus_p = top_down_series (NEXT (sub_p)); + + if (bus_p != NO_NODE && IS (bus_p, BUS_SYMBOL)) + { + a68_make_sub (sub_p, bus_p, SUB_SYMBOL); + return NEXT (sub_p); + } + else + { + top_down_diagnose (sub_p, bus_p, 0, BUS_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + return NO_NODE; + } +} + +/* Make branch of IF .. THEN .. ELSE .. FI. */ + +static NODE_T * +top_down_if (NODE_T * if_p) +{ + NODE_T *then_p = top_down_series (NEXT (if_p)), *elif_p; + + if (then_p == NO_NODE || !IS (then_p, THEN_SYMBOL)) + { + top_down_diagnose (if_p, then_p, CONDITIONAL_CLAUSE, THEN_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (if_p, PREVIOUS (then_p), IF_SYMBOL); + + elif_p = top_down_series (NEXT (then_p)); + if (elif_p != NO_NODE && IS (elif_p, FI_SYMBOL)) + { + a68_make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL); + a68_make_sub (if_p, elif_p, IF_SYMBOL); + return NEXT (if_p); + } + + if (elif_p != NO_NODE && IS (elif_p, ELSE_SYMBOL)) + { + NODE_T *fi_p = top_down_series (NEXT (elif_p)); + + if (fi_p == NO_NODE || !IS (fi_p, FI_SYMBOL)) + { + top_down_diagnose (if_p, fi_p, CONDITIONAL_CLAUSE, FI_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + else + { + a68_make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL); + a68_make_sub (elif_p, PREVIOUS (fi_p), ELSE_SYMBOL); + a68_make_sub (if_p, fi_p, IF_SYMBOL); + return NEXT (if_p); + } + } + + if (elif_p != NO_NODE && IS (elif_p, ELIF_SYMBOL)) + { + NODE_T *fi_p = top_down_if (elif_p); + + a68_make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL); + a68_make_sub (if_p, elif_p, IF_SYMBOL); + return fi_p; + } + else + { + top_down_diagnose (if_p, elif_p, CONDITIONAL_CLAUSE, FI_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + return NO_NODE; + } +} + +/* Make branch of CASE .. IN .. OUT .. ESAC. */ + +static NODE_T * +top_down_case (NODE_T *case_p) +{ + NODE_T *in_p = top_down_series (NEXT (case_p)), *ouse_p; + + if (in_p == NO_NODE || !IS (in_p, IN_SYMBOL)) + { + top_down_diagnose (case_p, in_p, ENCLOSED_CLAUSE, IN_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + + a68_make_sub (case_p, PREVIOUS (in_p), CASE_SYMBOL); + + ouse_p = top_down_series (NEXT (in_p)); + if (ouse_p != NO_NODE && IS (ouse_p, ESAC_SYMBOL)) + { + a68_make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL); + a68_make_sub (case_p, ouse_p, CASE_SYMBOL); + return NEXT (case_p); + } + + if (ouse_p != NO_NODE && IS (ouse_p, OUT_SYMBOL)) + { + NODE_T *esac_p = top_down_series (NEXT (ouse_p)); + + if (esac_p == NO_NODE || !IS (esac_p, ESAC_SYMBOL)) + { + top_down_diagnose (case_p, esac_p, ENCLOSED_CLAUSE, ESAC_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + else + { + a68_make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL); + a68_make_sub (ouse_p, PREVIOUS (esac_p), OUT_SYMBOL); + a68_make_sub (case_p, esac_p, CASE_SYMBOL); + return NEXT (case_p); + } + } + + if (ouse_p != NO_NODE && IS (ouse_p, OUSE_SYMBOL)) + { + NODE_T *esac_p = top_down_case (ouse_p); + + a68_make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL); + a68_make_sub (case_p, ouse_p, CASE_SYMBOL); + return esac_p; + } + else + { + top_down_diagnose (case_p, ouse_p, ENCLOSED_CLAUSE, ESAC_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + return NO_NODE; + } +} + +/* Skip a unit. */ + +static NODE_T * +top_down_skip_unit (NODE_T *p) +{ + while (p != NO_NODE && !a68_is_unit_terminator (p)) + { + if (IS (p, BEGIN_SYMBOL)) + p = top_down_begin (p); + else if (IS (p, SUB_SYMBOL)) + p = top_down_sub (p); + else if (IS (p, OPEN_SYMBOL)) + p = top_down_open (p); + else if (IS (p, IF_SYMBOL)) + p = top_down_if (p); + else if (IS (p, CASE_SYMBOL)) + p = top_down_case (p); + else + FORWARD (p); + } + return p; +} + +static NODE_T *top_down_skip_format (NODE_T *); + +/* Make branch of ( .. ) in a format. */ + +static NODE_T * +top_down_format_open (NODE_T *open_p) +{ + NODE_T *close_p = top_down_skip_format (NEXT (open_p)); + + if (close_p != NO_NODE && IS (close_p, FORMAT_CLOSE_SYMBOL)) + { + a68_make_sub (open_p, close_p, FORMAT_OPEN_SYMBOL); + return NEXT (open_p); + } + else + { + top_down_diagnose (open_p, close_p, 0, FORMAT_CLOSE_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + return NO_NODE; + } +} + +/* Skip a format text. */ + +static NODE_T * +top_down_skip_format (NODE_T *p) +{ + while (p != NO_NODE) + { + if (IS (p, FORMAT_OPEN_SYMBOL)) + p = top_down_format_open (p); + else if (a68_is_one_of (p, FORMAT_CLOSE_SYMBOL, FORMAT_DELIMITER_SYMBOL, STOP)) + return p; + else + FORWARD (p); + } + return NO_NODE; +} + +/* Make branch of $ .. $. */ + +static void +top_down_formats (NODE_T * p) +{ + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (SUB (q) != NO_NODE) + top_down_formats (SUB (q)); + } + + for (NODE_T *q = p; q != NO_NODE; FORWARD (q)) + { + if (IS (q, FORMAT_DELIMITER_SYMBOL)) + { + NODE_T *f = NEXT (q); + + while (f != NO_NODE && !IS (f, FORMAT_DELIMITER_SYMBOL)) + { + if (IS (f, FORMAT_OPEN_SYMBOL)) + f = top_down_format_open (f); + else + f = NEXT (f); + } + + if (f == NO_NODE) + { + top_down_diagnose (p, f, FORMAT_TEXT, FORMAT_DELIMITER_SYMBOL); + longjmp (A68_PARSER (top_down_crash_exit), 1); + } + else + a68_make_sub (q, f, FORMAT_DELIMITER_SYMBOL); + } + } +} + +/* Skip prelude packet. */ + +static NODE_T * +top_down_prelude_packet (NODE_T *p) +{ + while (p != NO_NODE) + { + if (IS (p, DEF_SYMBOL)) + p = top_down_def (p); + else + FORWARD (p); + } + + return p; +} + +/* Skip particular program. */ + +static NODE_T * +top_down_particular_program (NODE_T *p) +{ + (void) top_down_series (p); + return p; +} + +/* Make branches of phrases for the bottom-up parser. */ + +void +a68_top_down_parser (NODE_T *p) +{ + if (p == NO_NODE) + return; + + if (!setjmp (A68_PARSER (top_down_crash_exit))) + { + if (IS (p, MODULE_SYMBOL)) + (void) top_down_prelude_packet (p); + else + (void) top_down_particular_program (p); + } + + top_down_loops (p); + top_down_formats (p); + top_down_access (p); +} diff --git a/gcc/algol68/a68-parser-victal.cc b/gcc/algol68/a68-parser-victal.cc new file mode 100644 index 000000000000..b4162fc39821 --- /dev/null +++ b/gcc/algol68/a68-parser-victal.cc @@ -0,0 +1,362 @@ +/* Syntax check for formal, actual and virtual declarers. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" + +#include "a68.h" + +static bool victal_check_declarer (NODE_T *, int); + +/* Check generator. */ + +static void +victal_check_generator (NODE_T * p) +{ + if (!victal_check_declarer (NEXT (p), ACTUAL_DECLARER_MARK)) + a68_error (p, "Y expected", "actual declarer"); +} + +/* Check formal pack. */ + +static void +victal_check_formal_pack (NODE_T *p, int x, bool *z) +{ + if (p != NO_NODE) + { + if (IS (p, FORMAL_DECLARERS)) + victal_check_formal_pack (SUB (p), x, z); + else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) + victal_check_formal_pack (NEXT (p), x, z); + else if (IS (p, FORMAL_DECLARERS_LIST)) + { + victal_check_formal_pack (NEXT (p), x, z); + victal_check_formal_pack (SUB (p), x, z); + } + else if (IS (p, DECLARER)) + { + victal_check_formal_pack (NEXT (p), x, z); + (*z) &= victal_check_declarer (SUB (p), x); + } + } +} + +/* Check operator declaration. */ + +static void +victal_check_operator_dec (NODE_T *p) +{ + if (IS (NEXT (p), FORMAL_DECLARERS)) + { + bool z = true; + victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z); + if (!z) + a68_error (p, "Y expected", "formal declarers"); + FORWARD (p); + } + if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK)) + a68_error (p, "Y expected", "formal declarer"); +} + +/* Check mode declaration. */ + +static void +victal_check_mode_dec (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, MODE_DECLARATION)) + { + victal_check_mode_dec (SUB (p)); + victal_check_mode_dec (NEXT (p)); + } + else if (a68_is_one_of (p, MODE_SYMBOL, DEFINING_INDICANT, STOP) + || a68_is_one_of (p, EQUALS_SYMBOL, COMMA_SYMBOL, STOP)) + { + victal_check_mode_dec (NEXT (p)); + } + else if (IS (p, DECLARER)) + { + if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK)) + a68_error (p, "Y expected", "actual declarer"); + } + } +} + +/* Check variable declaration. */ + +static void +victal_check_variable_dec (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, VARIABLE_DECLARATION)) + { + victal_check_variable_dec (SUB (p)); + victal_check_variable_dec (NEXT (p)); + } + else + { + if (IS (p, QUALIFIER)) + FORWARD (p); + + if (a68_is_one_of (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, STOP) + || IS (p, COMMA_SYMBOL)) + victal_check_variable_dec (NEXT (p)); + else if (IS (p, UNIT)) + a68_victal_checker (SUB (p)); + else if (IS (p, DECLARER)) + { + if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK)) + a68_error (p, "Y expected", "actual declarer"); + victal_check_variable_dec (NEXT (p)); + } + } + } +} + +/* Check identity declaration. */ + +static void +victal_check_identity_dec (NODE_T * p) +{ + if (p != NO_NODE) + { + if (IS (p, IDENTITY_DECLARATION)) + { + victal_check_identity_dec (SUB (p)); + victal_check_identity_dec (NEXT (p)); + } + else if (a68_is_one_of (p, DEFINING_IDENTIFIER, EQUALS_SYMBOL, COMMA_SYMBOL, STOP)) + victal_check_identity_dec (NEXT (p)); + else if (IS (p, UNIT)) + a68_victal_checker (SUB (p)); + else if (IS (p, DECLARER)) + { + if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) + a68_error (p, "Y expected", "formal declarer"); + victal_check_identity_dec (NEXT (p)); + } + } +} + +/* Check routine pack. */ + +static void +victal_check_routine_pack (NODE_T *p, int x, bool *z) +{ + if (p != NO_NODE) + { + if (IS (p, PARAMETER_PACK)) + victal_check_routine_pack (SUB (p), x, z); + else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) + victal_check_routine_pack (NEXT (p), x, z); + else if (a68_is_one_of (p, PARAMETER_LIST, PARAMETER, STOP)) + { + victal_check_routine_pack (NEXT (p), x, z); + victal_check_routine_pack (SUB (p), x, z); + } + else if (IS (p, DECLARER)) + *z &= victal_check_declarer (SUB (p), x); + } +} + +/* Check routine text. */ + +static void +victal_check_routine_text (NODE_T *p) +{ + if (IS (p, PARAMETER_PACK)) + { + bool z = true; + victal_check_routine_pack (p, FORMAL_DECLARER_MARK, &z); + if (!z) + a68_error (p, "Y expected", "formal declarers"); + FORWARD (p); + } + if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) + a68_error (p, "Y expected", "formal declarer"); + a68_victal_checker (NEXT (p)); +} + +/* Check structure pack. */ + +static void +victal_check_structure_pack (NODE_T *p, int x, bool *z) +{ + if (p != NO_NODE) + { + if (IS (p, STRUCTURE_PACK)) + victal_check_structure_pack (SUB (p), x, z); + else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) + victal_check_structure_pack (NEXT (p), x, z); + else if (a68_is_one_of (p, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD, STOP)) + { + victal_check_structure_pack (NEXT (p), x, z); + victal_check_structure_pack (SUB (p), x, z); + } + else if (IS (p, DECLARER)) + (*z) &= victal_check_declarer (SUB (p), x); + } +} + +/* Check union pack. */ + +static void +victal_check_union_pack (NODE_T * p, int x, bool * z) +{ + if (p != NO_NODE) + { + if (IS (p, UNION_PACK)) + victal_check_union_pack (SUB (p), x, z); + else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, VOID_SYMBOL, STOP)) + victal_check_union_pack (NEXT (p), x, z); + else if (IS (p, UNION_DECLARER_LIST)) + { + victal_check_union_pack (NEXT (p), x, z); + victal_check_union_pack (SUB (p), x, z); + } + else if (IS (p, DECLARER)) + { + victal_check_union_pack (NEXT (p), x, z); + (*z) &= victal_check_declarer (SUB (p), FORMAL_DECLARER_MARK); + } + } +} + +/* Check declarer. */ + +static bool +victal_check_declarer (NODE_T *p, int x) +{ + if (p == NO_NODE) + return false; + else if (IS (p, DECLARER)) + return victal_check_declarer (SUB (p), x); + else if (a68_is_one_of (p, LONGETY, SHORTETY, STOP)) + return true; + else if (a68_is_one_of (p, VOID_SYMBOL, INDICANT, STANDARD, STOP)) + return true; + else if (IS_REF (p)) + return victal_check_declarer (NEXT (p), VIRTUAL_DECLARER_MARK); + else if (IS_FLEX (p)) + return victal_check_declarer (NEXT (p), x); + else if (IS (p, BOUNDS)) + { + a68_victal_checker (SUB (p)); + if (x == FORMAL_DECLARER_MARK) + { + a68_error (p, "Y expected", "formal bounds"); + (void) victal_check_declarer (NEXT (p), x); + return true; + } + else if (x == VIRTUAL_DECLARER_MARK) + { + a68_error (p, "Y expected", "virtual bounds"); + (void) victal_check_declarer (NEXT (p), x); + return true; + } + else + return victal_check_declarer (NEXT (p), x); + } + else if (IS (p, FORMAL_BOUNDS)) + { + a68_victal_checker (SUB (p)); + if (x == ACTUAL_DECLARER_MARK) + { + a68_error (p, "Y expected", "actual bounds"); + (void) victal_check_declarer (NEXT (p), x); + return true; + } + else + return victal_check_declarer (NEXT (p), x); + } + else if (IS (p, STRUCT_SYMBOL)) + { + bool z = true; + victal_check_structure_pack (NEXT (p), x, &z); + return z; + } + else if (IS (p, UNION_SYMBOL)) + { + bool z = true; + victal_check_union_pack (NEXT (p), FORMAL_DECLARER_MARK, &z); + if (!z) + a68_error (p, "Y expected", "formal declarer pack"); + return true; + } + else if (IS (p, PROC_SYMBOL)) + { + if (IS (NEXT (p), FORMAL_DECLARERS)) + { + bool z = true; + victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z); + if (!z) + a68_error (p, "Y expected", "formal declarer"); + FORWARD (p); + } + if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK)) + a68_error (p, "Y expected", "formal declarer"); + return true; + } + else + return false; +} + +/* Check cast. */ + +static void +victal_check_cast (NODE_T *p) +{ + if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) + { + a68_error (p, "Y expected", "formal declarer"); + a68_victal_checker (NEXT (p)); + } +} + +/* Driver for checking VICTALITY of declarers. */ + +void +a68_victal_checker (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, MODE_DECLARATION)) + victal_check_mode_dec (SUB (p)); + else if (IS (p, VARIABLE_DECLARATION)) + victal_check_variable_dec (SUB (p)); + else if (IS (p, IDENTITY_DECLARATION)) + victal_check_identity_dec (SUB (p)); + else if (IS (p, GENERATOR)) + victal_check_generator (SUB (p)); + else if (IS (p, ROUTINE_TEXT)) + victal_check_routine_text (SUB (p)); + else if (IS (p, OPERATOR_PLAN)) + victal_check_operator_dec (SUB (p)); + else if (IS (p, CAST)) + victal_check_cast (SUB (p)); + else + a68_victal_checker (SUB (p)); + } +} diff --git a/gcc/algol68/a68-parser.cc b/gcc/algol68/a68-parser.cc new file mode 100644 index 000000000000..f01ecbee434b --- /dev/null +++ b/gcc/algol68/a68-parser.cc @@ -0,0 +1,1181 @@ +/* ALGOL 68 parser. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* + This is a Mailloux-type parser driver. + + The Algol 68 grammar is a two level (Van Wijngaarden, "VW") grammar + that incorporates, as syntactical rules, the semantical rules in + other languages. Examples are correct use of symbols, modes and + scope. + + This code constitutes an effective "VW Algol 68 parser". A + pragmatic approach was chosen since in the early days of Algol 68, + many "ab initio" implementations failed, probably because + techniques to parse a language like Algol 68 had yet to be + invented. + + This is a Mailloux-type parser, in the sense that it scans a + "phrase" for definitions needed for parsing. Algol 68 allows for + tags to be used before they are defined, which gives freedom in + top-down programming. + + B. J. Mailloux. On the implementation of Algol 68. + Thesis, Universiteit van Amsterdam (Mathematisch Centrum) [1968]. + + Technically, Mailloux's approach renders the two-level grammar + LALR. + + First part of the parser is the scanner. The source file is read, is + tokenised. The result is a linear list of tokens that is input for the + parser, that will transform the linear list into a syntax tree. + + This front-end tokenises all symbols before the bottom-up parser is invoked. + This means that scanning does not use information from the parser. The + scanner does of course some rudimentary parsing. + + The scanner supports two stropping regimes: "bold" (or "upper") and + "quote". Examples of both: + + bold stropping: BEGIN INT i = 1, j = 1; print (i + j) END + + quote stropping: 'BEGIN' 'INT' I = 1, J = 1; PRINT (I + J) 'END' + + Quote stropping was used frequently in the (excusez-le-mot) + punch-card age. Hence, bold stropping is the default. There also + existed point stropping, but that has not been implemented here. + + Next part of the parser is a recursive-descent type to check + parenthesis. Also a first set-up is made of symbol tables, needed + by the bottom-up parser. Next part is the bottom-up parser, that + parses without knowing modes while parsing and reducing. It can + therefore not exchange "[]" with "()" as was blessed by the Revised + Report. This is solved by treating CALL and SLICE as equivalent for + the moment and letting the mode checker sort it out later. + + Parsing progresses in various phases to avoid spurious diagnostics + from a recovering parser. Every phase "tightens" the grammar more. + An error in any phase makes the parser quit when that phase ends. + The parser is forgiving in case of superfluous semicolons. + + These are the parser phases: + + (1) Parenthesis are checked to see whether they match. Then, a top-down + parser determines the basic-block structure of the program + so symbol tables can be set up that the bottom-up parser will consult + as you can define things before they are applied. + + (2) A bottom-up parser resolves the structure of the program. + + (3) After the symbol tables have been finalised, a small rearrangement of the + tree may be required where JUMPs have no GOTO. This leads to the + non-standard situation that JUMPs without GOTO can have the syntactic + position of a PRIMARY, SECONDARY or TERTIARY. The bottom-up parser also + does not check VICTAL correctness of declarers. This is done separately. + + The parser sets up symbol tables and populates them as far as needed to parse + the source. After the bottom-up parser terminates succesfully, the symbol tables + are completed. + + (4) Next, modes are collected and rules for well-formedness and structural + equivalence are applied. Then the symbol-table is completed now moids are + all known. + + (5) Next phases are the mode checker and coercion inserter. The syntax tree is + traversed to determine and check all modes, and to select operators. Then + the tree is traversed again to insert coercions. + + (6) A static scope checker detects where objects are transported out of scope. + At run time, a dynamic scope checker will check that what the static scope + checker cannot see. + + (7) A serial-clause dynamic stack allocation (DSA) phase annotates the + serial clauses that contain phrases whose elaboration may result in + dynamic stack adjustments. +*/ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "diagnostic.h" +#include "tree.h" + +#include "a68.h" + +/* Global state kept by the parser. */ + +PARSER_T a68_parser_state; + +/* A few forward declarations of functions defined below. */ + +static void make_special_mode (MOID_T ** n, int m); +static void tie_label_to_serial (NODE_T *p); +static void tie_label_to_unit (NODE_T *p); + +/* Is_ref_refety_flex. */ + +bool +a68_is_ref_refety_flex (MOID_T *m) +{ + if (IS_REF_FLEX (m)) + return true; + else if (IS_REF (m)) + return a68_is_ref_refety_flex (SUB (m)); + else + return false; +} + +/* Count number of operands in operator parameter list. */ + +int +a68_count_operands (NODE_T *p) +{ + if (p != NO_NODE) + { + if (IS (p, DECLARER)) + return a68_count_operands (NEXT (p)); + else if (IS (p, COMMA_SYMBOL)) + return 1 + a68_count_operands (NEXT (p)); + else + return a68_count_operands (NEXT (p)) + a68_count_operands (SUB (p)); + } + else + return 0; +} + +/* Count formal bounds in declarer in tree. */ + +int +a68_count_formal_bounds (NODE_T * p) +{ + if (p == NO_NODE) + return 0; + else + { + if (IS (p, COMMA_SYMBOL)) + return 1; + else + return a68_count_formal_bounds (NEXT (p)) + a68_count_formal_bounds (SUB (p)); + } +} + +/* Count pictures. */ + +void +a68_count_pictures (NODE_T *p, int *k) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, PICTURE)) + (*k)++; + a68_count_pictures (SUB (p), k); + } +} + +/* Whether token cannot follow semicolon or EXIT. */ + +bool +a68_is_semicolon_less (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case BUS_SYMBOL: + case CLOSE_SYMBOL: + case END_SYMBOL: + case SEMI_SYMBOL: + case EXIT_SYMBOL: + case THEN_BAR_SYMBOL: + case ELSE_BAR_SYMBOL: + case THEN_SYMBOL: + case ELIF_SYMBOL: + case ELSE_SYMBOL: + case FI_SYMBOL: + case IN_SYMBOL: + case OUT_SYMBOL: + case OUSE_SYMBOL: + case ESAC_SYMBOL: + case OD_SYMBOL: + case FED_SYMBOL: + case POSTLUDE_SYMBOL: + return true; + default: + return false; + } +} + +/* Whether formal bounds. */ + +bool +a68_is_formal_bounds (NODE_T *p) +{ + if (p == NO_NODE) + return true; + + switch (ATTRIBUTE (p)) + { + case OPEN_SYMBOL: + case CLOSE_SYMBOL: + case SUB_SYMBOL: + case BUS_SYMBOL: + case COMMA_SYMBOL: + case COLON_SYMBOL: + case INT_DENOTATION: + case IDENTIFIER: + case OPERATOR: + return (a68_is_formal_bounds (SUB (p)) + && a68_is_formal_bounds (NEXT (p))); + default: + return false; + } +} + +/* Whether token terminates a unit. */ + +bool +a68_is_unit_terminator (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case BUS_SYMBOL: + case CLOSE_SYMBOL: + case END_SYMBOL: + case SEMI_SYMBOL: + case EXIT_SYMBOL: + case COMMA_SYMBOL: + case THEN_BAR_SYMBOL: + case ELSE_BAR_SYMBOL: + case THEN_SYMBOL: + case ELIF_SYMBOL: + case ELSE_SYMBOL: + case FI_SYMBOL: + case IN_SYMBOL: + case OUT_SYMBOL: + case OUSE_SYMBOL: + case ESAC_SYMBOL: + case FED_SYMBOL: + case POSTLUDE_SYMBOL: + return true; + default: + return false; + } +} + +/* Whether token is a unit-terminator in a loop clause. */ + +bool +a68_is_loop_keyword (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case FOR_SYMBOL: + case FROM_SYMBOL: + case BY_SYMBOL: + case TO_SYMBOL: + case WHILE_SYMBOL: + case DO_SYMBOL: + return true; + default: + return false; + } +} + +/* Get good attribute. */ + +enum a68_attribute +a68_get_good_attribute (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case UNIT: + case TERTIARY: + case SECONDARY: + case PRIMARY: + return a68_get_good_attribute (SUB (p)); + default: + return ATTRIBUTE (p); + } +} + +/* Preferably don't put intelligible diagnostic here. */ + +bool +a68_dont_mark_here (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case ALT_DO_SYMBOL: + case ALT_EQUALS_SYMBOL: + case ANDF_SYMBOL: + case ASSERT_SYMBOL: + case ASSIGN_SYMBOL: + case ASSIGN_TO_SYMBOL: + case AT_SYMBOL: + case BEGIN_SYMBOL: + case BITS_SYMBOL: + case BOLD_COMMENT_SYMBOL: + case BOLD_PRAGMAT_SYMBOL: + case BOLD_COMMENT_BEGIN_SYMBOL: + case BOLD_COMMENT_END_SYMBOL: + case BOOL_SYMBOL: + case BUS_SYMBOL: + case BY_SYMBOL: + case BYTES_SYMBOL: + case CASE_SYMBOL: + case CHANNEL_SYMBOL: + case CHAR_SYMBOL: + case CLOSE_SYMBOL: + case COLON_SYMBOL: + case COMMA_SYMBOL: + case COMPLEX_SYMBOL: + case COMPL_SYMBOL: + case DO_SYMBOL: + case ELIF_SYMBOL: + case ELSE_BAR_SYMBOL: + case ELSE_SYMBOL: + case EMPTY_SYMBOL: + case END_SYMBOL: + case EQUALS_SYMBOL: + case ESAC_SYMBOL: + case EXIT_SYMBOL: + case FALSE_SYMBOL: + case FILE_SYMBOL: + case FI_SYMBOL: + case FLEX_SYMBOL: + case FOR_SYMBOL: + case FROM_SYMBOL: + case GO_SYMBOL: + case GOTO_SYMBOL: + case HEAP_SYMBOL: + case IF_SYMBOL: + case IN_SYMBOL: + case INT_SYMBOL: + case ISNT_SYMBOL: + case IS_SYMBOL: + case LOC_SYMBOL: + case LONG_SYMBOL: + case MAIN_SYMBOL: + case MODE_SYMBOL: + case NIL_SYMBOL: + case OD_SYMBOL: + case OF_SYMBOL: + case OPEN_SYMBOL: + case OP_SYMBOL: + case ORF_SYMBOL: + case OUSE_SYMBOL: + case OUT_SYMBOL: + case PAR_SYMBOL: + case POINT_SYMBOL: + case PRIO_SYMBOL: + case PROC_SYMBOL: + case REAL_SYMBOL: + case REF_SYMBOL: + case ROWS_SYMBOL: + case ROW_SYMBOL: + case SEMA_SYMBOL: + case SEMI_SYMBOL: + case SHORT_SYMBOL: + case SKIP_SYMBOL: + case STRING_SYMBOL: + case STRUCT_SYMBOL: + case STYLE_I_COMMENT_SYMBOL: + case STYLE_II_COMMENT_SYMBOL: + case STYLE_I_PRAGMAT_SYMBOL: + case SUB_SYMBOL: + case THEN_BAR_SYMBOL: + case THEN_SYMBOL: + case TO_SYMBOL: + case TRUE_SYMBOL: + case UNION_SYMBOL: + case VOID_SYMBOL: + case WHILE_SYMBOL: + case SERIAL_CLAUSE: + case ENQUIRY_CLAUSE: + case INITIALISER_SERIES: + case DECLARATION_LIST: + case DEF_SYMBOL: + case FED_SYMBOL: + case POSTLUDE_SYMBOL: + case ACCESS_SYMBOL: + return true; + default: + return false; + } +} + +/* Renumber nodes in the given subtree P, starting with number N. */ + +static void +renumber_nodes (NODE_T *p, int *n) +{ + for (; p != NO_NODE; FORWARD (p)) + { + NUMBER (p) = (*n)++; + renumber_nodes (SUB (p), n); + } +} + +/* Parse an ALGOL 68 source file. */ + +void +a68_parser (const char *filename) +{ + int renum = 0; + + /* Initialisation. */ + A68 (top_keyword) = NO_KEYWORD; + A68 (top_token) = NO_TOKEN; + A68_PARSER (error_tag) = (TAG_T *) a68_new_tag (); + TOP_NODE (&A68_JOB) = NO_NODE; + TOP_MOID (&A68_JOB) = NO_MOID; + TOP_LINE (&A68_JOB) = NO_LINE; + STANDENV_MOID (&A68_JOB) = NO_MOID; + a68_set_up_tables (); + ERROR_COUNT (&A68_JOB) = WARNING_COUNT (&A68_JOB) = 0; + + /* Tokeniser. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + bool ok = a68_lexical_analyser (filename); + + if (!ok) + return; + + /* An empty file is not a valid program. */ + if (TOP_NODE (&A68_JOB) == NO_NODE) + { + a68_error (NO_NODE, "file is empty, expected a program"); + return; + } + + TREE_LISTING_SAFE (&A68_JOB) = true; + renum = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &renum); + } + + /* Final initialisations. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + A68_STANDENV = NO_TABLE; + a68_init_postulates (); + A68 (mode_count) = 0; + make_special_mode (&M_HIP, A68 (mode_count)++); + make_special_mode (&M_UNDEFINED, A68 (mode_count)++); + make_special_mode (&M_ERROR, A68 (mode_count)++); + make_special_mode (&M_VACUUM, A68 (mode_count)++); + make_special_mode (&M_C_STRING, A68 (mode_count)++); + make_special_mode (&M_COLLITEM, A68 (mode_count)++); + } + + /* Handle pragmats. */ + if (ERROR_COUNT (&A68_JOB) == 0) + a68_handle_pragmats (TOP_NODE (&A68_JOB)); + + /* Top-down parser. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_check_parenthesis (TOP_NODE (&A68_JOB)); + if (ERROR_COUNT (&A68_JOB) == 0) + { + if (OPTION_BRACKETS (&A68_JOB)) + a68_substitute_brackets (TOP_NODE (&A68_JOB)); + A68 (symbol_table_count) = 0; + A68_STANDENV = a68_new_symbol_table (NO_TABLE); + LEVEL (A68_STANDENV) = 0; + a68_top_down_parser (TOP_NODE (&A68_JOB)); + // printf ("AFTER TOP-DOWN\n"); + // a68_dump_parse_tree (TOP_NODE (&A68_JOB)); + } + + renum = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &renum); + } + + /* Standard environment builder. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + TABLE (TOP_NODE (&A68_JOB)) = a68_new_symbol_table (A68_STANDENV); + a68_make_standard_environ (); + STANDENV_MOID (&A68_JOB) = TOP_MOID (&A68_JOB); + } + + /* Bottom-up parser. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_preliminary_symbol_table_setup (TOP_NODE (&A68_JOB)); + // printf ("AFTER PRELIMINARY SYMBOL TABLE SETUP\n"); + // a68_dump_parse_tree (TOP_NODE (&A68_JOB), true); + a68_bottom_up_parser (TOP_NODE (&A68_JOB)); + a68_bottom_up_coalesce_pub (TOP_NODE (&A68_JOB)); + renum = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &renum); + } + + // printf ("AFTER BOTTOM-UP\n"); + // a68_dump_parse_tree (TOP_NODE (&A68_JOB), true); + + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_bottom_up_error_check (TOP_NODE (&A68_JOB)); + a68_victal_checker (TOP_NODE (&A68_JOB)); + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_finalise_symbol_table_setup (TOP_NODE (&A68_JOB), 1); + // printf ("AFTER FINALISE SYMBOL TABLE SETUP\n"); + // a68_dump_parse_tree (TOP_NODE (&A68_JOB), true, true); + NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3; + a68_reset_symbol_table_nest_count (TOP_NODE (&A68_JOB)); + a68_fill_symbol_table_outer (TOP_NODE (&A68_JOB), TABLE (TOP_NODE (&A68_JOB))); + a68_set_nest (TOP_NODE (&A68_JOB), NO_NODE); + a68_set_proc_level (TOP_NODE (&A68_JOB), 1); + } + renum = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &renum); + } + + /* Mode table builder. */ + if (ERROR_COUNT (&A68_JOB) == 0) + a68_make_moid_list (&A68_JOB); + CROSS_REFERENCE_SAFE (&A68_JOB) = true; + + /* Symbol table builder. */ + if (ERROR_COUNT (&A68_JOB) == 0) + a68_collect_taxes (TOP_NODE (&A68_JOB)); + + /* Post parser. */ + if (ERROR_COUNT (&A68_JOB) == 0) + a68_rearrange_goto_less_jumps (TOP_NODE (&A68_JOB)); + + /* Mode checker. */ + if (ERROR_COUNT (&A68_JOB) == 0) + a68_mode_checker (TOP_NODE (&A68_JOB)); + + /* Coercion inserter. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_coercion_inserter (TOP_NODE (&A68_JOB)); + renum = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &renum); + } + + /* Application checker. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_mark_moids (TOP_NODE (&A68_JOB)); + a68_mark_auxilliary (TOP_NODE (&A68_JOB)); + a68_jumps_from_procs (TOP_NODE (&A68_JOB)); + a68_warn_for_unused_tags (TOP_NODE (&A68_JOB)); + } + + /* Static scope checker. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + tie_label_to_serial (TOP_NODE (&A68_JOB)); + tie_label_to_unit (TOP_NODE (&A68_JOB)); + a68_bind_routine_tags_to_tree (TOP_NODE (&A68_JOB)); + a68_scope_checker (TOP_NODE (&A68_JOB)); + } + + /* Serial dynamic stack allocation checker. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + a68_serial_dsa (TOP_NODE (&A68_JOB)); + } + + /* Finalise syntax tree. */ + if (ERROR_COUNT (&A68_JOB) == 0) + { + int num = 0; + renumber_nodes (TOP_NODE (&A68_JOB), &num); + NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3; + a68_reset_symbol_table_nest_count (TOP_NODE (&A68_JOB)); + } +} + +/* New_node_info. */ + +NODE_INFO_T * +a68_new_node_info (void) +{ + NODE_INFO_T *z = ggc_cleared_alloc (); + + A68 (new_node_infos)++; + PROCEDURE_LEVEL (z) = 0; + CHAR_IN_LINE (z) = NO_TEXT; + SYMBOL (z) = NO_TEXT; + PRAGMAT (z) = NO_TEXT; + PRAGMAT_TYPE (z) = 0; + PRAGMAT_LINE (z) = NO_LINE; + PRAGMAT_CHAR_IN_LINE (z) = NO_TEXT; + COMMENT (z) = NO_TEXT; + COMMENT_TYPE (z) = 0; + COMMENT_LINE (z) = NO_LINE; + COMMENT_CHAR_IN_LINE (z) = NO_TEXT; + LINE (z) = NO_LINE; + return z; +} + +/* New_genie_info. */ + +GINFO_T * +a68_new_genie_info (void) +{ + GINFO_T *z = ggc_cleared_alloc (); + + A68 (new_genie_infos)++; + PARTIAL_PROC (z) = NO_MOID; + PARTIAL_LOCALE (z) = NO_MOID; + return z; +} + +/* Allocate and return a new parse tree node with proper defaults. */ + +NODE_T * +a68_new_node (void) +{ + NODE_T *z = ggc_cleared_alloc (); + + A68 (new_nodes)++; + TABLE (z) = NO_TABLE; + INFO (z) = NO_NINFO; + GINFO (z) = NO_GINFO; + ATTRIBUTE (z) = STOP; + ANNOTATION (z) = STOP; + MOID (z) = NO_MOID; + NEXT (z) = NO_NODE; + PREVIOUS (z) = NO_NODE; + SUB (z) = NO_NODE; + NEST (z) = NO_NODE; + NON_LOCAL (z) = NO_TABLE; + TAX (z) = NO_TAG; + SEQUENCE (z) = NO_NODE; + PACK (z) = NO_PACK; + CDECL (z) = NULL_TREE; + DYNAMIC_STACK_ALLOCS (z) = false; + PUBLICIZED (z) = false; + return z; +} + +/* Some_node. */ + +NODE_T * +a68_some_node (const char *t) +{ + NODE_T *z = a68_new_node (); + INFO (z) = a68_new_node_info (); + GINFO (z) = a68_new_genie_info (); + NSYMBOL (z) = t; + return z; +} + +/* New_symbol_table. */ + +TABLE_T * +a68_new_symbol_table (TABLE_T *p) +{ + TABLE_T *z = ggc_cleared_alloc (); + + NUM (z) = A68 (symbol_table_count); + LEVEL (z) = A68 (symbol_table_count)++; + NEST (z) = A68 (symbol_table_count); + ATTRIBUTE (z) = 0; + INITIALISE_FRAME (z) = true; + PROC_OPS (z) = true; + INITIALISE_ANON (z) = true; + PREVIOUS (z) = p; + OUTER (z) = NO_TABLE; + IDENTIFIERS (z) = NO_TAG; + OPERATORS (z) = NO_TAG; + MODULES (z) = NO_TAG; + PRIO (z) = NO_TAG; + INDICANTS (z) = NO_TAG; + LABELS (z) = NO_TAG; + ANONYMOUS (z) = NO_TAG; + JUMP_TO (z) = NO_NODE; + SEQUENCE (z) = NO_NODE; + PUBLIC_RANGE (z) = false; + return z; +} + +/* New_moid. */ + +MOID_T * +a68_new_moid (void) +{ + MOID_T *z = ggc_cleared_alloc (); + + A68 (new_modes)++; + ATTRIBUTE (z) = 0; + NUMBER (z) = 0; + DIM (z) = 0; + USE (z) = false; + HAS_ROWS (z) = false; + PORTABLE (z) = true; + DERIVATE (z) = false; + NODE (z) = NO_NODE; + PACK (z) = NO_PACK; + SUB (z) = NO_MOID; + EQUIVALENT_MODE (z) = NO_MOID; + SLICE (z) = NO_MOID; + TRIM (z) = NO_MOID; + DEFLEXED (z) = NO_MOID; + NAME (z) = NO_MOID; + MULTIPLE_MODE (z) = NO_MOID; + NEXT (z) = NO_MOID; + CTYPE (z) = NULL_TREE; + ASM_LABEL (z) = NULL; + return z; +} + +/* New_pack. */ + +PACK_T * +a68_new_pack (void) +{ + PACK_T *z = ggc_cleared_alloc (); + + MOID (z) = NO_MOID; + TEXT (z) = NO_TEXT; + NODE (z) = NO_NODE; + NEXT (z) = NO_PACK; + PREVIOUS (z) = NO_PACK; + return z; +} + +/* New_tag. */ + +TAG_T * +a68_new_tag (void) +{ + TAG_T *z = ggc_cleared_alloc (); + + STATUS (z) = NULL_MASK; + TAG_TABLE (z) = NO_TABLE; + MOID (z) = NO_MOID; + NODE (z) = NO_NODE; + UNIT (z) = NO_NODE; + VALUE (z) = NO_TEXT; + SCOPE (z) = PRIMAL_SCOPE; + SCOPE_ASSIGNED (z) = false; + PRIO (z) = 0; + USE (z) = false; + IN_PROC (z) = false; + HEAP (z) = false; + YOUNGEST_ENVIRON (z) = PRIMAL_SCOPE; + LOC_ASSIGNED (z) = false; + NEXT (z) = NO_TAG; + BODY (z) = NO_TAG; + PORTABLE (z) = true; + VARIABLE (z) = false; + IS_RECURSIVE (z) = false; + PUBLICIZED (z) = true; /* XXX */ + EXPORTED (z) = false; + ASCRIBED_ROUTINE_TEXT (z) = false; + LOWERER (z) = NO_LOWERER; + TAX_TREE_DECL (z) = NULL_TREE; + MOIF (z) = NO_MOIF; + EXTERN_SYMBOL (z) = NO_TEXT; + NUMBER (z) = ++A68_PARSER (tag_number); + return z; +} + +/* Make special, internal mode. */ + +static void +make_special_mode (MOID_T ** n, int m) +{ + (*n) = a68_new_moid (); + ATTRIBUTE (*n) = 0; + NUMBER (*n) = m; + PACK (*n) = NO_PACK; + SUB (*n) = NO_MOID; + EQUIVALENT (*n) = NO_MOID; + DEFLEXED (*n) = NO_MOID; + NAME (*n) = NO_MOID; + SLICE (*n) = NO_MOID; + TRIM (*n) = NO_MOID; + ROWED (*n) = NO_MOID; +} + +/* Whether attributes match in subsequent nodes. */ + +bool +a68_whether (NODE_T * p, ...) +{ + va_list vl; + va_start (vl, p); + int a; + while ((a = va_arg (vl, int)) != STOP) + { + if (p != NO_NODE && a == WILDCARD) + FORWARD (p); + else if (p != NO_NODE && (a == KEYWORD)) + { + if (a68_find_keyword_from_attribute (A68 (top_keyword), ATTRIBUTE (p)) != NO_KEYWORD) + FORWARD (p); + else + { + va_end (vl); + return false; + } + } + else if (p != NO_NODE && (a >= 0 ? a == ATTRIBUTE (p) : (-a) != ATTRIBUTE (p))) + FORWARD (p); + else + { + va_end (vl); + return false; + } + } + va_end (vl); + return true; +} + +/* Whether one of a series of attributes matches a node. */ + +bool +a68_is_one_of (NODE_T *p, ...) +{ + if (p != NO_NODE) + { + bool match = false; + int a; + + va_list vl; + va_start (vl, p); + while ((a = va_arg (vl, int)) != STOP) + match = (match | IS (p, a)); + va_end (vl); + return match; + } + else + return false; +} + + +/* Isolate nodes p-q making p a branch to p-q + + From x - p - a - b - c - q - y + To x - t - y + | + p - a - b - c - q +*/ + +void +a68_make_sub (NODE_T *p, NODE_T *q, enum a68_attribute t) +{ + NODE_T *z = a68_new_node (); + + gcc_assert (p != NO_NODE && q != NO_NODE); + *z = *p; + + if (GINFO (p) != NO_GINFO) + GINFO (z) = a68_new_genie_info (); + + PREVIOUS (z) = NO_NODE; + + if (p == q) + NEXT (z) = NO_NODE; + else + { + if (NEXT (p) != NO_NODE) + PREVIOUS (NEXT (p)) = z; + NEXT (p) = NEXT (q); + if (NEXT (p) != NO_NODE) + PREVIOUS (NEXT (p)) = p; + NEXT (q) = NO_NODE; + } + + SUB (p) = z; + ATTRIBUTE (p) = t; +} + +/* Find symbol table at level I. */ + +static TABLE_T * +find_level (NODE_T *n, int i) +{ + if (n == NO_NODE) + return NO_TABLE; + else + { + TABLE_T *s = TABLE (n); + + if (s != NO_TABLE && LEVEL (s) == i) + return s; + else if ((s = find_level (SUB (n), i)) != NO_TABLE) + return s; + else if ((s = find_level (NEXT (n), i)) != NO_TABLE) + return s; + else + return NO_TABLE; + } +} + +/* Whether P is top of lexical level. */ + +bool +a68_is_new_lexical_level (NODE_T *p) +{ + switch (ATTRIBUTE (p)) + { + case ALT_DO_PART: + case BRIEF_ELIF_PART: + case BRIEF_OUSE_PART: + case BRIEF_CONFORMITY_OUSE_PART: + case CHOICE: + case CLOSED_CLAUSE: + case CONDITIONAL_CLAUSE: + case DO_PART: + case ELIF_PART: + case ELSE_PART: + case CASE_CLAUSE: + case CASE_CHOICE_CLAUSE: + case CASE_IN_PART: + case CASE_OUSE_PART: + case OUT_PART: + case ROUTINE_TEXT: + case SPECIFIED_UNIT: + case THEN_PART: + case CONFORMITY_CLAUSE: + case CONFORMITY_CHOICE: + case CONFORMITY_IN_PART: + case CONFORMITY_OUSE_PART: + case WHILE_PART: + case DEF_PART: + case POSTLUDE_PART: + case ACCESS_CLAUSE: + return true; + case MODULE_TEXT: + /* Module texts introduce an additional lexical level encompassing all + its parts only if it is endowed with revelations. */ + if (SUB (p) != NO_NODE && IS (SUB (p), REVELATION_PART)) + return true; + else + return false; + break; + default: + return false; + } +} + +/* + * Couple of utility functions. + */ + +/* Safely append to buffer. */ + +void +a68_bufcat (char *dst, const char *src, int len) +{ + if (src != NO_TEXT) { + char *d = dst; + const char *s = src; + int n = len; +// Find end of dst and left-adjust; do not go past end + for (; n-- != 0 && d[0] != '\0'; d++) { + ; + } + int dlen = (int) (d - dst); + n = len - dlen; + if (n > 0) { + while (s[0] != '\0') { + if (n != 1) { + (d++)[0] = s[0]; + n--; + } + s++; + } + d[0] = '\0'; + } +// Better sure than sorry + dst[len - 1] = '\0'; + } +} + +/* Safely copy to buffer. */ + +void +a68_bufcpy (char *dst, const char *src, int len) +{ + if (src != NO_TEXT) { + char *d = dst; + const char *s = src; + int n = len; +// Copy as many as fit + if (n > 0 && --n > 0) { + do { + if (((d++)[0] = (s++)[0]) == '\0') { + break; + } + } while (--n > 0); + } + if (n == 0 && len > 0) { +// Not enough room in dst, so terminate + d[0] = '\0'; + } +// Better sure than sorry + dst[len - 1] = '\0'; + } +} + +/* Make a new copy of concatenated strings. */ + +char * +a68_new_string (const char *t, ...) +{ + va_list vl; + va_start (vl, t); + const char *q = t; + if (q == NO_TEXT) { + va_end (vl); + return NO_TEXT; + } + int len = 0; + while (q != NO_TEXT) { + len += (int) strlen (q); + q = va_arg (vl, char *); + } + va_end (vl); + len++; + char *z = (char *) xmalloc ((size_t) len); + z[0] = '\0'; + q = t; + va_start (vl, t); + while (q != NO_TEXT) { + a68_bufcat (z, q, len); + q = va_arg (vl, char *); + } + va_end (vl); + return z; +} + +/* Tie label to the clause it is defined in. */ + +static void +tie_label_to_serial (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, SERIAL_CLAUSE)) + { + bool valid_follow; + + if (NEXT (p) == NO_NODE) + valid_follow = true; + else if (IS (NEXT (p), CLOSE_SYMBOL)) + valid_follow = true; + else if (IS (NEXT (p), END_SYMBOL)) + valid_follow = true; + else if (IS (NEXT (p), OD_SYMBOL)) + valid_follow = true; + else + valid_follow = false; + + if (valid_follow) + JUMP_TO (TABLE (SUB (p))) = NO_NODE; + } + + tie_label_to_serial (SUB (p)); + } +} + +/* Tie label to the clause it is defined in. */ + +static void +tie_label (NODE_T *p, NODE_T *unit) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, DEFINING_IDENTIFIER)) + UNIT (TAX (p)) = unit; + tie_label (SUB (p), unit); + } +} + +/* Tie label to the clause it is defined in. */ + +static void +tie_label_to_unit (NODE_T *p) +{ + for (; p != NO_NODE; FORWARD (p)) + { + if (IS (p, LABELED_UNIT)) + tie_label (SUB_SUB (p), NEXT_SUB (p)); + tie_label_to_unit (SUB (p)); + } +} + +/* Table with attribute names. */ + +static const char *attribute_names[] = +{ + "STOP", +#define A68_ATTR(ATTR,DESCR) DESCR, +#include "a68-parser-attrs.def" +#undef A68_ATTR +}; + +/* Get the name of an attribute. */ + +const char * +a68_attribute_name (enum a68_attribute attr) +{ + return attribute_names[attr]; +} + +/* Get the location of node P as a GCC location. */ + +location_t +a68_get_node_location (NODE_T *p) +{ + LINE_T *line = LINE (INFO (p)); + + if (line == NO_LINE) + return UNKNOWN_LOCATION; + + unsigned line_number = NUMBER (line); + unsigned column_number = CHAR_IN_LINE (INFO (p)) - STRING (line) + 1; + const char *filename = FILENAME (line); + + location_t gcc_location; + + linemap_add (line_table, LC_ENTER, 0, filename, line_number); + linemap_line_start (line_table, line_number, 0); + gcc_location = linemap_position_for_column (line_table, column_number); + linemap_add (line_table, LC_LEAVE, 0, NULL, 0); + + return gcc_location; +} + +/* Get the location of POS inside LINE as a GCC location. */ + +location_t +a68_get_line_location (LINE_T *line, const char *pos) +{ + location_t loc; + + linemap_add (line_table, LC_ENTER, 0, FILENAME (line), NUMBER (line)); + linemap_line_start (line_table, NUMBER (line), 0); + loc = linemap_position_for_column (line_table, pos - STRING (line) + 1); + linemap_add (line_table, LC_LEAVE, 0, NULL, 0); + return loc; +} diff --git a/gcc/algol68/a68-postulates.cc b/gcc/algol68/a68-postulates.cc new file mode 100644 index 000000000000..f291205114d4 --- /dev/null +++ b/gcc/algol68/a68-postulates.cc @@ -0,0 +1,103 @@ +/* Postulates needed for improving equivalence of modes. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +/* Initialise use of postulate-lists. */ + +void +a68_init_postulates (void) +{ + A68 (top_postulate) = NO_POSTULATE; + A68 (top_postulate_list) = NO_POSTULATE; +} + +/* Make old postulates available for new use. */ + +void +a68_free_postulate_list (POSTULATE_T *start, POSTULATE_T *stop) +{ + if (start == stop) + return; + + POSTULATE_T *last = start; + for (; NEXT (last) != stop; FORWARD (last)) + ; + + NEXT (last) = A68 (top_postulate_list); + A68 (top_postulate_list) = start; +} + +/* Add postulates to postulate-list. */ + +void +a68_make_postulate (POSTULATE_T **p, MOID_T *a, MOID_T *b) +{ + POSTULATE_T *new_one; + + if (A68 (top_postulate_list) != NO_POSTULATE) + { + new_one = A68 (top_postulate_list); + A68 (top_postulate_list) = A68 (top_postulate_list)->next; + } + else + { + new_one = (POSTULATE_T *) ggc_cleared_alloc (); + A68 (new_postulates)++; + } + + new_one->a = a; + new_one->b = b; + new_one->next = *p; + *p = new_one; +} + +/* Where postulates are in the list. */ + +POSTULATE_T +*a68_is_postulated_pair (POSTULATE_T *p, MOID_T *a, MOID_T *b) +{ + for (; p != NO_POSTULATE; p = p->next) + { + if (p->a == a && p->b == b) + return p; + } + + return NO_POSTULATE; +} + +/* Where postulate is in the list. */ + +POSTULATE_T +*a68_is_postulated (POSTULATE_T *p, MOID_T *a) +{ + for (; p != NO_POSTULATE; p = p->next) + { + if (p->a == a) + return p; + } + + return NO_POSTULATE; +} diff --git a/gcc/algol68/a68-tree.def b/gcc/algol68/a68-tree.def new file mode 100644 index 000000000000..1d7c644988f7 --- /dev/null +++ b/gcc/algol68/a68-tree.def @@ -0,0 +1,24 @@ +/* This file contains the definitions and documentation for the + additional tree codes used in the GNU Algol 68 compiler (see + tree.def for the standard codes). + Copyright (C) 2025 Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation; either version 3, or (at your option) any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along with + GCC; see the file COPYING3. If not see . */ + +/* Tree nodes used in the Algol68 frontend only. */ + +/* +Local variables: +mode:c +End: +*/ diff --git a/gcc/algol68/a68-types.h b/gcc/algol68/a68-types.h new file mode 100644 index 000000000000..df9133fb12fe --- /dev/null +++ b/gcc/algol68/a68-types.h @@ -0,0 +1,1166 @@ +/* Type definitions for the ALGOL 68 parser. + Copyright (C) 2001-2023 J. Marcel van der Veer. + Copyright (C) 2025 Jose E. Marchesi. + + Original implementation by J. Marcel van der Veer. + Adapted for GCC by Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#ifndef __A68_TYPES_H__ +#define __A68_TYPES_H__ + +#include "config.h" +#include "system.h" + +#include +#include "vec.h" + +/* Enumerations. */ + +enum a68_stropping +{ + UPPER_STROPPING, + SUPPER_STROPPING +}; + +enum a68_attribute +{ + STOP = 0, +#define A68_ATTR(ATTR,DESCR) ATTR, +#include "a68-parser-attrs.def" +#undef A68_ATTR +}; + +enum a68_tree_index +{ + /* Type trees. */ + ATI_VOID_TYPE, + ATI_BOOL_TYPE, + ATI_CHAR_TYPE, + ATI_SHORT_SHORT_BITS_TYPE, + ATI_SHORT_BITS_TYPE, + ATI_BITS_TYPE, + ATI_LONG_BITS_TYPE, + ATI_LONG_LONG_BITS_TYPE, + ATI_BYTES_TYPE, + ATI_LONG_BYTES_TYPE, + ATI_SHORT_SHORT_INT_TYPE, + ATI_SHORT_INT_TYPE, + ATI_INT_TYPE, + ATI_LONG_INT_TYPE, + ATI_LONG_LONG_INT_TYPE, + ATI_REAL_TYPE, + ATI_LONG_REAL_TYPE, + ATI_LONG_LONG_REAL_TYPE, + /* Sentinel. */ + ATI_MAX +}; + +/* + * Type definitions. + */ + +typedef char BUFFER[BUFFER_SIZE + 1]; + +typedef struct MODES_T MODES_T; +typedef struct NODE_T NODE_T; +typedef struct MODE_CACHE_T MODE_CACHE_T; +typedef struct MOID_T MOID_T; +typedef struct GINFO_T GINFO_T; +typedef struct KEYWORD_T KEYWORD_T; +typedef struct LINE_T LINE_T; +typedef struct NODE_INFO_T NODE_INFO_T; +typedef struct PACK_T PACK_T; +typedef struct SOID_T SOID_T; +typedef struct TABLE_T TABLE_T; +typedef struct TAG_T TAG_T; +typedef struct TOKEN_T TOKEN_T; +typedef struct ORIGIN_T ORIGIN_T; +typedef struct POSTULATE_T POSTULATE_T; +typedef struct OPTIONS_T OPTIONS_T; +typedef struct PARSER_T PARSER_T; +typedef struct MODULE_T MODULE_T; +typedef struct EXTRACT_T EXTRACT_T; +typedef struct MOIF_T MOIF_T; +typedef struct A68_T A68_T; + +#define NO_A68_REF ((A68_REF *) 0) +#define NO_ARRAY ((A68_ARRAY *) 0) +#define NO_BOOK ((BOOK_T *) 0) +#define NO_BOOL ((bool *) 0) +#define NO_BYTE ((BYTE_T *) 0) +#define NO_CONSTANT ((void *) 0) +#define NO_DEC ((DEC_T *) 0) +#define NO_EDLIN ((EDLIN_T *) 0) +#define NO_FILE ((FILE *) 0) +#define NO_FORMAT ((A68_FORMAT *) 0) +#define NO_GINFO ((GINFO_T *) 0) +#define NO_GPROC ((void (*) (NODE_T *)) 0) +#define NO_HANDLE ((A68_HANDLE *) 0) +#define NO_INT ((int *) 0) +#define NO_JMP_BUF ((jmp_buf *) 0) +#define NO_KEYWORD ((KEYWORD_T *) 0) +#define NO_NINFO ((NODE_INFO_T *) 0) +#define NO_NOTE ((void (*) (NODE_T *)) 0) +#define NO_OPTION_LIST ((OPTION_LIST_T *) 0) +#define NO_PACK ((PACK_T *) 0) +#define NO_PPROC ((PROP_T (*) (NODE_T *)) 0) +#define NO_PROCEDURE ((A68_PROCEDURE *) 0) +#define NO_REAL ((REAL_T *) 0) +#define NO_REFINEMENT ((REFINEMENT_T *) 0) +#define NO_REGMATCH ((regmatch_t *) 0) +#define NO_SCOPE ((SCOPE_T *) 0) +#define NO_SOID ((SOID_T *) 0) +#define NO_STREAM NO_FILE +#define NO_TEXT ((char *) 0) +#define NO_TICK ((bool *) 0) +#define NO_TOKEN ((TOKEN_T *) 0) +#define NO_TUPLE ((A68_TUPLE *) 0) +#define NO_VAR (0) + +/* A STATUS_MASK_T is a word of flags denoting states. + + Status masks are used in parse tree nodes (NODE_T) and in entries in the + symbol table (TAG_T). + + + SCOPE_ERROR_MASK is used by the static scope checker in order to avoid + emitting duplicated scope warnings. */ + +typedef uint32_t STATUS_MASK_T; + +#define STATUS_CLEAR(p, q) {STATUS (p) &= (~(q));} +#define STATUS_SET(p, q) {STATUS (p) |= (q);} +#define STATUS_TEST(p, q) ((STATUS (p) & (q)) != (uint32_t) 0) + +#define NULL_MASK ((STATUS_MASK_T) 0x00000000) +#define SCOPE_ERROR_MASK ((STATUS_MASK_T) 0x00000200) + +/* Structure containing the lowering context which is propagated while calling + the lowering handlers. */ + +struct LOW_CTX_T +{ + /* The common declarer in a declaration list. */ + NODE_T **declarer; + /* The defining identifier of the procedure declaration being processed, or + NO_NODE. This is set by a68_lower_procedure_declaration and used by + a68_lower_routine_text. */ + NODE_T *proc_decl_identifier; + /* If proc_decl_identifier is no NO_NODE, this denotes whether the + declaration being processed is of an operator. */ + bool proc_decl_operator; + /* Name of current module definition, or NULL. */ + const char *module_definition_name; + /* For debugging purposes. */ + int level; +}; + +typedef struct LOW_CTX_T LOW_CTX_T; + +/* Type of the lowerer routines defined in a68-low-prelude.cc. */ +typedef tree (*LOWERER_T) (struct NODE_T *, struct LOW_CTX_T); + +#define NO_LOWERER a68_lower_unimplemented + +struct GTY((chain_next ("%h.more"), chain_prev ("%h.less"))) KEYWORD_T +{ + enum a68_attribute attribute; + const char *text; + KEYWORD_T *less, *more; +}; + +/* A MOID_T represents a mode indicator. + + NUMBER is an unique number assigned to the moid when it gets created. A + renumber_moids function exists in a68-parser-modes.cc but it dosn't seem to + be used at all. + + ATTRIBUTE characterizes the kind of mode and is one of the values defined in + a68-parser-attrs.def. Valid values are: + + PROC_SYMBOL for procecure modes. + ROWS_SYMBOL for row modes. + REF_SYMBOL for reference modes. + FLEX_SYMBOL for flexible reference modes. + STRUCT_SYMBOL for struct modes. + UNION_SYMBOL for union modes. + IN_TYPE_MODE for XXX modes. + OUT_TYPE_MODE for XXX modes. + SERIES_MODE for XXX modes. + INDICANT for XXX modes. + MODULE_INDICANT for XXX modules. + STANDARD for standard modes. + + NODE is a parse tree node XXX. + + HAS_ROWS is true if the mode contains rows somewhere in its internal + structure. + + The interpretation of SUB depends on the kind of mode: + - For REF modes it is the referred mode. + - For FLEX modes it is the referred mode. + - For ROW modes it is the mode of the elements. + - For PROC modes it is the mode of the value yielded by the procedure. + + The interpretation of DIM depends on the kind of mode: + - In VOID_SYMBOL, STANDARD or INDICANT mode, if DIM is positive it + specifies the size of the longsety of the mode. If DIM is negative then + abs (DIM) is the size of hte shortsety of the mode. + - In ROW modes, DIM is the number of dimensions. + - In STRUCT modes, DIM is the number of fields. + - In UNION modes, DIM is the number of united modes. + - In PROC_SYMBOL modes, DIM is the number of arguments. + - In SERIES_MODE and STOWED_MODE modes, DIM is the number modes. + + SLICE is the mode resulting from slicing a value of this mode. For example, + slicing a M_ROW_INT yields a M_INT. + + EQUIVALENT_MODE (referred as EQUIVALENT), for INDICANTs it is its declarer + mode (in MODE FOO = BAR FOO is the indicant and BAR is its declarer) and for + STANDARD modes it may be a mode that reflects its structure. + + USE is used by the is_well_formed function, which detects whether a mode is + well formed, i.e. that the mode doesn't refer to itself nor it relates to + void. + + DEFLEXED_MODE is like the current mode, but without FLEX. Only defined for + modes that have a SUB, i.e. REF, FLEX, ROW and PROC. In other modes this is + NO_MODE. + + For refs to structs, rows or flex, NAME points to the corresponding name + mode. For example, for a mode REF STRUCT (INT i, REAL x), NAME points to a + mode STRUCT (REF INT i, REF REAL x). This is used for selections. + + For rows of structs, rows or flex, MULTIPLE points to the corresponding row + mode. For example, for a mode [] STRUCT (INT i, REAL x), MULTIPLE points to + a mode STRUCT ([]INT i, []REAL x). This is used for selections. + + PACK is a pack of moids. For a STOWED_MODE, it contains the modes of the + arguments of a procedure, or the modes of the units in a collateral clause. + For a SERIES_MODE, it contains the modes of the completing units in a serial + clause, the alternatives in a conformity clause, the alternatives in a + CONDITIONAL_CLAUSE, the alternatives in a CASE_CLAUSE, + + CTYPE is a GCC GENERIC tree corresponding to this mode. It is computed and + installed by a68_lower_moid. + + ASM_LABEL is an assembly label used by a68_asm_output_mode. */ + +#define NO_MOID ((MOID_T *) 0) + +struct GTY((chain_next ("%h.next"))) MOID_T +{ + int number; + int attribute; + int dim; + bool has_rows, use, portable, derivate; + NODE_T *node; + PACK_T *pack; + MOID_T *sub, *equivalent_mode, *slice, *deflexed_mode, *name, *multiple_mode, *next, *rowed, *trim; + tree ctype; + const char *asm_label; +}; + +/* A MODES_T struct contains a collection of particular pre-defined modes. + + These modes are initialized by either stand_moids or make_special_mode. + They are commonly referred using the corresponding M_* macros. + + ROWS is a mode to which any ROW mode can be strongly coerced. It is used as + the mode of the second operand of the ELEMS, LWB and UPB operators. + + HIP is the mode of NIL. */ + +struct MODES_T +{ + MOID_T *BITS, *BOOL, *BYTES, *CHANNEL, *CHAR, *COLLITEM, *COMPL, *COMPLEX, + *C_STRING, *ERROR, *FILE, *FORMAT, *HEX_NUMBER, *HIP, *INT, *LONG_BITS, *LONG_BYTES, + *LONG_COMPL, *LONG_COMPLEX, *LONG_INT, *LONG_LONG_BITS, *LONG_LONG_COMPL, + *LONG_LONG_COMPLEX, *LONG_LONG_INT, *LONG_LONG_REAL, *LONG_REAL, *NUMBER, + *PROC_REAL_REAL, *PROC_LONG_REAL_LONG_REAL, *PROC_REF_FILE_BOOL, *PROC_REF_FILE_VOID, *PROC_ROW_CHAR, + *PROC_STRING, *PROC_VOID, *REAL, *REF_BITS, *REF_BOOL, *REF_BYTES, + *REF_CHAR, *REF_COMPL, *REF_COMPLEX, *REF_FILE, *REF_INT, + *REF_LONG_BITS, *REF_LONG_BYTES, *REF_LONG_COMPL, *REF_LONG_COMPLEX, + *REF_LONG_INT, *REF_LONG_LONG_BITS, *REF_LONG_LONG_COMPL, + *REF_LONG_LONG_COMPLEX, *REF_LONG_LONG_INT, *REF_LONG_LONG_REAL, *REF_LONG_REAL, + *REF_REAL, *REF_REF_FILE, *REF_ROW_CHAR, *REF_ROW_COMPLEX, *REF_ROW_INT, + *REF_ROW_REAL, *REF_ROW_ROW_COMPLEX, *REF_ROW_ROW_REAL, + *REF_SHORT_BITS, *REF_SHORT_SHORT_BITS, *REF_SHORT_INT, + *REF_SHORT_SHORT_INT, *REF_STRING, + *ROW_BITS, *ROW_BOOL, *ROW_CHAR, *ROW_COMPLEX, *ROW_INT, *ROW_LONG_BITS, *ROW_LONG_LONG_BITS, + *ROW_REAL, *ROW_ROW_CHAR, *ROW_ROW_COMPLEX, *ROW_ROW_REAL, *ROWS, *ROW_SIMPLIN, *ROW_SIMPLOUT, + *ROW_STRING, *SEMA, *SHORT_BITS, *SHORT_SHORT_BITS, *SHORT_INT, *SHORT_SHORT_INT, + *SIMPLIN, *SIMPLOUT, *STRING, *FLEX_ROW_CHAR, + *FLEX_ROW_BOOL, *UNDEFINED, *VACUUM, *VOID; +}; + +/* The OPTIONS_T structure record which front-end options have been activated. + Each option OPTION has a corresponding GCC -f[no-]a68-OPTION command-line + switch that can be used to activate or deactivate it. + + STROPPING indicates the stropping regime in use. It can be UPPER_STROPPING + or SUPPER_STROPPING. + + BRACKETS indicates whether [ .. ] and { .. } are equivalent to ( .. ). + + STRICT indicates that no ALGOL 68 extension is allowed. + + ASSERT indicates whether to generate code for assertions. + + BOUNDS_CHECKING indicates whether to perform array bound checking at + run-time. + + NIL_CHECKING indicates whether to check for NIL when dereferencing at + run-time. */ + +struct GTY(()) OPTIONS_T +{ + enum a68_stropping stropping; + bool brackets; + bool strict; + bool assert; + bool bounds_checking; + bool nil_checking; +}; + +/* The access class static property of a stored value determines how the value + can be reached at run-time. It is used by the lowering pass in order to + minimize copies at run-time. + + CONSTANT is for constant literals. At run-time these literals will either + reside in operand instructions or in space allocated in CONSTAB%. + + DIRIDEN (direct identifier) means that the value is stored on IDST% at some + static address. This is the access class used for values ascribed to + identifiers as long as the block in hich they are declared has not been + left. It is also used for values resulting from actions such as the + selection from a value possessed by an identifier or the dereferencing fo a + name corespodning to a variable. + + VARIDEN (variable identifier) is used for values which are names/variables. + The name is stored on IDST%. The static elaboration of the dereferencing of + a variable with access VARIDEN results in a value with access DIRIDEN, not + requiring any run-time action. Same happens with selections of variables of + access VARIDEN. + + INDIDEN (indirect identifier) is used for values that are stored in a memory + location in IDST%. The static elaboration of a dereferencing applied to a + value of access DIRIDEN. + + DIRWOST (direct working stack) is very much like DIRIDEN, except that the + value is stored in WOST% rathern than in IDST%. This access is used for the + result of an action when this result does not preexist in memory and hence + has to be constructed in WOST%. + + INDWOST (indirect working stack) is very similar to INDIDEN. Such an access + can be obtained for example through the static elaboration of the + dereferencing of a name the access of which is DIRWOST. + + NIHIL is used to characterize the absence of value. This is used in the + static elaboration of a jump, a voiding and a call ith a void result. + + Note that in all these classes we assume as run-time the intermediate + language level we are lowering to, i.e. GENERIC. A DIRIDEN value, for + example, can very well stored in a register depending on further compiler + optimizations. */ + +#define ACCESS_NIHIL 0 +#define ACCESS_CONSTANT 1 +#define ACCESS_DIRIDEN 2 +#define ACCESS_INDIDEN 3 +#define ACCESS_DIRWOST 4 + +/* A NODE_T is a node in the A68 Syntax tree produced by the lexer-scanner and + later expanded by the Mailloux parser. + + NUMBER identifies the node uniquely in the syntax tree. + + ATTRIBUTE is a code that specifies the kind of entity denoted by the node. + Valid attributes are defined in the enumeration a68_attribute above in + this file. Examples of attributes are ELIF_PART, GOTO_SYMBOL or BOLD_TAG. + + ANNOTATION provides a way to annotate a node with a reference to another + node attribute. This is currently used by the mode checker to annotate + indexer nodes as slicer or as trimmers. + + TYPE (accessed as MOID) is either NO_MOID if the entity denoted by the node + doesn't have a mode, or a suitable MOID_T reflecting the mode of the entity. + This attribute is calculated and set in all the nodes of the tree by the + mode collection and checker pass implemented by make_moid_list. + + INFO contains additional attributes of the node. See NODE_INFO_T below. + + NEXT, PREVIOUS and SUB are links to other tree nodes. They are used to link + the syntax tree structure from the top: + + TOP <-> N <-> N <-> ... + | < is PREVIOUS + N <-> N <-> ... > is NEXT + | | is SUB + N <-> ... + + SEQUENCE is a link to another tree node. It is used by the tax collector + (symbol table builder) in order to handle DO .. OD ranges. + + NEST is a link to another tree node, which is the NEST for the current node. + It is set by the tax collector (symbol table builder) and it is used for + diagnostics. + + PACK (accessed as NODE_PACK) is either NO_PACK or an instance of the PACK_T + structure defined below. It is used by the modes checker. + + STATUS is a mask of flags, used by several passes that handle nodes. Valid status flags are: + + SYMBOL_TABLE (accessed as TABLE) is either NO_TABLE or a TABLE_T containing + a symbol table introduced by the entity denoted by the tree node. These + nodes are the ones introducing ranges: BEGIN, DO, etc. + + NON_LOCAL is either NO_TABLE, if the environ established by the node is + local, or a pointer to a TABLE_T identifying the non-local environment + associated with the tree node. It is set by the static scope checker. See + 3.2.2 and 5.2.3.2.b in the report for its application in the handling of + local generators in serial clauses. + + TAG (accessed as TAX) is either NO_TAG or a TAG_T used to bind identifier + nodes, routine texts and other indicants to their corresponding entry in a + symbol table. This is set by the taxes collector. + + The following fields are static properties managed an used in the lowering + pass. + + ORIGIN is a static property that describes the history of the entity denoted + by the node. This is only used in nodes denoting values. + + DYNAMIC_STACK_ALLOCS is a flag used in serial clause nodes. It determines + whether the elaboration of the phrases in the serial clause may involve + dynamic stack allocation. This is used by the lower pass, along with + NON_LOCAL above, in order to properly manage the stack pointer while + lowering these clauses. + + PUBLICIZED is true for DEFINING_OPERATOR, DEFINING_IDENTIFIER and + DEFINING_INDICANT nodes that appear in declarations marked with PUB. + + CDECL is a GCC GENERIC tree corresponding to a DECL_FIELD for FIELD + nodes. */ + +struct GTY((chain_next ("%h.next"), chain_prev ("%h.previous"))) NODE_T +{ + GINFO_T *genie; + int number; + enum a68_attribute attribute; + enum a68_attribute annotation; + MOID_T *type; + NODE_INFO_T *info; + NODE_T *next, *previous, *sub; + NODE_T *sequence, *nest; + PACK_T *pack; + STATUS_MASK_T status; + TABLE_T *symbol_table; + TABLE_T *non_local; + TAG_T *tag; + tree cdecl; + bool dynamic_stack_allocs; + bool publicized; +}; + +#define NO_NODE ((NODE_T *) 0) + +/* A NODE_INFO_T struct contains additional attributes of a NODE_T parse tree + node. + + PROCEDURE_LEVEL indicates how lexically deep the tree node is in terms of + routine texts. This attribute is set for all the nodes in the syntax tree + by the taxes collector and originally used by ALGOL 68 Genie's monitor. + Even if at the moment this is not used by GCC, this field and the + correponding machinery is still here in case it is useful in the future. + + PRIORITY (accessed as PRIO) is used by operator tree nodes and specifies the + priority of the operator denoted by the node. This is set tree wide by the + bottom-up parser. + + SYMBOL (accessed indirectly as NSYMBOL) contains the symbol value, a string, + corresponding to the tree node. This is used by tree nodes representing + tokens such as bold tags, keywords and identifiers. The symbols are set by + the parser-scanner. + + LINE is a pointer to the source line from which the tree node originates. + This is set for tree nodes representing tokens and is set by the + parser-scanner. */ + +struct GTY(()) NODE_INFO_T +{ + int procedure_level; + int priority; + char * GTY((skip)) char_in_line; + int comment_type; + char * GTY((skip)) comment; + LINE_T *comment_line; + char * GTY((skip)) comment_char_in_line; + int pragmat_type; + char * GTY((skip)) pragmat; + LINE_T *pragmat_line; + char * GTY((skip)) pragmat_char_in_line; + const char *symbol; + LINE_T *line; +}; + +struct GTY(()) GINFO_T +{ + MOID_T *partial_proc, *partial_locale; +}; + +struct GTY((chain_next ("%h.next"), chain_prev ("%h.previous"))) PACK_T +{ + MOID_T *type; + const char *text; + NODE_T *node; + PACK_T *next, *previous; +}; + +/* Postulates. */ + +struct GTY((chain_next ("%h.next"))) POSTULATE_T +{ + MOID_T *a, *b; + POSTULATE_T *next; +}; + +#define NO_POSTULATE ((POSTULATE_T *) 0) + +struct GTY((chain_next ("%h.next"))) SOID_T +{ + int attribute, sort, cast; + MOID_T *type; + NODE_T *node; + SOID_T *next; +}; + +struct GTY((chain_next ("%h.next"))) LINE_T +{ + char marker[6]; + char * GTY((skip)) string; + const char *filename; + int number; + LINE_T *next, *previous; +}; +#define NO_LINE ((LINE_T *) 0) + +/* Symbol table. + + PUBLIC_RANGE is true in ranges whose declarations may be made accessible to + other compilation units. decl trees lowered for declarations in public + ranges will be put in the top-level block. This is used for top-level + module declarations. */ + +struct GTY(()) TABLE_T +{ + int num, level, nest, attribute; + bool initialise_frame, initialise_anon, proc_ops, public_range; + TABLE_T *previous, *outer; + TAG_T *identifiers, *operators, *modules, *priority, *indicants, *labels, *anonymous; + NODE_T *jump_to, *sequence; +}; +#define NO_TABLE ((TABLE_T *) 0) + +/* A TAG_T structure denotes an entry in the symbol table. Each entry + corresponds to an identity. + + TAX: TAG; TAB; TAD; TAM; + + TYPE is the mode of the entry. + + NODE is the defining identifier associated to the declaration. + + SCOPE is the lexical depth of the tag. Zero corresponds to the primal + scope. It is set by the static scope checker. + + SCOPE_ASSIGNED determines whether a SCOPE has been actually assigned to the + tag. It is set by the static scope checker. The entities which get + assigned scopes are identities of format texts and routine texts. + + PORTABLE determines whether the construction associated with the tag is + Algol 68 or some extension. + + VARIABLE is set when the defining identifier in NODE is defined in a + variable declaration, as opposed to an identity declaration. This is set by + extract_variables and is used by the lowering pass. + + HEAP is used for defining identifier in NODE is defined in a variable + declaration. It is HEAP_SYMBOL or LOC_SYMBOL. + + IS_RECURSIVE is set for mode indicants whose definition is recursive, + i.e. they appear in actual declarers within its own definition. + + PUBLICIZED is set for tags that are marked as public and therefore shall be + exported as part of a module interface. + + EXPORTED is set for DEFINING_MODULEs whose module interface is to be + exported. + + ASCRIBED_ROUTINE_TEXT is set when the defining identifier is ascribed a + routine-text in an identity declaration. + + IN_PROC is set when the defining identifier has been set in a + proc-identity-declaration or in a brief-op-declaration. These declarations + are optimized in a similar way than variable declarations in order to avoid + indirect addressing. + + YOUNGEST_ENVIRON is used when NODE is either a ROUTINE_TEXT or a + FORMAT_TEXT, and contains the youngest (higher) lexical level of any object + directly declared in the routine or format body. This is filled in and used + by the scope checker. + + TREE_DECL is the GENERIC declaration for the definition of this symbol. + This is set and used by the lower pass. For mode indicants, it contains a + function that generates a pointer to the given mode, and is used by + a68_low_generator to handle recursive modes. + + MOIF is a list of module interfaces. This is used in ACCESS_CLAUSE nodes. + + EXTERN_SYMBOL is a string with the symbol that was obtained from an imported + module declaration. This is only used in entries where MOIF is not NO_MOIF. + + LOWERER is a lowering routine defined in a68-low-prelude.cc. These are used + in taxes that denote some pre-defined operator. */ + +struct GTY((chain_next ("%h.next"))) TAG_T +{ + TABLE_T *symbol_table; + MOID_T *type; + NODE_T *node, *unit; + const char *value; + bool scope_assigned, use, in_proc, loc_assigned, portable, variable; + bool ascribed_routine_text, is_recursive, publicized, exported; + int priority, heap, scope, youngest_environ, number; + STATUS_MASK_T status; + tree tree_decl; + MOIF_T *moif; + LOWERER_T lowerer; + TAG_T *next, *body; + const char *extern_symbol; +}; +#define NO_TAG ((TAG_T *) 0) + +struct GTY((chain_next ("%h.more"), chain_prev ("%h.less"))) TOKEN_T +{ + const char *text; + TOKEN_T *less, *more; +}; +#define NO_TOKEN ((TOKEN_T *) 0) + +struct GTY(()) MODULE_T +{ + bool tree_listing_safe, cross_reference_safe; + int error_count, warning_count, source_scan; + LINE_T *top_line; + MOID_T *top_moid, *standenv_moid; + NODE_T *top_node; + OPTIONS_T options; + FILE * GTY ((skip)) file_source_fd; + const char *file_source_name; + struct + { + LINE_T *save_l; + char * GTY((skip)) save_s, GTY((skip)) save_c; + } scan_state; +}; + +/* Module interface extracts. + + KIND is the kind of extract. One of the GA68_EXTRACT_* codes defined in + a68-exports.cc. + + SYMBOL is a string with the symbol name for the entity represented by the + extract. It is mangled. + + MODE applies to identifier, operator and indicatione extracts. + + PRIORITY is the priority number in a priority extract. + + VARIABLE applies to GA68_EXTRACT_IDEN and GA68_EXTRACT_OPER extracts, and + indicates whether the exported symbol was declared via a variable + declaration. These decls are optimized and don't require indirect + addressing. This is compiler-specific and part of mdextra. + + IN_PROC applies to GA68_EXTRACT_IDEN and GA68_EXTRACT_OPER extracts. If + set, the exported symbol shall not be indirected. This is compiler-specific + and part of mdextra. */ + +struct GTY(()) EXTRACT_T +{ + unsigned int kind; + const char *symbol; + MOID_T *mode; + int priority; + bool variable, in_proc; +}; + +/* Module interfaces. + + VERSION is the version of the exports format to report in the encoded data. + + NAME is the name of the module as it is accessed at the source level, which + corresponds to a bold word. + + PRELUDE and POSTLUDE are mangled symbols corresponding to the entry points + of the module's prelude and postlude. + + MODES is a vector of modes which conform the modes table of the module + interface. + + MODULES is a vector of TAGs for module extracts. + INDICANTS is a vector of TAGs for mode extracts. + IDENTIFIERS is a vector of TAGs for identifier extracts. + PRIOS is a vector of TAGs for operator priorities. */ + +#define NO_MOIF ((MOIF_T *) 0) + +struct GTY(()) MOIF_T +{ + unsigned int version; + const char *name; + const char *prelude; + const char *postlude; + vec *modes; + vec *modules; + vec *indicants; + vec *identifiers; + vec *prios; + vec *operators; +}; + +struct MODE_CACHE_T +{ + MOID_T *proc_bool; + MOID_T *proc_char; + MOID_T *proc_complex_complex; + MOID_T *proc_int; + MOID_T *proc_int_int; + MOID_T *proc_int_int_real; + MOID_T *proc_int_real; + MOID_T *proc_int_real_real; + MOID_T *proc_int_real_real_real; + MOID_T *proc_real; + MOID_T *proc_real_int_real; + MOID_T *proc_real_real; + MOID_T *proc_real_real_int_real; + MOID_T *proc_real_real_real; + MOID_T *proc_real_real_real_int; + MOID_T *proc_real_real_real_real; + MOID_T *proc_real_real_real_real_real; + MOID_T *proc_real_real_real_real_real_real; + MOID_T *proc_real_ref_real_ref_int_void; + MOID_T *proc_void; +}; + +/* A PARSER_T struct contains all the global state that is kept by the parser. + This information is managed and used exclusively by a68_parser. + + ERROR_TAG is a tag that signifies an error. It is initialized in + a68_parser. + + STOP_SCANNER is a control flag used exclusively by the main loop in + tokenise_source, which is recursive. + + SCAN_BUF is a scratch buffer used by the scanner for several purposes. This + buffer is known to be big enough to hold any substring from the source file. + It is initialized in read_source_file. + + MAX_SCAN_BUF_LENGTH is the useable size of SCAN_BUF. This is used by the + scanner to grow SCAN_BUF as it includes other files. + + TAG_NUMBER is a global counter used by the parser to assign an unique number + to each tag it creates. It is used in a68_new_tag. + + BOTTOM_UP_CRASH_EXIT and TOP_DOWN_CRASH_EXIT are used to longjmp from deeply + nested errors in the bottom-up and top-down parsers respectively. */ + +struct GTY(()) PARSER_T +{ + TAG_T *error_tag; + bool stop_scanner; + size_t max_scan_buf_length; + char * GTY((skip)) scan_buf; + int tag_number; + jmp_buf GTY((skip)) bottom_up_crash_exit; + jmp_buf GTY((skip)) top_down_crash_exit; +}; + +/* A A68_T struct contains the global state used by the ALGOL 68 front-end. + + OUTPUT_LINE is used by the diagnostics machinery in order to write out + message lines. + + EDIT_LINE is used as a scratch buffer for composing error messages and the + like. + + INPUT_LINE is used by the original ALGOL 68 Genie to read lines from the + tty. But in this parser it is used uninitialized (!) by the + a68_phrase_to_text routine in the top-down parser. XXX. + + NEW_NODES is a global counter that keeps the number of parse tree nodes + created. It is currently not used for anything, but still updated in + a68_new_node. + + NEW_MODES is a global counter that keeps the number of moids created. It is + currently not used for anything, but still updated in a68_new_moid. + + NEW_POSTULATES is a global counter that keeps the number of postulates + created by the front-end. It is currently not used for anything, but still + updated in a68_make_postulate. + + NEW_NODE_INFOS is a global counter that keeps the number of NODE_INFO_T + structures created by the front-end. It is currently not used for anything, + but still updated in a68_new_node_info. + + NEW_GENIE_INFOS is a global counter that keeps the number of GINFO_T + structures created by the front-end. It is currently no tused for anything, + but still updated in a68_new_genie_info. + + SYMBOL_TABLE_COUNT is a global counter used by the parser. XXX move to + parser global state when syntax tree finalisation is moved to a68_parser? + + MODE_COUNT is the number of modes registered in the global modes table. XXX + which table. + + TOP_KEYWORD is the top of the list of keywords known to the font-end. + + MODE_CACHE XXX. + + A68_MODES (accessed as MODE) is a collection of particular pre-defined + modes. These modes are initialized by stand_moids. + + JOB (accessed as A68_JOB) is the instance of MODULE_T with the global data + corresponding to the source file being compiled. + + OPTIONS is the set of options currently set for the front-end. + + TOP_POSTULATE and TOP_POSTULATE_LIST are lists of postulates maintained by + the front-end. + + POSTULATES is a collection of postulates used by the moid pretty printer. + + TOP_SOID_LIST is used by the moid machinery. + + STANDENV XXX. + + TOP_TOKEN XXX. + + INCLUDE_PATHS is the list of paths where we search for files to include. + Directories are added to the list at the option handling language hook. + The list is searched in FIFO order. + + IMPORT_PATHS is the list of paths where we search for module exports data. + Directories are added to the list at the option handling language hook. The + list is searched in FIFO order. + + GLOBAL_TREES is an array with global types like a68_void_type and + a68_long_int_type. It is indexed by an enum a68_tree_index. + + MODULE_DEFINITION_DECLS is the global list of the tree decls corresponding + to the module definition being compiled. Note that currently we only allow + top-level modules, so there is no nesting. This is part of the context of + the lowering pass, and these declarations are collected by the lowering + handlers and finally compiled down to assembler in lower_module_declaration. + It cannot go in LOW_CTX_T because the later is on the stack and is not + reachable by the GGC. + + PARSER_STATE contains the parser's global state. + + GLOBAL_CONTEXT is the context to be used for global declarations. Normally + the translation unit. + + GLOBAL_DECLARATIONS contains a array of global declarations to pass back to + the middle-end at the end of the compilation. +*/ + +struct GTY(()) A68_T +{ + BUFFER output_line; + BUFFER edit_line; + BUFFER input_line; + int new_nodes; + int new_modes; + int new_postulates; + int new_node_infos; + int new_genie_infos; + int symbol_table_count; + int mode_count; + KEYWORD_T *top_keyword; + MODE_CACHE_T mode_cache; + MODES_T a68_modes; + MODULE_T job; + OPTIONS_T *options; + POSTULATE_T *postulates, *top_postulate, *top_postulate_list; + SOID_T *top_soid_list; + TABLE_T *standenv; + TOKEN_T *top_token; + vec *include_paths; + vec *import_paths; + hash_map *module_files; + tree global_trees[ATI_MAX]; + PARSER_T parser_state; + vec *module_definition_decls; + tree global_context; + vec *global_declarations; +}; + +/* + * Access macros to fields in the struct types defined above. These are used * + * in order to achieve a nice ALGOL-like field OF struct style. + */ + +#define ASM_LABEL(m) ((m)->asm_label) +#define BACKWARD(p) (p = PREVIOUS (p)) +#define DEFLEX(p) (DEFLEXED (p) != NO_MOID ? DEFLEXED(p) : (p)) +#define FORWARD(p) ((p) = NEXT (p)) +#define A(p) ((p)->a) +#define ANNOTATION(p) ((p)->annotation) +#define ANONYMOUS(p) ((p)->anonymous) +#define ATTRIBUTE(p) ((p)->attribute) +#define ASCRIBED_ROUTINE_TEXT(p) ((p)->ascribed_routine_text) +#define B(p) ((p)->b) +#define BODY(p) ((p)->body) +#define CAST(p) ((p)->cast) +#define CHAR_IN_LINE(p) ((p)->char_in_line) +#define CROSS_REFERENCE_SAFE(p) ((p)->cross_reference_safe) +#define CDECL(p) ((p)->cdecl) +#define COMMENT(p) ((p)->comment) +#define COMMENT_CHAR_IN_LINE(p) ((p)->comment_char_in_line) +#define COMMENT_LINE(p) ((p)->comment_line) +#define COMMENT_TYPE(p) ((p)->comment_type) +#define CTYPE(p) ((p)->ctype) +#define DEFLEXED(p) ((p)->deflexed_mode) +#define DEREFO(p) ((p).derefo) +#define DERIVATE(p) ((p)->derivate) +#define DIM(p) ((p)->dim) +#define DYNAMIC_STACK_ALLOCS(p) ((p)->dynamic_stack_allocs) +#define EQUIVALENT(p) ((p)->equivalent_mode) +#define EQUIVALENT_MODE(p) ((p)->equivalent_mode) +#define ERROR_COUNT(p) ((p)->error_count) +#define EXPORTED(p) ((p)->exported) +#define EXTERN_SYMBOL(p) ((p)->extern_symbol) +#define EXTRACT_IN_PROC(p) ((p)->in_proc) +#define EXTRACT_KIND(p) ((p)->kind) +#define EXTRACT_MODE(p) ((p)->mode) +#define EXTRACT_PRIO(p) ((p)->priority) +#define EXTRACT_SYMBOL(p) ((p)->symbol) +#define EXTRACT_VARIABLE(p) ((p)->variable) +#define WARNING_COUNT(p) ((p)->warning_count) +#define F(p) ((p)->f) +#define FILENAME(p) ((p)->filename) +#define FILE_SOURCE_FD(p) ((p)->file_source_fd) +#define FILE_SOURCE_NAME(p) ((p)->file_source_name) +#define FLEXO(p) ((p).flexo) +#define FLEXO_KNOWN(p) ((p).flexo_known) +#define G(p) ((p)->g) +#define GINFO(p) ((p)->genie) +#define GENO(p) ((p).geno) +#define GET(p) ((p)->get) +#define GPARENT(p) (PARENT (GINFO (p))) +#define GREEN(p) ((p)->green) +#define H(p) ((p)->h) +#define HANDLE(p) ((p)->handle) +#define HAS_ROWS(p) ((p)->has_rows) +#define HEAP(p) ((p)->heap) +#define ID(p) ((p)->id) +#define IDENTIFICATION(p) ((p)->identification) +#define IDENTIFIERS(p) ((p)->identifiers) +#define IDF(p) ((p)->idf) +#define IM(z) (VALUE (&(z)[1])) +#define IN(p) ((p)->in) +#define INDEX(p) ((p)->index) +#define INDICANTS(p) ((p)->indicants) +#define INFO(p) ((p)->info) +#define INITIALISE_ANON(p) ((p)->initialise_anon) +#define INITIALISE_FRAME(p) ((p)->initialise_frame) +#define INI_PTR(p) ((p)->ini_ptr) +#define INS_MODE(p) ((p)->ins_mode) +#define IN_FORBIDDEN(p) ((p)->in_forbidden) +#define IN_PREFIX(p) ((p)->in_prefix) +#define IN_PROC(p) ((p)->in_proc) +#define IN_TEXT(p) ((p)->in_text) +#define IS_OPEN(p) ((p)->is_open) +#define IS_RECURSIVE(p) ((p)->is_recursive) +#define IS_TMP(p) ((p)->is_tmp) +#define JUMP_STAT(p) ((p)->jump_stat) +#define JUMP_TO(p) ((p)->jump_to) +#define K(q) ((q)->k) +#define LABELS(p) ((p)->labels) +#define LAST(p) ((p)->last) +#define LAST_LINE(p) ((p)->last_line) +#define LESS(p) ((p)->less) +#define LEVEL(p) ((p)->level) +#define LEX_LEVEL(p) (LEVEL (TABLE (p))) +#define LINBUF(p) ((p)->linbuf) +#define LINE(p) ((p)->line) +#define LINE_APPLIED(p) ((p)->line_applied) +#define LINE_DEFINED(p) ((p)->line_defined) +#define LINE_END_MENDED(p) ((p)->line_end_mended) +#define LINE_NUMBER(p) (NUMBER (LINE (INFO (p)))) +#define LINSIZ(p) ((p)->linsiz) +#define LIST(p) ((p)->list) +#define ln(x) (log (x)) +#define LOCALE(p) ((p)->locale) +#define LOC_ASSIGNED(p) ((p)->loc_assigned) +#define LOWERER(p) ((p)->lowerer) +#define LOWER_BOUND(p) ((p)->lower_bound) +#define LWB(p) ((p)->lower_bound) +#define MARKER(p) ((p)->marker) +#define MATCH(p) ((p)->match) +#define MODIFIED(p) ((p)->modified) +#define MODULES(p) ((p)->modules) +#define VERSION(p) ((p)->version) +#define MODES(p) ((p)->modes) +#define MOID(p) ((p)->type) +#define MOIF(p) ((p)->moif) +#define MORE(p) ((p)->more) +#define MSGS(p) ((p)->msgs) +#define MULTIPLE(p) ((p)->multiple_mode) +#define MULTIPLE_MODE(p) ((p)->multiple_mode) +#define NAME(p) ((p)->name) +#define NEST(p) ((p)->nest) +#define NEXT(p) ((p)->next) +#define NEXT_NEXT(p) (NEXT (NEXT (p))) +#define NEXT_NEXT_NEXT(p) (NEXT (NEXT_NEXT (p))) +#define NEXT_SUB(p) (NEXT (SUB (p))) +#define NF(p) ((p)->nf) +#define NILO(p) ((p).nilo) +#define NILO_KNOWN(p) ((p).nilo_known) +#define NODE(p) ((p)->node) +#define NODE_DEFINED(p) ((p)->node_defined) +#define NODE_PACK(p) ((p)->pack) +#define NON_LOCAL(p) ((p)->non_local) +#define NCHAR_IN_LINE(p) (CHAR_IN_LINE (INFO (p))) +#define NCOMMENT(p) (COMMENT (INFO (p))) +#define NCOMMENT_CHAR_IN_LINE(p) (COMMENT_CHAR_IN_LINE (INFO (p))) +#define NCOMMENT_LINE(p) (COMMENT_LINE (INFO (p))) +#define NCOMMENT_TYPE(p) (COMMENT_TYPE (INFO (p))) +#define NPRAGMAT(p) (PRAGMAT (INFO (p))) +#define NPRAGMAT_CHAR_IN_LINE(p) (PRAGMAT_CHAR_IN_LINE (INFO (p))) +#define NPRAGMAT_LINE(p) (PRAGMAT_LINE (INFO (p))) +#define NPRAGMAT_TYPE(p) (PRAGMAT_TYPE (INFO (p))) +#define NSYMBOL(p) (SYMBOL (INFO (p))) +#define NUM(p) ((p)->num) +#define NUMBER(p) ((p)->number) +#define OPER(p) ((p)->oper) +#define OPERATORS(p) ((p)->operators) +#define OPT(p) ((p)->opt) +#define OPTIONS(p) ((p)->options) +#define OPTION_ASSERT(p) (OPTIONS (p).assert) +#define OPTION_BOUNDS_CHECKING(p) (OPTIONS (p).bounds_checking) +#define OPTION_BRACKETS(p) (OPTIONS (p).brackets) +#define OPTION_NIL_CHECKING(p) (OPTIONS (p).nil_checking) +#define OPTION_STRICT(p) (OPTIONS (p).strict) +#define OPTION_STROPPING(p) (OPTIONS (p).stropping) +#define OPTION_LIST(p) (OPTIONS (p).list) +#define OPTION_LOCAL(p) (OPTIONS (p).local) +#define OPTION_NODEMASK(p) (OPTIONS (p).nodemask) +#define OUT(p) ((p)->out) +#define OUTER(p) ((p)->outer) +#define P(q) ((q)->p) +#define PACK(p) ((p)->pack) +#define PARTIAL_LOCALE(p) ((p)->partial_locale) +#define PARTIAL_PROC(p) ((p)->partial_proc) +#define PORTABLE(p) ((p)->portable) +#define POSTLUDE(p) ((p)->postlude) +#define PRAGMAT(p) ((p)->pragmat) +#define PRAGMAT_CHAR_IN_LINE(p) ((p)->pragmat_char_in_line) +#define PRAGMAT_LINE(p) ((p)->pragmat_line) +#define PRAGMAT_TYPE(p) ((p)->pragmat_type) +#define PRELUDE(p) ((p)->prelude) +#define PREVIOUS(p) ((p)->previous) +#define PRIO(p) ((p)->priority) +#define PRIOS(p) ((p)->prios) +#define PROCEDURE_LEVEL(p) ((p)->procedure_level) +#define PROC_OPS(p) ((p)->proc_ops) +#define PUBLICIZED(p) ((p)->publicized) +#define PUBLIC_RANGE(p) ((p)->public_range) +#define R(p) ((p)->r) +#define RE(z) (VALUE (&(z)[0])) +#define ROWED(p) ((p)->rowed) +#define SCAN_STATE_C(p) ((p)->scan_state.save_c) +#define SCAN_STATE_L(p) ((p)->scan_state.save_l) +#define SCAN_STATE_S(p) ((p)->scan_state.save_s) +#define SCOPE(p) ((p)->scope) +#define SCOPE_ASSIGNED(p) ((p)->scope_assigned) +#define SEQUENCE(p) ((p)->sequence) +#define SEVERITY(p) ((p)->severity) +#define SLICE(p) ((p)->slice) +#define SORT(p) ((p)->sort) +#define SOURCE_SCAN(p) ((p)->source_scan) +#define STANDENV_MOID(p) ((p)->standenv_moid) +#define STATUS(p) ((p)->status) +#define STRING(p) ((p)->string) +#define SUB(p) ((p)->sub) +#define SUB_MOID(p) (SUB (MOID (p))) +#define SUB_NEXT(p) (SUB (NEXT (p))) +#define SUB_SUB(p) (SUB (SUB (p))) +#define SYMBOL(p) ((p)->symbol) +#define TABLE(p) ((p)->symbol_table) +#define TAG_LEX_LEVEL(p) (LEVEL (TAG_TABLE (p))) +#define TAG_TABLE(p) ((p)->symbol_table) +#define TAX(p) ((p)->tag) +#define TAX_TREE_DECL(p) ((p)->tree_decl) +#define TEXT(p) ((p)->text) +#define TOP_LINE(p) ((p)->top_line) +#define TOP_MOID(p) ((p)->top_moid) +#define TOP_NODE(p) ((p)->top_node) +#define TRANSIENT(p) ((p)->transient) +#define TREE_LISTING_SAFE(p) ((p)->tree_listing_safe) +#define TRIM(p) ((p)->trim) +#define TUPLE(p) ((p)->tuple) +#define UNIT(p) ((p)->unit) +#define USE(p) ((p)->use) +#define VALUE(p) ((p)->value) +#define VARIABLE(p) ((p)->variable) +#define WHERE(p) ((p)->where) +#define IS_FLEXETY_ROW(m) (IS_FLEX (m) || IS_ROW (m) || m == M_STRING) +#define IS_FLEX(m) IS ((m), FLEX_SYMBOL) +#define IS_LITERALLY(p, s) (strcmp (NSYMBOL (p), s) == 0) +#define ISNT(p, s) (! IS (p, s)) +#define IS(p, s) (ATTRIBUTE (p) == (s)) +#define IS_REF_FLEX(m) (IS (m, REF_SYMBOL) && IS (SUB (m), FLEX_SYMBOL)) +#define IS_REF(m) IS ((m), REF_SYMBOL) +#define IS_INTEGRAL(m) \ + ((m) == M_INT \ + || (m) == M_LONG_INT \ + || (m) == M_LONG_LONG_INT \ + || (m) == M_SHORT_INT \ + || (m) == M_SHORT_SHORT_INT) +#define IS_BITS(m) \ + ((m) == M_BITS \ + || (m) == M_LONG_BITS \ + || (m) == M_LONG_LONG_BITS \ + || (m) == M_SHORT_BITS \ + || (m) == M_SHORT_SHORT_BITS) +#define IS_BYTES(m) \ + ((m) == M_BYTES || (m) == M_LONG_BYTES) +#define IS_COMPLEX(m) \ + ((m) == M_COMPLEX \ + || (m) == M_LONG_COMPLEX \ + || (m) == M_LONG_LONG_COMPLEX) +#define IS_REAL(m) \ + ((m) == M_REAL \ + || (m) == M_LONG_REAL \ + || (m) == M_LONG_LONG_REAL) +#define IS_ROW(m) IS ((m), ROW_SYMBOL) +#define IS_STRUCT(m) IS ((m), STRUCT_SYMBOL) +#define IS_UNION(m) IS ((m), UNION_SYMBOL) +#define YOUNGEST_ENVIRON(p) ((p)->youngest_environ) + +#endif /* ! __A68_TYPES_H */ diff --git a/gcc/algol68/a68-unistr.c b/gcc/algol68/a68-unistr.c new file mode 100644 index 000000000000..ee7a6d7831f6 --- /dev/null +++ b/gcc/algol68/a68-unistr.c @@ -0,0 +1,453 @@ +/* Character conversion functions for the Algol 68 front-end. + Copyright (C) 1999-2002, 2006-2007, 2009-2024 Free Software Foundation, Inc. + Copyright (C) 2025 Jose E. Marchesi. + + The code in this file has been adapted from the unistr gnulib module, + written by Bruno Haible. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_MEMORY +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "a68.h" + +static int +u8_mbtoucr (uint32_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c < 0x80) + { + *puc = c; + return 1; + } + else if (c >= 0xc2) + { + if (c < 0xe0) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x1f) << 6) + | (unsigned int) (s[1] ^ 0x80); + return 2; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + else if (c < 0xf0) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) + { + if (n >= 3) + { + if ((s[2] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x0f) << 12) + | ((unsigned int) (s[1] ^ 0x80) << 6) + | (unsigned int) (s[2] ^ 0x80); + return 3; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + else if (c <= 0xf4) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) + && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90))) + { + if (n >= 3) + { + if ((s[2] ^ 0x80) < 0x40) + { + if (n >= 4) + { + if ((s[3] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x07) << 18) + | ((unsigned int) (s[1] ^ 0x80) << 12) + | ((unsigned int) (s[2] ^ 0x80) << 6) + | (unsigned int) (s[3] ^ 0x80); + return 4; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return -2; + } + } + } + /* invalid multibyte character */ + *puc = 0xfffd; + return -1; +} + +/* Get the UCS code for the first character of a given UTF-8 string. */ + +int +a68_u8_mbtouc (uint32_t *puc, const uint8_t *s, size_t n) +{ + uint8_t c = *s; + + if (c < 0x80) + { + *puc = c; + return 1; + } + else if (c >= 0xc2) + { + if (c < 0xe0) + { + if (n >= 2) + { + if ((s[1] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x1f) << 6) + | (unsigned int) (s[1] ^ 0x80); + return 2; + } + /* invalid multibyte character */ + } + else + { + /* incomplete multibyte character */ + *puc = 0xfffd; + return 1; + } + } + else if (c < 0xf0) + { + if (n >= 3) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) + { + if ((s[2] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x0f) << 12) + | ((unsigned int) (s[1] ^ 0x80) << 6) + | (unsigned int) (s[2] ^ 0x80); + return 3; + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 2; + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; + } + else + { + *puc = 0xfffd; + if (n == 1) + { + /* incomplete multibyte character */ + return 1; + } + else + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xe1 || s[1] >= 0xa0) + && (c != 0xed || s[1] < 0xa0)) + { + /* incomplete multibyte character */ + return 2; + } + else + { + /* invalid multibyte character */ + return 1; + } + } + } + } + else if (c <= 0xf4) + { + if (n >= 4) + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) + && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90))) + { + if ((s[2] ^ 0x80) < 0x40) + { + if ((s[3] ^ 0x80) < 0x40) + { + *puc = ((unsigned int) (c & 0x07) << 18) + | ((unsigned int) (s[1] ^ 0x80) << 12) + | ((unsigned int) (s[2] ^ 0x80) << 6) + | (unsigned int) (s[3] ^ 0x80); + return 4; + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 3; + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 2; + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; + } + else + { + *puc = 0xfffd; + if (n == 1) + { + /* incomplete multibyte character */ + return 1; + } + else + { + if ((s[1] ^ 0x80) < 0x40 + && (c >= 0xf1 || s[1] >= 0x90) + && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90))) + { + if (n == 2) + { + /* incomplete multibyte character */ + return 2; + } + else + { + if ((s[2] ^ 0x80) < 0x40) + { + /* incomplete multibyte character */ + return 3; + } + else + { + /* invalid multibyte character */ + return 2; + } + } + } + else + { + /* invalid multibyte character */ + return 1; + } + } + } + } + } + /* invalid multibyte character */ + *puc = 0xfffd; + return 1; +} + +/* Encode a given UCS code in UTF-8. */ + +int +a68_u8_uctomb (uint8_t *s, uint32_t uc, ptrdiff_t n) +{ + if (uc < 0x80) + { + if (n > 0) + { + s[0] = uc; + return 1; + } + /* else return -2, below. */ + } + else + { + int count; + + if (uc < 0x800) + count = 2; + else if (uc < 0x10000) + { + if (uc < 0xd800 || uc >= 0xe000) + count = 3; + else + return -1; + } + else if (uc < 0x110000) + count = 4; + else + return -1; + + if (n >= count) + { + switch (count) /* note: code falls through cases! */ + { + case 4: s[3] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x10000; + gcc_fallthrough (); + case 3: s[2] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x800; + gcc_fallthrough (); + case 2: s[1] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0xc0; + /*case 1:*/ s[0] = uc; + } + return count; + } + } + return -2; +} + +/* Convert UTF-8 to UTF-32/UCS-4 */ + +uint32_t * +a68_u8_to_u32 (const uint8_t *s, size_t n, uint32_t *resultbuf, size_t *lengthp) +{ + const uint8_t *s_end = s + n; + /* Output string accumulator. */ + uint32_t *result; + size_t allocated; + size_t length; + + if (resultbuf != NULL) + { + result = resultbuf; + allocated = *lengthp; + } + else + { + result = NULL; + allocated = 0; + } + length = 0; + /* Invariants: + result is either == resultbuf or == NULL or malloc-allocated. + If length > 0, then result != NULL. */ + + while (s < s_end) + { + uint32_t uc; + int count; + + /* Fetch a Unicode character from the input string. */ + count = u8_mbtoucr (&uc, s, s_end - s); + if (count < 0) + { + if (!(result == resultbuf || result == NULL)) + free (result); + errno = EILSEQ; + return NULL; + } + s += count; + + /* Store it in the output string. */ + if (length + 1 > allocated) + { + uint32_t *memory; + + allocated = (allocated > 0 ? 2 * allocated : 12); + if (length + 1 > allocated) + allocated = length + 1; + if (result == resultbuf || result == NULL) + memory = (uint32_t *) xmalloc (allocated * sizeof (uint32_t)); + else + memory = + (uint32_t *) xrealloc (result, allocated * sizeof (uint32_t)); + + if (memory == NULL) + { + if (!(result == resultbuf || result == NULL)) + free (result); + errno = ENOMEM; + return NULL; + } + if (result == resultbuf && length > 0) + memcpy ((char *) memory, (char *) result, + length * sizeof (uint32_t)); + result = memory; + } + result[length++] = uc; + } + + if (length == 0) + { + if (result == NULL) + { + /* Return a non-NULL value. NULL means error. */ + result = (uint32_t *) xmalloc (sizeof (uint32_t)); + if (result == NULL) + { + errno = ENOMEM; + return NULL; + } + } + } + else if (result != resultbuf && length < allocated) + { + /* Shrink the allocated memory if possible. */ + uint32_t *memory; + + memory = (uint32_t *) xrealloc (result, length * sizeof (uint32_t)); + if (memory != NULL) + result = memory; + } + + *lengthp = length; + return result; +} diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h new file mode 100644 index 000000000000..92dc28e222f2 --- /dev/null +++ b/gcc/algol68/a68.h @@ -0,0 +1,1117 @@ +/* Definitions for the Algol 68 GCC front end. + Copyright (C) 2025 Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY + or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public + License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#ifndef __A68_H__ +#define __A68_H__ + +/* Some common definitions first. */ + +#define BUFFER_SIZE 1024 +#define SMALL_BUFFER_SIZE 128 +#define SNPRINTF_SIZE ((size_t) (BUFFER_SIZE - 1)) +#define BUFCLR(z) {memset ((z), 0, BUFFER_SIZE + 1);} +#define MOID_ERROR_WIDTH 80 + +#define MONADS "%^&+-~!?" +#define NOMADS ">= 4001) || GCC_VERSION == BUILDING_GCC_VERSION +#define ATTRIBUTE_A68_DIAG(m, n) __attribute__ ((__format__ (__gcc_tdiag__, m, n))) ATTRIBUTE_NONNULL(m) +#else +#define ATTRIBUTE_A68_DIAG(m, n) ATTRIBUTE_NONNULL(m) +#endif + +/* Maximum number of priorities supported for operators. The Algol 68 RR + specifies 9. */ + +#define MAX_PRIORITY 9 + +/* The primal scope is the top-level scope. */ + +#define PRIMAL_SCOPE 0 + +/* Deflexing strategy. See the moid checking routines in + a68-parser-moids-check for an explanation of these values. */ + +enum +{ + NO_DEFLEXING = 1, SAFE_DEFLEXING, ALIAS_DEFLEXING, FORCE_DEFLEXING, + SKIP_DEFLEXING +}; + +/* Magic number for the exports data. */ + +#define A68_EXPORT_MAGIC_LEN 2 + +#define A68_EXPORT_MAGIC1 0x0a +#define A68_EXPORT_MAGIC2 0x68 + +/* The segment name we pass to simple_object_start_read to find Algol 68 export + data. */ + +#ifndef A68_EXPORT_SEGMENT_NAME +#define A68_EXPORT_SEGMENT_NAME "__GNU_A68" +#endif + +/* The section name we use when reading and writing export data. */ + +#ifndef A68_EXPORT_SECTION_NAME +#define A68_EXPORT_SECTION_NAME ".a68_exports" +#endif + +/* ga68 export format definitions. See ga68-exports.pk. */ + +#define GA68_EXPORTS_VERSION 1 + +#define GA68_MODE_UNKNOWN 0 +#define GA68_MODE_VOID 1 +#define GA68_MODE_INT 2 +#define GA68_MODE_REAL 3 +#define GA68_MODE_BITS 4 +#define GA68_MODE_BYTES 5 +#define GA68_MODE_CHAR 6 +#define GA68_MODE_BOOL 7 +#define GA68_MODE_CMPL 8 +#define GA68_MODE_ROW 9 +#define GA68_MODE_STRUCT 10 +#define GA68_MODE_UNION 11 +#define GA68_MODE_NAME 12 +#define GA68_MODE_PROC 13 +#define GA68_MODE_STRING 14 +#define GA68_MODE_FLEX 15 + +#define GA68_EXTRACT_MODU 0 +#define GA68_EXTRACT_IDEN 1 +#define GA68_EXTRACT_MODE 2 +#define GA68_EXTRACT_PRIO 3 +#define GA68_EXTRACT_OPER 4 + +/* Then the types. */ + +#include "a68-types.h" + +/* Front-end global state. */ + +extern GTY(()) A68_T a68_common; +#define A68(z) (a68_common.z) +#define A68_JOB A68 (job) +#define A68_STANDENV A68 (standenv) +#define A68_MCACHE(z) A68 (mode_cache.z) +#define A68_INCLUDE_PATHS A68 (include_paths) +#define A68_IMPORT_PATHS A68 (import_paths) +#define A68_MODULE_FILES A68 (module_files) +#define A68_GLOBAL_TREES A68 (global_trees) +#define A68_PARSER(Z) (A68 (parser_state).Z) +#define A68_MODULE_DEFINITION_DECLS A68 (module_definition_decls) +#define A68_GLOBAL_CONTEXT A68 (global_context) +#define A68_GLOBAL_DECLARATIONS A68 (global_declarations) + +/* Particular pre-defined modes. */ + +#define MODE(p) A68 (a68_modes.p) +#define M_BITS (MODE (BITS)) +#define M_BOOL (MODE (BOOL)) +#define M_BYTES (MODE (BYTES)) +#define M_CHANNEL (MODE (CHANNEL)) +#define M_CHAR (MODE (CHAR)) +#define M_COLLITEM (MODE (COLLITEM)) +#define M_COMPLEX (MODE (COMPLEX)) +#define M_C_STRING (MODE (C_STRING)) +#define M_ERROR (MODE (ERROR)) +#define M_FILE (MODE (FILE)) +#define M_FLEX_ROW_BOOL (MODE (FLEX_ROW_BOOL)) +#define M_FLEX_ROW_CHAR (MODE (FLEX_ROW_CHAR)) +#define M_FORMAT (MODE (FORMAT)) +#define M_HIP (MODE (HIP)) +#define M_INT (MODE (INT)) +#define M_LONG_BITS (MODE (LONG_BITS)) +#define M_LONG_BYTES (MODE (LONG_BYTES)) +#define M_LONG_COMPLEX (MODE (LONG_COMPLEX)) +#define M_LONG_INT (MODE (LONG_INT)) +#define M_LONG_LONG_INT (MODE (LONG_LONG_INT)) +#define M_LONG_LONG_BITS (MODE (LONG_LONG_BITS)) +#define M_LONG_LONG_COMPLEX (MODE (LONG_LONG_COMPLEX)) +#define M_LONG_LONG_INT (MODE (LONG_LONG_INT)) +#define M_LONG_LONG_REAL (MODE (LONG_LONG_REAL)) +#define M_LONG_REAL (MODE (LONG_REAL)) +#define M_NIL (MODE (NIL)) +#define M_NUMBER (MODE (NUMBER)) +#define M_PROC_LONG_REAL_LONG_REAL (MODE (PROC_LONG_REAL_LONG_REAL)) +#define M_PROC_REAL_REAL (MODE (PROC_REAL_REAL)) +#define M_PROC_REF_FILE_BOOL (MODE (PROC_REF_FILE_BOOL)) +#define M_PROC_REF_FILE_VOID (MODE (PROC_REF_FILE_VOID)) +#define M_PROC_ROW_CHAR (MODE (PROC_ROW_CHAR)) +#define M_PROC_STRING (MODE (PROC_STRING)) +#define M_PROC_VOID (MODE (PROC_VOID)) +#define M_REAL (MODE (REAL)) +#define M_REF_BITS (MODE (REF_BITS)) +#define M_REF_BOOL (MODE (REF_BOOL)) +#define M_REF_BYTES (MODE (REF_BYTES)) +#define M_REF_CHAR (MODE (REF_CHAR)) +#define M_REF_COMPLEX (MODE (REF_COMPLEX)) +#define M_REF_FILE (MODE (REF_FILE)) +#define M_REF_INT (MODE (REF_INT)) +#define M_REF_LONG_BITS (MODE (REF_LONG_BITS)) +#define M_REF_LONG_BYTES (MODE (REF_LONG_BYTES)) +#define M_REF_LONG_COMPLEX (MODE (REF_LONG_COMPLEX)) +#define M_REF_LONG_INT (MODE (REF_LONG_INT)) +#define M_REF_LONG_LONG_BITS (MODE (REF_LONG_LONG_BITS)) +#define M_REF_LONG_LONG_COMPLEX (MODE (REF_LONG_LONG_COMPLEX)) +#define M_REF_LONG_LONG_INT (MODE (REF_LONG_LONG_INT)) +#define M_REF_LONG_LONG_REAL (MODE (REF_LONG_LONG_REAL)) +#define M_REF_LONG_REAL (MODE (REF_LONG_REAL)) +#define M_REF_REAL (MODE (REF_REAL)) +#define M_REF_REF_FILE (MODE (REF_REF_FILE)) +#define M_REF_SHORT_BITS (MODE (REF_SHORT_BITS)) +#define M_REF_SHORT_SHORT_BITS (MODE (REF_SHORT_SHORT_BITS)) +#define M_REF_ROW_CHAR (MODE (REF_ROW_CHAR)) +#define M_REF_ROW_COMPLEX (MODE (REF_ROW_COMPLEX)) +#define M_REF_ROW_INT (MODE (REF_ROW_INT)) +#define M_REF_ROW_REAL (MODE (REF_ROW_REAL)) +#define M_REF_ROW_ROW_COMPLEX (MODE (REF_ROW_ROW_COMPLEX)) +#define M_REF_ROW_ROW_REAL (MODE (REF_ROW_ROW_REAL)) +#define M_REF_SHORT_INT (MODE (REF_SHORT_INT)) +#define M_REF_SHORT_SHORT_INT (MODE (REF_SHORT_SHORT_INT)) +#define M_REF_STRING (MODE (REF_STRING)) +#define M_ROW_BITS (MODE (ROW_BITS)) +#define M_ROW_BOOL (MODE (ROW_BOOL)) +#define M_ROW_CHAR (MODE (ROW_CHAR)) +#define M_ROW_COMPLEX (MODE (ROW_COMPLEX)) +#define M_ROW_INT (MODE (ROW_INT)) +#define M_ROW_REAL (MODE (ROW_REAL)) +#define M_ROW_ROW_CHAR (MODE (ROW_ROW_CHAR)) +#define M_ROW_ROW_COMPLEX (MODE (ROW_ROW_COMPLEX)) +#define M_ROW_ROW_REAL (MODE (ROW_ROW_REAL)) +#define M_ROW_SIMPLIN (MODE (ROW_SIMPLIN)) +#define M_ROW_SIMPLOUT (MODE (ROW_SIMPLOUT)) +#define M_ROWS (MODE (ROWS)) +#define M_ROW_STRING (MODE (ROW_STRING)) +#define M_SEMA (MODE (SEMA)) +#define M_SHORT_BITS (MODE (SHORT_BITS)) +#define M_SHORT_SHORT_BITS (MODE (SHORT_SHORT_BITS)) +#define M_SHORT_INT (MODE (SHORT_INT)) +#define M_SHORT_SHORT_INT (MODE (SHORT_SHORT_INT)) +#define M_SIMPLIN (MODE (SIMPLIN)) +#define M_SIMPLOUT (MODE (SIMPLOUT)) +#define M_STRING (MODE (STRING)) +#define M_UNDEFINED (MODE (UNDEFINED)) +#define M_VACUUM (MODE (VACUUM)) +#define M_VOID (MODE (VOID)) + +/* Usage of TYPE_LANG_FLAG_* flags. */ + +#define A68_ROW_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE) +#define A68_UNION_TYPE_P(NODE) TYPE_LANG_FLAG_1 (NODE) +#define A68_STRUCT_TYPE_P(NODE) TYPE_LANG_FLAG_2 (NODE) +#define A68_ROWS_TYPE_P(NODE) TYPE_LANG_FLAG_3 (NODE) +#define A68_TYPE_HAS_ROWS_P(NODE) TYPE_LANG_FLAG_4 (NODE) + +/* Language-specific tree checkers. */ + +#define STRUCT_OR_UNION_TYPE_CHECK(NODE) \ + TREE_CHECK2 (NODE, RECORD_TYPE, UNION_TYPE) + +/* Usage of TYPE_LANG_SLOT_* fields. */ + +#define TYPE_FORWARD_REFERENCES(NODE) \ + (TYPE_LANG_SLOT_1 (STRUCT_OR_UNION_TYPE_CHECK (NODE))) + +/* a68-unistr.cc */ + +int a68_u8_mbtouc (uint32_t *puc, const uint8_t *s, size_t n); +int a68_u8_uctomb (uint8_t *s, uint32_t uc, ptrdiff_t n); + +uint32_t *a68_u8_to_u32 (const uint8_t *s, size_t n, uint32_t *resultbuf, size_t *lengthp); + +/* a68-lang.cc */ + +/* Global types. These are built in a68_build_a68_type_nodes and used by the + lowering routines. */ + +#define a68_void_type A68_GLOBAL_TREES[ATI_VOID_TYPE] +#define a68_bool_type A68_GLOBAL_TREES[ATI_BOOL_TYPE] +#define a68_char_type A68_GLOBAL_TREES[ATI_CHAR_TYPE] +#define a68_short_short_bits_type A68_GLOBAL_TREES[ATI_SHORT_SHORT_BITS_TYPE] +#define a68_short_bits_type A68_GLOBAL_TREES[ATI_SHORT_BITS_TYPE] +#define a68_bits_type A68_GLOBAL_TREES[ATI_BITS_TYPE] +#define a68_long_bits_type A68_GLOBAL_TREES[ATI_LONG_BITS_TYPE] +#define a68_long_long_bits_type A68_GLOBAL_TREES[ATI_LONG_LONG_BITS_TYPE] +#define a68_bytes_type A68_GLOBAL_TREES[ATI_BYTES_TYPE] +#define a68_long_bytes_type A68_GLOBAL_TREES[ATI_LONG_BYTES_TYPE] +#define a68_short_short_int_type A68_GLOBAL_TREES[ATI_SHORT_SHORT_INT_TYPE] +#define a68_short_int_type A68_GLOBAL_TREES[ATI_SHORT_INT_TYPE] +#define a68_int_type A68_GLOBAL_TREES[ATI_INT_TYPE] +#define a68_long_int_type A68_GLOBAL_TREES[ATI_LONG_INT_TYPE] +#define a68_long_long_int_type A68_GLOBAL_TREES[ATI_LONG_LONG_INT_TYPE] +#define a68_real_type A68_GLOBAL_TREES[ATI_REAL_TYPE] +#define a68_long_real_type A68_GLOBAL_TREES[ATI_LONG_REAL_TYPE] +#define a68_long_long_real_type A68_GLOBAL_TREES[ATI_LONG_LONG_REAL_TYPE] + +struct lang_type *a68_build_lang_type (MOID_T *moid); +struct lang_decl *a68_build_lang_decl (NODE_T *node); +MOID_T *a68_type_moid (tree type); + +/* a68-diagnostics.cc */ + +void a68_error (NODE_T *p, const char *loc_str, ...); +void a68_error_in_pragmat (NODE_T *p, size_t off, + const char *loc_str, ...); +bool a68_warning (NODE_T *p, int opt, const char *loc_str, ...); +void a68_inform (NODE_T *p, const char *loc_str, ...); +void a68_fatal (NODE_T *p, const char *loc_str, ...); +void a68_scan_error (LINE_T *u, char *v, const char *txt, ...); + +/* a68-parser-scanner.cc */ + +bool a68_lexical_analyser (const char *filename); + +/* a68-parser.cc */ + +int a68_count_operands (NODE_T *p); +int a68_count_formal_bounds (NODE_T *p); +void a68_count_pictures (NODE_T *p, int *k); +bool a68_is_ref_refety_flex (MOID_T *m); +bool a68_is_semicolon_less (NODE_T *p); +bool a68_is_formal_bounds (NODE_T *p); +bool a68_is_unit_terminator (NODE_T *p); +bool a68_is_loop_keyword (NODE_T *p); +bool a68_is_new_lexical_level (NODE_T *p); +bool a68_dont_mark_here (NODE_T *p); +enum a68_attribute a68_get_good_attribute (NODE_T *p); +void a68_parser (const char *filename); +NODE_INFO_T *a68_new_node_info (void); +GINFO_T *a68_new_genie_info (void); +NODE_T *a68_new_node (void); +NODE_T *a68_some_node (const char *t); +TABLE_T *a68_new_symbol_table (TABLE_T *p); +MOID_T *a68_new_moid (void); +PACK_T *a68_new_pack (void); +TAG_T *a68_new_tag (void); +void a68_make_special_mode (MOID_T **, int m); +void a68_make_sub (NODE_T *p, NODE_T *, enum a68_attribute t); +bool a68_whether (NODE_T *, ...); +bool a68_is_one_of (NODE_T *p, ...); +void a68_bufcat (char *dst, const char *src, int len); +void a68_bufcpy (char *dst, const char *src, int len); +char *a68_new_string (const char *t, ...); +const char *a68_attribute_name (enum a68_attribute attr); +location_t a68_get_node_location (NODE_T *p); +location_t a68_get_line_location (LINE_T *line, const char *pos); + +/* a68-parser-top-down.cc */ + +void a68_substitute_brackets (NODE_T *p); +const char *a68_phrase_to_text (NODE_T *p, NODE_T **w); +void a68_top_down_parser (NODE_T *p); + +/* a68-parser-bottom-up.cc */ + +void a68_bottom_up_parser (NODE_T *p); +void a68_bottom_up_error_check (NODE_T *p); +void a68_rearrange_goto_less_jumps (NODE_T *p); +void a68_bottom_up_coalesce_pub (NODE_T *p); + +/* a68-parser-extract.cc */ + +void a68_extract_indicants (NODE_T *p); +void a68_extract_priorities (NODE_T *p); +void a68_extract_operators (NODE_T *p); +void a68_extract_labels (NODE_T *p, int expect); +void a68_extract_declarations (NODE_T *p); +void a68_elaborate_bold_tags (NODE_T *p); + +/* a68-parser-keywords.cc */ + +const char *a68_strop_keyword (const char *keyword); +void a68_set_up_tables (void); +TOKEN_T *a68_add_token (TOKEN_T **p, const char *t); +KEYWORD_T *a68_find_keyword (KEYWORD_T *p, const char *t); +KEYWORD_T *a68_find_keyword_from_attribute (KEYWORD_T *p, enum a68_attribute a); + +/* a68-postulates.cc */ + +void a68_init_postulates (void); +void a68_free_postulate_list (POSTULATE_T *, POSTULATE_T *); +void a68_make_postulate (POSTULATE_T **, MOID_T *, MOID_T *); +POSTULATE_T *a68_is_postulated (POSTULATE_T *, MOID_T *); +POSTULATE_T *a68_is_postulated_pair (POSTULATE_T *, MOID_T *, MOID_T *); + +/* a68-parser-moids-check.cc */ + +void a68_mode_checker (NODE_T *p); + +/* a68-parser-moids-coerce.cc */ + +void a68_coercion_inserter (NODE_T *p); + +/* a68-parser-moids-equivalence.cc */ + +bool a68_prove_moid_equivalence (MOID_T *, MOID_T *); + +/* a68-parser-brackets.cc */ + +void a68_check_parenthesis (NODE_T *top); + +/* a68-parser-prelude.cc */ + +void a68_make_standard_environ (void); + +/* a68-parser-taxes.cc */ + +void a68_set_proc_level (NODE_T *p, int n); +void a68_set_nest (NODE_T *p, NODE_T *s); +int a68_first_tag_global (TABLE_T * table, const char *name); +void a68_collect_taxes (NODE_T *p); +TAG_T *a68_add_tag (TABLE_T *s, int a, NODE_T *n, MOID_T *m, int p); +TAG_T *a68_find_tag_global (TABLE_T *table, int a, const char *name); +int a68_is_identifier_or_label_global (TABLE_T *table, const char *name); +void a68_reset_symbol_table_nest_count (NODE_T *p); +void a68_bind_routine_tags_to_tree (NODE_T *p); +void a68_fill_symbol_table_outer (NODE_T *p, TABLE_T *s); +void a68_finalise_symbol_table_setup (NODE_T *p, int l); +void a68_preliminary_symbol_table_setup (NODE_T *p); +void a68_mark_moids (NODE_T *p); +void a68_mark_auxilliary (NODE_T *p); +void a68_warn_for_unused_tags (NODE_T *p); +void a68_jumps_from_procs (NODE_T *p); + +/* a68-parser-victal.cc */ + +void a68_victal_checker (NODE_T *p); + +/* a68-parser-modes.cc */ + +int a68_count_pack_members (PACK_T *u); +MOID_T *a68_register_extra_mode (MOID_T **z, MOID_T *u); +MOID_T *a68_create_mode (int att, int dim, NODE_T *node, MOID_T *sub, PACK_T *pack); +MOID_T *a68_search_equivalent_mode (MOID_T *m); +MOID_T *a68_add_mode (MOID_T **z, int att, int dim, NODE_T *node, MOID_T *sub, PACK_T *pack); +void a68_contract_union (MOID_T *u); +PACK_T *a68_absorb_union_pack (PACK_T * u); +void a68_add_mode_to_pack (PACK_T **p, MOID_T *m, const char *text, NODE_T *node); +void a68_add_mode_to_pack_end (PACK_T **p, MOID_T *m, const char *text, NODE_T *node); +void a68_make_moid_list (MODULE_T *mod); + +void a68_renumber_moids (MOID_T *p, int n); + +/* a68-moids-to-string.cc */ + +const char *a68_moid_to_string (MOID_T *n, size_t w, NODE_T *idf, + bool indicant_value = false); + +/* a68-moids-misc.cc */ + +bool a68_basic_coercions (MOID_T *p, MOID_T *q, int c, int deflex); +bool a68_clause_allows_balancing (int att); +bool a68_is_balanced (NODE_T *n, SOID_T *y, int sort); +bool a68_is_coercible_in_context (SOID_T *p, SOID_T *q, int deflex); +bool a68_is_coercible (MOID_T *p, MOID_T *q, int c, int deflex); +bool a68_is_coercible_series (MOID_T *p, MOID_T *q, int c, int deflex); +bool a68_is_coercible_stowed (MOID_T *p, MOID_T *q, int c, int deflex); +bool a68_is_deprefable (MOID_T *p); +bool a68_is_equal_modes (MOID_T *p, MOID_T *q, int deflex); +bool a68_is_firmly_coercible (MOID_T *p, MOID_T *q, int deflex); +bool a68_is_firm (MOID_T *p, MOID_T *q); +bool a68_is_meekly_coercible (MOID_T *p, MOID_T *q, int deflex); +bool a68_is_mode_isnt_well (MOID_T *p); +bool a68_is_moid_in_pack (MOID_T *u, PACK_T *v, int deflex); +bool a68_is_name_struct (MOID_T *p); +bool a68_is_nonproc (MOID_T *p); +bool a68_is_printable_mode (MOID_T *p); +bool a68_is_proc_ref_file_void_or_format (MOID_T *p); +bool a68_is_readable_mode (MOID_T *p); +bool a68_is_ref_row (MOID_T *p); +bool a68_is_rows_type (MOID_T *p); +bool a68_is_softly_coercible (MOID_T *p, MOID_T *q, int deflex); +bool a68_is_strongly_coercible (MOID_T *p, MOID_T *q, int deflex); +bool a68_is_strong_name (MOID_T *p, MOID_T *q); +bool a68_is_strong_slice (MOID_T *p, MOID_T *q); +bool a68_is_subset (MOID_T *p, MOID_T *q, int deflex); +bool a68_is_transput_mode (MOID_T *p, char rw); +bool a68_is_unitable (MOID_T *p, MOID_T *q, int deflex); +bool a68_is_weakly_coercible (MOID_T * p, MOID_T * q, int deflex); +bool a68_is_widenable (MOID_T *p, MOID_T *q); +MOID_T *a68_absorb_related_subsets (MOID_T *m); +MOID_T *a68_depref_completely (MOID_T *p); +MOID_T *a68_depref_once (MOID_T *p); +MOID_T *a68_depref_rows (MOID_T *p, MOID_T *q); +MOID_T *a68_deproc_completely (MOID_T *p); +MOID_T *a68_derow (MOID_T *p); +MOID_T *a68_determine_unique_mode (SOID_T *z, int deflex); +MOID_T *a68_get_balanced_mode (MOID_T *m, int sort, bool return_depreffed, int deflex); +MOID_T *a68_get_balanced_mode_or_no_mode (MOID_T *m, int sort, bool return_depreffed, int deflex); +MOID_T *a68_make_series_from_moids (MOID_T *u, MOID_T *v); +MOID_T *a68_make_united_mode (MOID_T *m); +MOID_T *a68_pack_soids_in_moid (SOID_T *top_sl, int attribute); +MOID_T *a68_unites_to (MOID_T *m, MOID_T *u); +void a68_absorb_series_pack (MOID_T **p); +void a68_absorb_series_union_pack (MOID_T **p); +void a68_add_to_soid_list (SOID_T **root, NODE_T *where, SOID_T *soid); +void a68_free_soid_list (SOID_T *root); +void a68_investigate_firm_relations (PACK_T *u, PACK_T *v, bool *all, bool *some); +void a68_make_coercion (NODE_T *l, enum a68_attribute a, MOID_T *m); +void a68_make_depreffing_coercion (NODE_T *n, MOID_T *p, MOID_T *q); +void a68_make_ref_rowing_coercion (NODE_T *n, MOID_T *p, MOID_T *q); +void a68_make_rowing_coercion (NODE_T *n, MOID_T *p, MOID_T *q); +void a68_make_soid (SOID_T *s, int sort, MOID_T *type, int attribute); +void a68_make_strong (NODE_T *n, MOID_T *p, MOID_T *q); +void a68_make_uniting_coercion (NODE_T *n, MOID_T *q); +void a68_make_void (NODE_T *p, MOID_T *q); + +#define A68_DEPREF true +#define A68_NO_DEPREF false + +#define A68_IF_MODE_IS_WELL(n) (! ((n) == M_ERROR || (n) == M_UNDEFINED)) + +/* a68-parser-scope.cc */ + +void a68_scope_checker (NODE_T *p); + +/* a68-parser-serial-dsa.cc */ + +void a68_serial_dsa (NODE_T *p); + +/* a68-parser-pragmat.cc */ + +void a68_handle_pragmats (NODE_T *p); + +/* a68-moids-diagnostics.cc */ + +const char *a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, int depth); +void a68_cannot_coerce (NODE_T *p, MOID_T *from, MOID_T *to, int context, int deflex, int att); +void a68_warn_for_voiding (NODE_T *p, SOID_T *x, SOID_T *y, int c); +void a68_semantic_pitfall (NODE_T *p, MOID_T *m, int c, int u); + +/* a68-low-misc.cc */ + +tree a68_lower_assertion (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_jump (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_parameter (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_parameter_list (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_parameter_pack (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_operator (NODE_T *p, LOW_CTX_T ctx); + +/* a68-low-moids.cc */ + +void a68_lower_moids (MOID_T *m); +void a68_set_type_moid (tree type, MOID_T *m); +tree a68_row_elements_pointer_type (tree type); +tree a68_row_elements_type (tree type); +tree a68_triplet_type (void); + +/* a68-low-bits.cc */ + +tree a68_get_bits_skip_tree (MOID_T *m); +tree a68_bits_width (tree type); +tree a68_bits_maxbits (tree type); +tree a68_bits_bin (MOID_T *m, tree val); +tree a68_bits_abs (MOID_T *m, tree bits); +tree a68_bits_leng (tree type, tree bits); +tree a68_bits_shorten (tree type, tree bits); +tree a68_bits_not (tree bits); +tree a68_bits_and (tree bits1, tree bits2); +tree a68_bits_ior (tree bits1, tree bits2); +tree a68_bits_xor (tree bits1, tree bits2); +tree a68_bits_elem (NODE_T *p, tree pos, tree bits); +tree a68_bits_subset (tree bits1, tree bits2); +tree a68_bits_shift (tree shift, tree bits); +tree a68_bits_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_bits_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION); + +/* a68-low_bools.cc */ + +tree a68_get_bool_skip_tree (void); +tree a68_bool_abs (tree val); +tree a68_bool_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_bool_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION); + +/* a68-low-ints.cc */ + +tree a68_get_int_skip_tree (MOID_T *m); +tree a68_int_maxval (tree type); +tree a68_int_minval (tree type); +tree a68_int_width (tree type); +tree a68_int_sign (tree val); +tree a68_int_abs (tree val); +tree a68_int_shorten (MOID_T *to_mode, MOID_T *from_mode, tree val); +tree a68_int_leng (MOID_T *to_mode, MOID_T *from_mode, tree val); + +tree a68_int_plus (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_minus (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_mult (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_div (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_mod (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_pow (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_lt (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_le (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_gt (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_int_ge (tree a, tree b, location_t loc = UNKNOWN_LOCATION); + +/* a68-low-complex.cc */ + +tree a68_complex_i (MOID_T *mode, tree re, tree im); +tree a68_complex_re (tree z); +tree a68_complex_im (tree z); +tree a68_complex_conj (MOID_T *mode, tree z); +tree a68_complex_widen_from_real (MOID_T *mode, tree r); + +/* a68-low-posix.cc */ + +tree a68_posix_setexitstatus (void); +tree a68_posix_argc (void); +tree a68_posix_argv (void); +tree a68_posix_getenv (void); +tree a68_posix_putchar (void); +tree a68_posix_puts (void); +tree a68_posix_fconnect (void); +tree a68_posix_fcreate (void); +tree a68_posix_fopen (void); +tree a68_posix_fclose (void); +tree a68_posix_fsize (void); +tree a68_posix_lseek (void); +tree a68_posix_errno (void); +tree a68_posix_perror (void); +tree a68_posix_strerror (void); +tree a68_posix_getchar (void); +tree a68_posix_fgetc (void); +tree a68_posix_fputc (void); +tree a68_posix_fputs (void); +tree a68_posix_gets (void); +tree a68_posix_fgets (void); + +/* a68-low-reals.cc */ + +tree a68_get_real_skip_tree (MOID_T *m); +tree a68_real_pi (tree type); +tree a68_real_maxval (tree type); +tree a68_real_minval (tree type); +tree a68_real_smallval (tree type); +tree a68_real_width (tree type); +tree a68_real_exp_width (tree type); +tree a68_real_sign (tree val); +tree a68_real_abs (tree val); +tree a68_real_sqrt (tree val); +tree a68_real_tan (tree type); +tree a68_real_sin (tree type); +tree a68_real_cos (tree type); +tree a68_real_acos (tree type); +tree a68_real_asin (tree type); +tree a68_real_atan (tree type); +tree a68_real_ln (tree type); +tree a68_real_log (tree type); +tree a68_real_exp (tree type); +tree a68_real_shorten (MOID_T *to_mode, MOID_T *from_mode, tree val); +tree a68_real_leng (MOID_T *to_mode, MOID_T *from_mode, tree val); +tree a68_real_entier (tree val, MOID_T *to_mode, MOID_T *from_mode); +tree a68_real_round (tree val, MOID_T *to_mode, MOID_T *from_mode); + +tree a68_real_plus (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_minus (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_mult (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_div (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_mod (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_pow (MOID_T *m, MOID_T *a_mode, MOID_T *b_mode, + tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_lt (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_le (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_gt (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_real_ge (tree a, tree b, location_t loc = UNKNOWN_LOCATION); + + +/* a68-low-strings.cc */ + +tree a68_get_string_skip_tree (void); +tree a68_string_concat (tree str1, tree str2); +tree a68_string_mult (tree str1, tree str2); +tree a68_string_from_char (tree c); +tree a68_string_cmp (tree s1, tree s2); +char *a68_string_process_breaks (NODE_T *p, const char *str); + +/* a68-low-chars.cc */ + +tree a68_get_char_skip_tree (void); +tree a68_char_max (void); +tree a68_char_repr (NODE_T *p, tree val); +tree a68_char_abs (tree val); +tree a68_char_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_char_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_char_lt (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_char_le (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_char_gt (tree a, tree b, location_t loc = UNKNOWN_LOCATION); +tree a68_char_ge (tree a, tree b, location_t loc = UNKNOWN_LOCATION); + +/* a68-low-refs.cc */ + +tree a68_get_ref_skip_tree (MOID_T *m); + +/* a68-low-procs.cc */ + +tree a68_get_proc_skip_tree (MOID_T *m); + +/* a68-low-structs.cc */ + +tree a68_get_struct_skip_tree (MOID_T *m); + +/* a68-low-multiples.cc */ + +tree a68_get_multiple_skip_tree (MOID_T *m); +tree a68_multiple_dimensions (tree exp); +tree a68_multiple_num_elems (tree exp); +tree a68_multiple_lower_bound (tree exp, tree dim); +tree a68_multiple_upper_bound (tree exp, tree dim); +tree a68_multiple_stride (tree exp, tree dim); +tree a68_multiple_triplets (tree exp); +tree a68_multiple_elements (tree exp); +tree a68_multiple_elements_size (tree exp); +tree a68_multiple_set_elements (tree exp, tree elements); +tree a68_multiple_set_elements_size (tree exp, tree elements_size); +void a68_multiple_compute_strides (tree type, size_t dim, + tree *lower_bounds, tree *upper_bounds, + tree *strides); +tree a68_multiple_set_lower_bound (tree exp, tree dim, tree bound); +tree a68_multiple_set_upper_bound (tree exp, tree dim, tree bound); +tree a68_multiple_set_stride (tree exp, tree dim, tree stride); +tree a68_row_value (tree type, size_t dim, + tree elements, tree elements_size, + tree *lower_bound, tree *upper_bound); +tree a68_row_value_raw (tree type, tree descriptor, + tree elements, tree elements_size); +tree a68_row_malloc (tree type, int dim, + tree elements, tree elements_size, + tree *lower_bound, tree *upper_bound); +tree a68_multiple_slice (NODE_T *p, tree multiple, bool slicing_name, + int num_indexes, tree *indexes); +tree a68_multiple_copy_elems (MOID_T *to_mode, tree to, tree from); +tree a68_rows_dim (tree exp); +tree a68_rows_value (tree multiple); +tree a68_rows_lower_bound (tree rows, tree dim); +tree a68_rows_upper_bound (tree rows, tree dim); +tree a68_rows_dim_check (NODE_T *p, tree rows, tree dim); +tree a68_multiple_dim_check (NODE_T *p, tree multiple, tree dim); +tree a68_multiple_single_bound_check (NODE_T *p, tree dim, tree multiple, + tree index, bool upper_bound); +tree a68_multiple_bounds_check (NODE_T *p, tree dim, tree multiple, + tree index); +tree a68_multiple_bounds_check_equal (NODE_T *p, tree m1, tree m2); + +/* a68-low-ranges.cc */ + +bool a68_in_global_range (void); +void a68_init_ranges (void); +void a68_push_range (MOID_T *mode); +tree a68_pop_range (void); +tree a68_pop_range_with_finalizer (tree *finalizer); +void a68_push_stmt_list (MOID_T *mode); +tree a68_pop_stmt_list (void); +void a68_push_function_range (tree fndel, tree result_type, + bool top_level = false); +void a68_pop_function_range (tree body); +void a68_push_serial_clause_range (MOID_T *clause_mode, + bool save_restore_stack = false); +tree a68_pop_serial_clause_range (void); +void a68_add_stmt (tree exp); +void a68_add_decl (tree decl); +void a68_add_decl_expr (tree decl_expr); +void a68_add_completer (void); +tree a68_range_context (void); +tree a68_range_names (void); +tree a68_range_stmt_list (void); + +/* a68-low-runtime.cc */ + +enum a68_libcall_fn +{ +#define DEF_A68_RUNTIME(CODE, N, T, P, F) A68_LIBCALL_ ## CODE, +#include "a68-low-runtime.def" +#undef DEF_A68_RUNTIME + A68_LIBCALL_LAST +}; + +tree a68_get_libcall (a68_libcall_fn libcall); +tree a68_build_libcall (a68_libcall_fn libcall, tree type, int nargs, ...); + +/* a68-low-clauses.cc */ + +void a68_begin_serial_clause (LOW_CTX_T *ctx, MOID_T *clause_mode); +tree a68_finish_serial_clause (LOW_CTX_T ctx, MOID_T *clause_mode, tree parent_block); +tree a68_lower_label (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_labeled_unit (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_completer (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_initialiser_series (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_serial_clause (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_loop_clause (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_conformity_clause (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_case_clause (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_enquiry_clause (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_conditional_clause (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_unit_list (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_access_clause (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_collateral_clause (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_parallel_clause (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_closed_clause (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_enclosed_clause (NODE_T *p, LOW_CTX_T ctx); + +/* a68-low-coercions.cc */ + +tree a68_lower_dereferencing (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_rowing (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_widening (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_deproceduring (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_proceduring (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_voiding (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_uniting (NODE_T *p, LOW_CTX_T ctx); + +/* a68-low-decls.cc */ + +tree a68_lower_mode_declaration (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_variable_declaration (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_identity_declaration (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_procedure_declaration (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_procedure_variable_declaration (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_declarer (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_declaration_list (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_priority_declaration (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_brief_operator_declaration (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_operator_declaration (NODE_T *p, LOW_CTX_T ctx); + +/* a68-low.cc */ + +tree a68_lower_top_tree (NODE_T *p); +tree a68_lower_tree (NODE_T *p, LOW_CTX_T ctx); +tree a68_make_identity_declaration_decl (NODE_T *identifier, const char *module_name = NULL, + bool indicant = false, bool external = false, + const char *extern_symbol = NULL); +tree a68_make_variable_declaration_decl (NODE_T *identifier, const char *module_name = NULL, + bool external = false, + const char *extern_symbol = NULL); +tree a68_make_proc_identity_declaration_decl (NODE_T *identifier, const char *module_name = NULL, + bool indicant = false, bool external = false, + const char *extern_symbol = NULL); +tree a68_make_anonymous_routine_decl (MOID_T *mode); +tree a68_get_skip_tree (MOID_T *m); +tree a68_get_empty (void); +void a68_ref_counts (tree exp, MOID_T *m, int *num_refs, int *num_pointers); +tree a68_consolidate_ref (MOID_T *m, tree expr); +tree a68_lower_alloca (tree type, tree size); +tree a68_lower_malloc (tree type, tree size); +tree a68_checked_indirect_ref (NODE_T *p, tree exp, MOID_T *exp_mode); +tree a68_low_deref (tree exp, NODE_T *p); +tree a68_low_dup (tree exp, bool use_heap = false); +tree a68_low_ascription (MOID_T *mode, tree lhs, tree rhs); +tree a68_low_assignation (NODE_T *p, tree lhs, MOID_T *lhs_mode, tree rhs, MOID_T *rhs_mode); +tree a68_lower_memcpy (tree dst, tree src, tree size); +tree a68_lower_tmpvar (const char *name, tree type, tree init); +tree a68_get_mangled_identifier (const char *name, + const char *mname = NULL, bool internal = false, + bool numbered = false); +tree a68_get_mangled_indicant (const char *name, + const char *mname = NULL, bool internal = false, + bool numbered = false); +char *a68_demangle_symbol (const char *mname, const char *symbol, + bool is_operator = false); +tree a68_low_toplevel_func_decl (const char *name, tree fntype); +tree a68_low_func_param (tree fndecl, const char *name, tree type); + +/* a68-low-builtins.cc */ + +void a68_install_builtins (); + +/* a68-low-unions.c */ + +int a68_united_mode_index (MOID_T *p, MOID_T *q); +tree a68_get_union_skip_tree (MOID_T *m); +tree a68_union_overhead (tree exp); +tree a68_union_set_overhead (tree exp, tree overhead); +tree a68_union_cunion (tree exp); +tree a68_union_alternative (tree exp, int index); +tree a68_union_value (MOID_T *mode, tree exp, MOID_T *exp_mode); +tree a68_union_translate_overhead (MOID_T *from, tree from_overhead, MOID_T *to); +bool a68_union_contains_mode (MOID_T *p, MOID_T *q); + +/* a68-low-units.cc */ + +tree a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_denotation (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_denotation (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_skip (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_nihil (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_empty (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_identity_relation (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_logic_function (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_primary (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_cast (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_secondary (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_slice (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_selection (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_formula (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_monadic_formula (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_tertiary (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_assignation (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_routine_text (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_generator (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_call (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_unit (NODE_T *p, LOW_CTX_T ctx); + +/* a68-low-generator.c */ + +tree a68_low_generator (NODE_T *declarer, MOID_T *mode, + bool heap, LOW_CTX_T ctx); +tree a68_low_gen (MOID_T *m, size_t nbuonds, tree *bounds, + bool use_heap); + +/* a68-low-prelude.c */ + +tree a68_lower_unimplemented (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_assert (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_intabs2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_realabs2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_boolabs2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_charabs2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_not2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_and3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_or3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_xor3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_confirm2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_negate2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_sign2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_realsign2 (NODE_T *p, LOW_CTX_T ctx); + +tree a68_lower_plus_int (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_plus_real (NODE_T *p, LOW_CTX_T ctx); + +tree a68_lower_minus_int (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_minus_real (NODE_T *p, LOW_CTX_T ctx); + +tree a68_lower_mult_int (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_mult_real (NODE_T *p, LOW_CTX_T ctx); + +tree a68_lower_multab3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_div3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_divab3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_rdiv3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_over3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_mod3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_int_eq3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_int_ne3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_int_lt3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_int_le3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_int_gt3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_int_ge3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_real_eq3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_real_ne3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_real_lt3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_real_le3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_real_gt3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_real_ge3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_char_eq3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_char_ne3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_char_lt3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_char_le3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_char_gt3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_char_ge3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bool_eq3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bool_ne3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_plusab3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_minusab3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_overab3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_modab3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_upb2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_upb3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_lwb2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_lwb3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_elems2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_elems3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_entier2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_round2 (NODE_T *p, LOW_CTX_T ctx); + +tree a68_lower_pow_int (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_pow_real (NODE_T *p, LOW_CTX_T ctx); + +tree a68_lower_odd2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_eq3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_ne3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_lt3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_le3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_gt3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_ge3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_plus3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_char_plus3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_plusab3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_mult3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_char_mult3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_multab3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_string_plusto3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_repr2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitelem3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bin2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitabs2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitleng2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitshorten2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bit_eq3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bit_ne3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitnot2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitand3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitior3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitxor3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_shl3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_shr3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bit_eq3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bit_ne3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bit_le3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bit_ge3 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_maxint (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_minint (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_maxbits (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_maxreal (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_minreal (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_smallreal (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitswidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longbitswidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longlongbitswidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_shortbitswidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_shortshortbitswidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_intwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longintwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longlongintwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_shortintwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_shortshortintwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_realwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longrealwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longlongrealwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_expwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longexpwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longlongexpwidth (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_pi (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_nullcharacter (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_flip (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_flop (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_errorchar (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_blank (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_eofchar (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_replacementchar (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_intlengths (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_intshorths (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitslengths (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_bitsshorths (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_reallengths (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_realshorths (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_infinity (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_minusinfinity (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_maxabschar (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_sqrt (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_sqrt (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_long_sqrt (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_tan (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_tan (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_long_tan (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_sin (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_sin (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_long_sin (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_cos (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_cos (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_long_cos (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_acos (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_acos (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_long_acos (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_asin (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_asin (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_long_asin (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_atan (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_atan (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_long_atan (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_ln (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_ln (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_long_ln (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_log (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_log (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_long_log (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_exp (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_exp (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_long_long_exp (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_reali (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longreali (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longlongreali (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_inti (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longinti (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longlonginti (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_re2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_im2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_conj2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_shortenint2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_lengint2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_lengreal2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_shortenreal2 (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_random (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longrandom (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_longlongrandom (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_setexitstatus (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixargc (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixargv (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixputchar (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixputs (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfputc (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfputs (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixgetenv (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfconnect (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfopen (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfcreate (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfclose (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfsize (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixlseek (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixseekcur (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixseekend (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixseekset (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixstdinfiledes (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixstdoutfiledes (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixstderrfiledes (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfileodefault (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfileordwr (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfileordonly (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfileowronly (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfileotrunc (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixerrno (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixperror (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixstrerror (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixgetchar (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfgetc (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixgets (NODE_T *p, LOW_CTX_T ctx); +tree a68_lower_posixfgets (NODE_T *p, LOW_CTX_T ctx); + +/* a68-exports.cc */ + +MOIF_T *a68_moif_new (const char *module_name); +void a68_moif_free (MOIF_T *moif); +void a68_do_exports (NODE_T *p); + +/* a68-imports.cc */ + +MOIF_T *a68_open_packet (const char *module); + +/* a68-parser-debug.cc */ + +void a68_dump_parse_tree (NODE_T *p, bool tables = false, bool levels = false); +void a68_dump_modes (MOID_T *m); +void a68_dump_moif (MOIF_T *moif); + +#endif /* ! __A68_H__ */ diff --git a/gcc/algol68/a68spec.cc b/gcc/algol68/a68spec.cc new file mode 100644 index 000000000000..bc11abde76e9 --- /dev/null +++ b/gcc/algol68/a68spec.cc @@ -0,0 +1,222 @@ +/* a68spec.c -- Specific flags and argument handling of the Algol 68 front end. + Copyright (C) 2025 Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it under the + terms of the GNU General Public License as published by the Free Software + Foundation; either version 3, or (at your option) any later version. + + GCC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + details. + + You should have received a copy of the GNU General Public License along with + GCC; see the file COPYING3. If not see . */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "opt-suggestions.h" +#include "gcc.h" +#include "tm.h" +#include "opts.h" + +/* satisfy intellisense */ +#include "options.h" + +/* How to link with libga68. */ +enum libga68_link_mode +{ + LIBGA68_NOLINK, + LIBGA68_STATIC, + LIBGA68_DYNAMIC +}; + +static enum libga68_link_mode libga68_link = LIBGA68_STATIC; + +/* This bit is set if we saw a `-xfoo' language specification. */ +#define LANGSPEC (1 << 1) +/* This bit is set if they did `-lc'. */ +#define WITHLIBC (1 << 2) +/* Skip this option. */ +#define SKIPOPT (1 << 3) + +void +lang_specific_driver (struct cl_decoded_option **in_decoded_options, + unsigned int *in_decoded_options_count, + int *in_added_libraries) +{ + unsigned int i, j; + + /* The new argument list will be contained in this. */ + struct cl_decoded_option *new_decoded_options; + + /* "-lc" if it appears on the command line. */ + const struct cl_decoded_option *saw_libc = 0; + + /* An array used to flag each argument that needs a bit set for + LANGSPEC or WITHLIBC. */ + int *args; + + /* True if we saw -static. */ + int static_link = 0; + + /* True if we should add -shared-libgcc to the command-line. */ + int shared_libgcc = 1; + + /* The total number of arguments with the new stuff. */ + unsigned int argc; + + /* The argument list. */ + struct cl_decoded_option *decoded_options; + + /* The number of libraries added in. */ + int added_libraries; + + /* The total number of arguments with the new stuff. */ + int num_args = 1; + + /* Whether the -o option was used. */ + // bool saw_opt_o = false; + + argc = *in_decoded_options_count; + decoded_options = *in_decoded_options; + added_libraries = *in_added_libraries; + + args = XCNEWVEC (int, argc); + + for (i = 1; i < argc; i++) + { + const char *arg = decoded_options[i].arg; + + switch (decoded_options[i].opt_index) + { + case OPT__help: + case OPT__help_: + /* Let gcc.cc handle this. */ + *in_added_libraries = 0; + return; + case OPT_c: + case OPT_E: + case OPT_M: + case OPT_MM: + case OPT_fsyntax_only: + case OPT_S: + libga68_link = LIBGA68_NOLINK; + break; + + case OPT_l: + if (strcmp (arg, "c") == 0) + args[i] |= WITHLIBC; + break; + + case OPT_o: + //saw_opt_o = true; + break; + + case OPT_static: + static_link = 1; + break; + + case OPT_static_libgcc: + shared_libgcc = 0; + break; + + case OPT_static_libga68: + libga68_link = LIBGA68_STATIC; +#ifdef HAVE_LD_STATIC_DYNAMIC + /* Remove -static-libga68 from the command only if target supports + LD_STATIC_DYNAMIC. When not supported, it is left in so that a + back-end target can use outfile substitution. */ + args[i] |= SKIPOPT; +#endif + break; + + case OPT_shared_libga68: + libga68_link = LIBGA68_DYNAMIC; + args[i] |= SKIPOPT; + break; + + case OPT_SPECIAL_input_file: + break; + } + } + + /* There's no point adding -shared-libgcc if we don't have a shared + libgcc. */ +#ifndef ENABLE_SHARED_LIBGCC + shared_libgcc = 0; +#endif + + /* Make sure to have room for the trailing NULL argument. + - libga68 adds `-Bstatic -lga68 -Bdynamic' */ + num_args = argc + shared_libgcc + 1 * 5 + 10; + new_decoded_options = XNEWVEC (struct cl_decoded_option, num_args); + + i = 0; + j = 0; + + /* Copy the 0th argument, i.e., the name of the program itself. */ + new_decoded_options[j++] = decoded_options[i++]; + + /* NOTE: We start at 1 now, not 0. */ + while (i < argc) + { + new_decoded_options[j] = decoded_options[i]; + + if (!saw_libc && (args[i] & WITHLIBC)) + { + --j; + saw_libc = &decoded_options[i]; + } + + if ((args[i] & SKIPOPT) != 0) + --j; + + i++; + j++; + } + + if (saw_libc) + new_decoded_options[j++] = *saw_libc; + if (shared_libgcc && !static_link) + generate_option (OPT_shared_libgcc, NULL, 1, CL_DRIVER, + &new_decoded_options[j++]); + + /* Add `-lga68 -lm' if we haven't already done so. */ +#ifdef HAVE_LD_STATIC_DYNAMIC + if (libga68_link == LIBGA68_STATIC && !static_link) + { + generate_option (OPT_Wl_, LD_STATIC_OPTION, 1, CL_DRIVER, + &new_decoded_options[j++]); + added_libraries++; /* The driver calls add_infile while handling -Wl */ + } +#endif + generate_option (OPT_l, + "ga68", 1, + CL_DRIVER, &new_decoded_options[j++]); + added_libraries++; +#ifdef HAVE_LD_STATIC_DYNAMIC + if (libga68_link == LIBGA68_STATIC && !static_link) + { + generate_option (OPT_Wl_, LD_DYNAMIC_OPTION, 1, CL_DRIVER, + &new_decoded_options[j++]); + added_libraries++; /* The driver calls add_infile while handling -Wl */ + } +#endif + *in_decoded_options_count = j; + *in_decoded_options = new_decoded_options; + *in_added_libraries = added_libraries; +} + +/* Called before linking. Returns 0 on success and -1 on failure. */ +int +lang_specific_pre_link (void) +{ + if (libga68_link != LIBGA68_NOLINK) + do_spec ("%:include(libga68.spec)"); + return 0; +} + +/* Number of extra output files that lang_specific_pre_link may generate. */ +int lang_specific_extra_outfiles = 0; /* Not used for Algol68. */ diff --git a/gcc/algol68/config-lang.in b/gcc/algol68/config-lang.in new file mode 100644 index 000000000000..e3de063715de --- /dev/null +++ b/gcc/algol68/config-lang.in @@ -0,0 +1,32 @@ +# config-lang.in -- Top level configure fragment for gcc Algol 68 frontend. + +# Copyright (C) 2025 Free Software Foundation, Inc. + +# GCC is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3, or (at your option) +# any later version. + +# GCC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# Configure looks for the existence of this file to auto-config each language. +# We define several parameters used by configure: +# +# language - name of language as it would appear in $(LANGUAGES) +# compilers - value to add to $(COMPILERS) + +language="algol68" +compilers="a681\$(exeext)" +gtfiles="\$(srcdir)/algol68/a68-types.h \$(srcdir)/algol68/a68.h \$(srcdir)/algol68/a68-lang.cc \$(srcdir)/algol68/a68-low-ranges.cc" + +target_libs="target-libga68" + +# Do not build by default. +build_by_default="no" diff --git a/gcc/algol68/ga68-exports.pk b/gcc/algol68/ga68-exports.pk new file mode 100644 index 000000000000..86484b8d8893 --- /dev/null +++ b/gcc/algol68/ga68-exports.pk @@ -0,0 +1,297 @@ +/* ga68-exports.pk - GCC Algol 68 exports format. + + Copyright (C) 2025 Jose E. Marchesi + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* GNU Algol 68 source files (compilation units, or "packets") may + contain either a single particular-program or a set of one or more + module definitions. + + When compiling a compilation unit containing module definitions, + the ga68 compiler emits an ELF section called .a68_exports along + with the usual compiled object code. This section contains + information that reflects the PUBlicized identifiers exported by + module definitions: modes, operators, procedures, identifiers, + other module definitions, etc. This interface is complete enough + to allow other compilation units to access these declarations. + + The information that is in a module interface is defined in the MR + document using a sort of grammar. It is: + + module interface : + unique code & external symbol & hole description option & + mode table & definition summary. + + definition summary : + set of definition groups. + + definition group : + module identity & set of definition extracts. + + definition extract : + mode extract ; + operation extract ; + priority extract ; + identifier extract ; + definition module extract ; + invocation extract. + + mode extract : + mode marker & mode indication & mode & mdextra. + + operation extract : + operation marker & operator & mode & mdextra. + + priority extract : + priority marker & operator & integer priority & mdextra. + + identifier extract : + identifier marker & identifier & mode & mdextra. + + definition module extract : + definition module marker & definition module indication & + definition summary & mdextra. + + invocation extract : + module identity. + + mdextra : + extra machine-dependent information. + + This pickle precisely describes how the module interfaces are + encoded in the .a68_exports ELF section, which are of type PROGBITS + and thus are concatenated by ELF linkers. This works well because + each compilation unit may contain several module definitions, but a + module definition cannot be splitted among several compilation + units. */ + +/* The exports format is versioned. A bump in the format version + number indicates the presence of a backward incompatibility. This + is important because .ga68_exports section may contain module + definition interfaces having different versions, so compilers and + tools designed to operate on version "n" must ignore, or error on, + modules definition interfaces with later versions. */ + +var ga68_exports_ver = 1; + +/* References other sections and the .ga68_export section itself are + realized via link-time relocations: + + References to code addresses are relative to some text section. + References to data in .ga68_export are relative to the start of the + section. */ + +load elf; + +type ga68_text_reloc = Elf64_Addr; +type ga68_data_reloc = Elf64_Addr; + +/* Strings are encoded in-place and are both pre-sized and + NULL-terminated. This is to ease reading them quickly and + efficiently. Note that the size includes the final NULL + character. */ + +type ga68_str = + struct + { + offset,B> len; + string s: s'size == len; + }; + +/* Each module definition interface includes a table of modes, that + contains not only the modes for which mode extracts exist, but also + the indirectly referred modes: since Algol 68 used structural + equivalence of modes, each mode has to be defined fully. The + encoding therefore tries to be as compact as possible while + allowing being read with a reasonable level of performance and + convenience. */ + +var GA68_MODE_UNKNOWN = 0UB, + GA68_MODE_VOID = 1UB, + GA68_MODE_INT = 2UB, + GA68_MODE_REAL = 3UB, + GA68_MODE_BITS = 4UB, + GA68_MODE_BYTES = 5UB, + GA68_MODE_CHAR = 6UB, + GA68_MODE_BOOL = 7UB, + GA68_MODE_CMPL = 8UB, + GA68_MODE_ROW = 9UB, + GA68_MODE_STRUCT = 10UB, + GA68_MODE_UNION = 11UB, + GA68_MODE_NAME = 12UB, + GA68_MODE_PROC = 13UB, + GA68_MODE_STRING = 14UB, + GA68_MODE_FLEX = 15UB; + +type ga68_mode = + struct + { + uint<8> kind : kind in [GA68_MODE_VOID, GA68_MODE_INT, + GA68_MODE_REAL, GA68_MODE_BITS, + GA68_MODE_BYTES, GA68_MODE_CHAR, + GA68_MODE_CMPL, GA68_MODE_ROW, + GA68_MODE_STRUCT, GA68_MODE_UNION, + GA68_MODE_NAME, GA68_MODE_PROC, + GA68_MODE_FLEX]; + + union + { + int<8> sizety : kind in [GA68_MODE_INT, GA68_MODE_REAL, + GA68_MODE_CMPL, GA68_MODE_BITS, + GA68_MODE_BYTES]; + struct + { + ga68_data_reloc mode; + } name : kind == GA68_MODE_NAME || kind == GA68_MODE_FLEX; + + struct + { + type triplet = struct { ga68_text_reloc lb; ga68_text_reloc ub; }; + + uint<8> ndims; + triplet[ndims] dims; + ga68_data_reloc row_of; + } row : kind == GA68_MODE_ROW; + + struct + { + type field = struct { ga68_data_reloc mode; ga68_str name; }; + + uint<16> nfields; + field[nfields] fields; + } sct : kind == GA68_MODE_STRUCT; + + struct + { + uint<8> nmodes; + ga68_data_reloc[nmodes] modes; + } uni : kind == GA68_MODE_UNION; + + struct + { + type arg = struct { ga68_data_reloc mode; ga68_str name; }; + + ga68_data_reloc ret_mode; + uint<8> nargs; + arg[nargs] args; + } routine : kind == GA68_MODE_PROC; + + struct { } _ : kind in [GA68_MODE_UNKNOWN, GA68_MODE_VOID, + GA68_MODE_CHAR, GA68_MODE_BOOL, + GA68_MODE_STRING]; + + } data; + }; + +/* Each module definition interface includes a table of "extracts", + one per identifier PUBlicized by the module definition. + + Mode extracts represent declarations of mode indications, like for + example `mode Foo = struct (int i, real r)'. + + Identifier extracts represent declarations of constans, variables, + procedures and operators. Examples are `real pi = 3.14', `int + counter', `proc double = (int a) int : a * 2' and `op // = (int a, + b) int: a % b'. + + Priority extracts represent declarations of priorities for dyadic + operators, like for example `prio // = 9'. + + Finally, module extracts represent the PUBlication of some other + module definition. For example, the module definition `mode Foo = + access A, B def ... fed' will include module extracts for both "A" + and "B" in its interface. + + Some of the extracts may need some additional compiler-specific or + machine-specific information, whose contents are not specified + here. */ + +var GA68_EXTRACT_MODU = 0UB, + GA68_EXTRACT_IDEN = 1UB, + GA68_EXTRACT_MODE = 2UB, + GA68_EXTRACT_PRIO = 3UB, + GA68_EXTRACT_OPER = 4UB; + +type ga68_extract = + struct + { + Elf64_Off extract_size; + union + { + struct + { + uint<8> mark : mark == GA68_EXTRACT_MODU; + ga68_str module_indication; + } module; + + struct + { + uint<8> mark : mark == GA68_EXTRACT_IDEN; + ga68_str name; + ga68_data_reloc mode; + } identifier; + + struct + { + uint<8> mark : mark == GA68_EXTRACT_MODE; + ga68_str mode_indication; + ga68_data_reloc mode; + } mode; + + struct + { + uint<8> mark : mark == GA68_EXTRACT_PRIO; + ga68_str opname; + uint<8> prio; + } prio; + + struct + { + uint<8> mark : mark == GA68_EXTRACT_OPER; + ga68_str opname; + ga68_mode mode; + } oper; + + } extract : extract'size == extract_size; + + Elf64_Off mdextra_size; + uint<8>[mdextra_size] data; + }; + +/* The contents of the .ga68_exports section can be mapped as a + ga68_module[sec.sh_size] */ + +type ga68_module = + struct + { + uint<8>[2] magic : magic == [0x0aUB, 0xadUB]; + uint<16> version : version == ga68_exports_ver; + + /* Module identification. + Add a hash or UUID? */ + ga68_str name; + + /* Entry points. */ + ga68_str prelude; + ga68_str poslude; + + /* Table of modes. */ + Elf64_Off modes_size; + ga68_mode[modes_size] modes; + + /* Table of extracts. */ + Elf64_Off extracts_size; + ga68_extract[extracts_size] extracts; + }; diff --git a/gcc/algol68/ga68-internals.texi b/gcc/algol68/ga68-internals.texi new file mode 100644 index 000000000000..1c0bad85f5e5 --- /dev/null +++ b/gcc/algol68/ga68-internals.texi @@ -0,0 +1,383 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename ga68-internals.info + +@include gcc-common.texi + +@synindex tp cp + +@settitle GNU Algol 68 Compiler Internals + +@c %**end of header + +@c %** start of document + +@copying +Copyright @copyright{} 2025 Jose E. Marchesi. + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A +copy of the license is included in the section entitled ``GNU Free +Documentation License''. +@end copying + +@ifinfo +@dircategory Software development +@direntry +* ga68-internals: (ga68-internals). The GNU Algol 68 Compiler Internals. +@end direntry +This file documents the internals of the GNU Algol 68 +compiler, (@command{ga68}). + +@insertcopying +@end ifinfo + +@c Macro for bold-tags. In TeX and HTML they expand to proper bold words, +@c in other formats it resorts to upper stropping. +@iftex +@macro B{tag} +@strong{\tag\} +@end macro +@end iftex + +@ifhtml +@macro B{tag} +@strong{\tag\} +@end macro +@end ifhtml + +@ifnottex +@ifnothtml +@macro B{tag} +@sc{\tag\} +@end macro +@end ifnothtml +@end ifnottex + +@setchapternewpage odd +@titlepage +@title GNU Algol 68 Internals +@versionsubtitle +@author Jose E. Marchesi +@page +@vskip 0pt plus 1filll +@sp 1 +@insertcopying +@end titlepage + +@summarycontents +@contents + +@page + +@ifnottex +@node Top +@top Introduction +@cindex Introduction + +This manual documents (some of) the internals of @command{ga68}, the +GNU Algol 68 compiler. + +@menu +* Scope Checking:: Scope checking in assignation. +* Storage Management:: Management of run-time storage. +* Lowering Declarations:: Mapping external objects to internal objects. +* Lowering Assignations:: Superceding the value referred by a name. +* GNU Free Documentation License:: + How you can copy and share this manual. +* Index:: Index of this documentation. +@end menu +@end ifnottex + +@c --------------------------------------------------------------------- +@c Scope Checking +@c --------------------------------------------------------------------- + +@node Scope Checking +@chapter Scope Checking + +Static scope checking: pass. +Dynamic scope checking: run-time call. + +@c --------------------------------------------------------------------- +@c Storage Management +@c --------------------------------------------------------------------- + +@node Storage Management +@chapter Storage Management + +This chapter discusses the run-time management of internal objects in +Algol 68. + +First, a conceptual model is presented that describes the restrictions +as mandated by the Report. The storage implied by the lowered GENERIC +entities, as described in the previous chapter, shall match the +storage of the conceptual model. + +@menu +* Storage Structure of Objects:: +* Copying of Objects:: +* The Stack:: +* The Heap:: +@end menu + +@node Storage Structure of Objects +@section Storage Structure of Objects + +The internal objects which are the values in an Algol 68 program may +consist on a hierarchy of memory locations, which may not be +contiguous. This hierarchy of memory locations is the storage +structure of the object, and is not concerned by the particular +bit-patterns stored. + +Simple values. + +Names. + +Multiple values. + +Structured values. + +Values of united modes. + +@node Copying of Objects +@section Copying of Objects + +@node The Stack +@section The Stack + +XXX + +@node The Heap +@section The Heap + +@itemize @minus +@item +A value that has rows and gets returned by a procedure shall be +allocated on the stack. +@item +A copy of the right hand side is made before assigning it to the left +hand side. This copy is always allocated in the heap, because the +scope of the left hand side may be older than the scope of the right +hand side. This happens when assigning to a global variable. +@item +A trimmer of a name. This is because the trimmed multiple may be +allocated on the heap, and the trim shall have the same scope than the +trimmed multiple. +@end itemize + +@c --------------------------------------------------------------------- +@c Internal Objects +@c --------------------------------------------------------------------- + +@node Lowering Declarations +@chapter Lowering Declarations + +This chapter describes the mapping between external objects declared +in identity and variable declarations and the internal objects that +are the result of lowering the external objects in the parse tree into +GENERIC entities. + +@menu +* Identity Declarations:: @code{@B{amode} xxx = init value} +* Variable Declarations:: @code{@B{amode} xxx [:= init value]} +* Procedure Identity Declarations:: @code{@B{proc} xxx = routine text} +* Procedure Variable Declarations:: @code{@B{proc} xxx := routine text} +* Operator Brief Declarations:: @code{@B{op} @B{xxx} = routine text} +* Operator Declarations:: @code{@B{op}(...)@B{amode} @B{xxx} = routine text} +* Applied Identifiers:: +@end menu + +@node Identity Declarations +@section Identity Declarations + +An identity declaration with the form: + +@example +@B{c} part 1 @B{c} +@B{amode} defining_identifier = unit; +@B{c} part 2 @B{c} +@end example + +@noindent +Introduces the identifier @code{defining_identifier} in the current +range and ascribes a copy of the value yielded by @code{unit} to it. +Once established, the relationship between an identifier and the value +ascribed to it is constant and it cannot change during the reach of +the identifier. The ascribed unit can be any unitary clause, and its +elaboration can be arbitrarily complicated. In particular, it is not +required to be a compile-time constant. @code{@B{amode}} determines +the mode of the value yielded by the unit, and the unit is elaborated +in a strong context. + +An identity declaration like the above, where @code{@B{amode}} is not +a procedure mode (@xref{Procedure Identity Declarations}) is lowered +into: + +@itemize @bullet +@item +A @code{VAR_DECL} with name @code{defining_identifier}, type +@code{CTYPE (@B{amode})} and initial value @code{@B{amode}(@B{skip})} +that gets chained into the declarations list of the current block. +@item +A @code{DECL_EXPR} that gets prepended in the current statement's list. +@item +A @code{MODIFY_EXPR} setting the @code{VAR_DECL} to a copy of the +lowering of @code{unit}, @code{a68_low_dup (unit)}. +@end itemize + +@noindent +Schematically: + +@example + BIND_EXPR (BLOCK (DECLS: ... -> VAR_DECL (defining_identifier, INITIAL=SKIP))) + STMT_LIST + | + +-- DECL_EXPR (defining_identifier) + | + | @B{c} part 1 @B{c} + | + +-- MODIFY_EXPR (defining_identifier, unit) + | + | @B{c} part 2 @B{c} + | +@end example + +The reason why the @code{VAR_DECL} is initialized to @code{@B{skip}} +and then set to the initial @code{unit} specified in the source line +is that the Report specifies that Algol 68 identifiers can be used +before they are defined provided we are in the right range, but in +that case the value ascribed to the identifier is ``undefined''. +Accessing an ``undefined'' value in traditional Algol 68 +implementations would lead to a run-time error (these implementations +used a special value to denote undefined, such as @code{F00L}) but in +GNU Algol 68 the ``undefined'' value is always @code{@B{skip}} which, +if not terribly useful in most cases, is at least well defined in this +implementation and doesn't lead to an error. + +Identity declarations are the Algol 68 way of defining constants, and +one may wonder why we are not using @code{CONST_DECL} instead of +@code{VAR_DECL}. The reason is that @code{CONST_DECL} is really only +intended for integral values in C enums, and the @code{@B{amode}} in +the identity declaration can really be any mode, from simple integers +or characters to fairly complicated structured modes, which may +involve also rows and united modes. Whether the @code{VAR_DECL} will +lead to allocating storage on the stack depends on the nature of the +mode and the way the identifier is used in the program: whether its +address is taken, etc. + +@node Variable Declarations +@section Variable Declarations + +A variable declaration with the form: + +@example +[@B{loc}|@B{heap}] @B{amode} defining identifier [:= unit]; +@end example + +@noindent +Is in principle equivalent to the identity declaration: + +@example +@B{ref} @B{amode} defining identifier = [@B{loc}|@B{heap}] @B{amode}; +@end example + +@noindent +In both cases the object ascribed to the defining identifier is of +mode @code{@B{ref} @B{amode}}. The ascribed object is a name which is +created by a generator implied in the actual declarer in the variable +declaration case, and an explicit generator in the initialization +expression in the identity declaration case. + +However, in this compiler these two cases are handled differently in +order to reduce the amount of both indirect addressing and of storage: + +@itemize @bullet +@item +The variable declaration @code{[@B{loc}|@B{heap}] @B{amode} foo} +lowers into a @code{VAR_DECL} with type @code{CTYPE (amode)} provided +that the generator is @code{@B{loc}} and that the type contains no +rows. Accessing the variable will then involve direct addressing, and +when its address is required an @code{ADDR_EXPR} shall be used. +@item +The identity declaration @code{@B{ref} @B{amode} foo = @B{loc} +@B{amode}} lowers into a @code{VAR_DECL} with type @code{*CTYPE +(amode)}. Accessing the variable will then involve indirect +addressing: it is effectively a pointer. +@end itemize + +This optimization introduces the complication that an expression (the +@code{VAR_DECL}) whose type is TYPE can appear in a place where *TYPE +is expected, depending on the context and the r-value and l-value +interpretation of the @code{VAR_DECL}. The function +@code{a68_consolidate_ref} is used in several parts of the lowering +pass to guarantee a given name is an address regardless of how it was +initialized. + +@node Procedure Identity Declarations +@section Procedure Identity Declarations + +XXX + +@node Procedure Variable Declarations +@section Procedure Variable Declarations + +XXX + +@node Operator Brief Declarations +@section Operator Brief Declarations + +XXX + +@node Operator Declarations +@section Operator Declarations + +XXX + +@node Applied Identifiers +@section Applied Identifiers + +XXX + +@c --------------------------------------------------------------------- +@c Lowering Assignations +@c --------------------------------------------------------------------- + +@node Lowering Assignations +@chapter Lowering Assignations + +Scope checking: + +@itemize @bullet +@item +If static scope checking is relevant and OK, then just perform assignation. +@item +If static scope checking is relevant and not OK, a compile-time error +will have already being emitted. +@item +If static scope checking is not relevant, perform dynamic scope +checking: each time a name, a routine or a format of the data +structure is assigned, its dynamic scope (scope%_si) is compared with +the one of the destination (scope%_d). A run-time error message is +provided in case scope%_d < scope%_si. +@end itemize + +@c --------------------------------------------------------------------- +@c GNU Free Documentation License +@c --------------------------------------------------------------------- + +@include fdl.texi + + +@c --------------------------------------------------------------------- +@c Index +@c --------------------------------------------------------------------- + +@node Index +@unnumbered Index + +@printindex cp + +@bye diff --git a/gcc/algol68/ga68.texi b/gcc/algol68/ga68.texi new file mode 100644 index 000000000000..96ebef679653 --- /dev/null +++ b/gcc/algol68/ga68.texi @@ -0,0 +1,3169 @@ +\input texinfo @c -*-texinfo-*- +@setfilename ga68.info +@settitle The GNU Algol 68 Compiler + +@c Macro for bold-tags. In TeX and HTML they expand to proper bold words, +@c in other formats it resorts to upper stropping. +@iftex +@macro B{tag} +@strong{\tag\} +@end macro +@end iftex + +@ifhtml +@macro B{tag} +@strong{\tag\} +@end macro +@end ifhtml + +@ifnottex +@ifnothtml +@macro B{tag} +\tag\ +@end macro +@end ifnothtml +@end ifnottex + +@c Create a separate index for command line options +@defcodeindex op +@c Merge the standard indexes into a single one. +@syncodeindex fn cp +@syncodeindex vr cp +@syncodeindex ky cp +@syncodeindex pg cp +@syncodeindex tp cp + +@include gcc-common.texi + +@c Copyright years for this manual. +@set copyrights-ga68 2025 + +@copying +@c man begin COPYRIGHT +Copyright @copyright{} @value{copyrights-ga68} Free Software Foundation, Inc. + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. +A copy of the license is included in the +@c man end +section entitled ``GNU Free Documentation License''. +@ignore +@c man begin COPYRIGHT +man page gfdl(7). +@c man end +@end ignore +@end copying + +@ifinfo +@format +@dircategory Software development +@direntry +* ga68: (ga68). A GCC-based compiler for Algol 68 +@end direntry +@end format + +@insertcopying +@end ifinfo + +@titlepage +@title The GNU Algol 68 Compiler +@versionsubtitle +@author Jose E. Marchesi + +@page +@vskip 0pt plus 1filll +@sp 1 +@insertcopying +@end titlepage +@summarycontents +@contents +@page + +@node Top +@top Introduction + +This manual describes how to use @command{ga68}, the GNU compiler for +Algol 68. This manual is specifically about how to invoke +@command{ga68}, as well as its features. For more information about +the Algol 68 language in general, the reader is referred to the +bibliography. + +Note that the particular way of representing Algol 68 code snippets in +this manual will depend on the media. If you are reading this manual +in a printed support or a PDF file rendered for publication then the +bold words in programs will be rendered in actual bold typography and +tags may have spaces within them. If you are reading this manual in a +terminal or other media not supporting rich typography the code +examples will follow the modern stropping regime with is the default +in ga68. + +Note also that we are making use of @dfn{pseudo-comments} in code +examples, as it is traditional in Algol 68 related documentation. +These appear surrounded by @code{@B{C}} marks and act as placeholders +of some Algol 68 code. For example, @code{@B{C} frob the input +variable @B{C}} is a pseudo-comment. + +@menu +* Invoking ga68:: How to run the compiler. +* Composing programs:: Packets, modules, holes, particular programs. +* Comments and pragmats:: Comments and pragmas. +* Hardware representation:: Representation of programs. +* Standard prelude:: Standard modes, operators, etc. +* Extended prelude:: GNU extensions to the standard prelude. +* POSIX prelude:: Simple I/O and system interaction facilities. +* Language extensions:: GNU extensions to the Algol 68 language. +* Copying:: The GNU General Public License. +* GNU Free Documentation License:: + How you can share and copy this manual. +* Option Index:: Index of command line options. +* General Index:: General index. +@end menu + +@node Invoking ga68 +@chapter Invoking ga68 + +@c man title ga68 A GCC-based compiler for Algol 68 + +@ignore +@c man begin SYNOPSIS ga68 +ga68 [@option{-c}|@option{-S}] [@option{-g}] [@option{-pg}] + [@option{-O}@var{level}] [@option{-W}@var{warn}@dots{}] + [@option{-I}@var{dir}@dots{}] [@option{-L}@var{dir}@dots{}] + [@option{-f}@var{option}@dots{}] [@option{-m}@var{machine-option}@dots{}] + [@option{-o} @var{outfile}] [@@@var{file}] @var{infile}@dots{} + +Only the most useful options are listed here; see below for the +remainder. +@c man end +@c man begin SEEALSO +gpl(7), gfdl(7), fsf-funding(7), gcc(1) +and the Info entries for @file{ga68} and @file{gcc}. +@c man end +@end ignore + +@c man begin DESCRIPTION ga68 + +The @command{ga68} command is the GNU compiler for the Algol 68 language and +supports many of the same options as @command{gcc}. @xref{Option Summary, , +Option Summary, gcc, Using the GNU Compiler Collection (GCC)}. +This manual only documents the options specific to @command{ga68}. + +@c man end + +@menu +* Dialect options:: Options controlling the accepted language. +* Directory options:: Options influencing where to find source files. +* Warnings options:: Options controlling warnings specific to ga68 +* Runtime options:: Options controlling runtime behavior +* Linking options:: Options influencing the linking step +* Developer options:: Options useful for developers of ga68 +@end menu + +@node Dialect options +@section Dialect options +@cindex options, dialect + +The following options control how the compiler handles certain dialect +variations of the language. + +@table @gcctabopt +@opindex std=@var{std} +@item -std=@var{std} +Specify the standard to which the program is expected to conform, +which may be one of @samp{algol68} or @samp{gnu68}. The default value +for @var{std} is @samp{gnu68}, which specifies a strict super language +of Algol 68 allowing GNU extensions. The @samp{algol68} value +specifies that the program strictly conform to the Revised Report. +@opindex fstropping=@var{stropping_regime} +@item -fstropping=@var{stropping_regime} +Specify the stropping regime to expect in the input programs. The +default value for @var{stropping_regime} is @samp{supper}, which +specifies the modern SUPPER stropping which is a GNU extension. The +@samp{upper} value specifies the classic UPPER stropping of Algol 68 +programs. @xref{Stropping regimes}. +@opindex fbrackets +@opindex fno-brackets +@item -fbrackets +This option controls whether @code{[ .. ]} and @code{@{ .. @}} are +considered equivalent to @code{( .. )}. This syntactic variation is +blessed by the Revised Report and is still strict Algol 68. + +This option is disabled by default. +@end table + +@node Directory options +@section Options for Directory Search +@cindex directory options +@cindex options, directory search +@cindex search path + +These options specify directories to search for files, libraries, and +other parts of the compiler: + +@table @gcctabopt + +@opindex I +@item -I@var{dir} +Add the directory @var{dir} to the list of directories to be searched +for files when processing the @ref{pragmat include}. Multiple +@option{-I} options can be used, and the directories specified are +scanned in left-to-right order, as with @command{gcc}. + +@end table + +@node Warnings options +@section Warnings options +@cindex options, warnings +@cindex options, errors +@cindex warnings, suppressing +@cindex messages, error +@cindex messages, warning +@cindex suppressing warnings + +Warnings are diagnostic messages that report constructions that +are not inherently erroneous but that are risky or suggest there +is likely to be a bug in the program. Unless @option{-Werror} is +specified, they do not prevent compilation of the program. + +@table @gcctabopt +@opindex Wvoiding +@opindex Wno-voiding +@item -Wvoiding +Warn on non-void units being voided due to a strong context. +@opindex Wscope +@opindex Wno-scope +@item -Wscope +Warn when a potential name scope violation is found. +@opindex Whidden-declarations +@opindex Wno-hidden-declarations +@item -Whidden-declarations=@var{level} +Warn when a declaration hides another declaration in a larger reach. +This includes operators that hide firmly related operators defined in +larger reach. + +@table @gcctabopt +@item -Whidden-declarations=none +At this level no warning is issued for any hidden declaration on an +outer scope. + +@item -Whidden-declarations=prelude +At this level, warnings are issued for hidden declarations defined in +the standard prelude. This is the default warning level of +@option{-Whidden-declarations}. + +@item -Whidden-declarations=all +At this level, warnings are issued for any and all hidden +declarations. +@end table + +@opindex Wextensions +@opindex Wno-extensions +@item -Wextensions +Warn when a non-portable Algol 68 construct is used, like GNU +extensions to Algol 68. +@end table + +@node Runtime options +@section Runtime options +@cindex options, runtime + +These options affect the runtime behavior of programs compiled with +@command{ga68}. + +@table @gcctabopt +@opindex fassert +@opindex fno-assert +@item -fno-assert +Turn off code generation for @code{ASSERT} contracts. + +@opindex fcheck +@item -fcheck=@var{} +Enable the generation of run-time checks; the argument shall be a +comma-delimited list of the following keywords. Prefixing a check +with @option{no-} disables it if it was activated by a previous +specification. + +@table @asis +@item @samp{all} +Enable all run-time test of @option{-fcheck}. + +@item @samp{none} +Disable all run-time test of @option{-fcheck}. + +@item @samp{nil} +Check for nil while dereferencing. + +@item @samp{bounds} +Enable generation of run-time checks when indexing and trimming +multiple values. +@end table +@end table + +@node Linking options +@section Linking options +@cindex options, linking +@cindex linking, static + +These options come into play when the compiler links object files into +an executable output file. They are meaningless if the compiler is +not doing a link step. + +@table @gcctabopt + +@opindex shared-libga68 +@item -shared-libga68 +On systems that provide @file{libga68} as a shared and a static +library, this option forces the use of the shared version. If no +shared version was built when the compiler was configured, this option +has no effect. + +@opindex static-libga68 +@item -static-libga68 +On systems that provide @file{libga68} as a shared and a static +library, this option forces the use of the static version. If no +static version was built when the compiler was configured, this option +has no effect. This is the default. +@end table + +@node Developer options +@section Developer options +@cindex developer options +@cindex debug dump options +@cindex dump options + +This section describes command-line options that are primarily of +interest to developers. + +@table @gcctabopt +@opindex fa68-dump-modes +@item -fa68-dump-modes +Output a list of all the modes parsed by the front-end. + +@opindex fa68-dump-ast +@item -fa68-dump-ast +Dump a textual representation of the parse tree. + +@opindex fa68-dump-module-interfaces +@item -fa68-dump-module-interfaces +Dump the interfaces of module definitions in the compiled packet. +@end table + +@node Composing programs +@chapter Composing programs +@cindex program +@cindex separated compilation + +This chapter documents how to compose full Algol 68 programs using the +modules and separated compilation support provided by this compiler. + +@menu +* Packets:: Compilation units. +* Modules:: Facilities for bottom-up programming. +* Holes:: Facilities for top-down programming. +* Particular programs:: The main program. +* The standard environment:: Environment conforming a full program. +@end menu + +@node Packets +@section Packets +@cindex packet +@cindex compilation unit + +Each Algol 68 source file contains a @dfn{packet}. Packets therefore +play the role of @dfn{compilation units}, and each packet can be +compiled separately to an object file. A set of compiled object files +can then be linked in the usual fashion into an executable, archive or +shared object by the system linker, without the need of any +language-specific link editor or build system. + +@noindent +This compiler supports three different kind of packets: + +@itemize @minus +@item +@dfn{Particular programs} constitute the entry point of a program. +They correspond to the @code{main} function of other languages like C. + +@xref{Particular programs}. + +@item +@dfn{Prelude packets} contain the definition of one or more modules, +which @dfn{publicize} definitions of modes, procedures, variables, +operators and even the publicized definitions of other modules. The +modules defined at the top-level of a prelude packet can be accessed +by other packets via an @code{@B{access}} construct. Prelude packets +are so-called because their contents get stuffed in the +@dfn{user-prelude} in the case of user-defined modules, or the +@dfn{library-prelude} in the case of module packets provided by the +compiler. They are usually used to compose libraries that can be used +in a bottom-up fashion. + +@xref{Modules}. + +@item +@dfn{Stuffing packets} contain the definition of an @dfn{actual hole}, +an @code{@B{egg}} construct, that can be stuffed in a matching +@dfn{formal hole} in another package via a @code{@B{nest}} construct. +Formal holes are used in order to achieve separated compilation in a +top-bottom fashion, and also to invoke procedures written in other +languages, such as C functions or Fortran subroutines. + +@xref{Holes}. +@end itemize + +A @dfn{collection of packets}, all of which must be compatible with +each other, constitutes either a @dfn{program} or a @dfn{library}. +Exactly one of the packets constituting a program shall be a +particular program. In libraries at least one packet must be a +prelude packet. + +@node Modules +@section Modules +@cindex module + +@dfn{Definition modules}, often referred as just @dfn{modules} in the +sequel, fulfill two different but related purposes. On one side, they +provide some degree of @dfn{protection} by preventing accessing +indicators defined within the module but not explicitly publicized. +On the other, they allow to define @dfn{interfaces}, allow separated +compilation based on these interfaces, and conform libraries. + +Modules are usually associated with bottom-up development strategies, +where several already written components are grouped and combined to +conform bigger components. + +@menu +* Writing modules:: Writing modules. +* Accessing modules:: Using the definitions of a module. +* Module activation:: How and when modules execute. +* Modules and libraries:: Using modules to conform libraries. +* Modules and protection:: When block structure is not enough. +@end menu + +@node Writing modules +@subsection Writing modules + +A @dfn{definition module} is a construct that provides access to a set +of publicized definitions. They can appear anywhere, but are +typically found in the outer reach and compiled separately, in which +case they conform a prelude packet (@pxref{Packets}). They are +composed of a prelude and a postlude. The publicized definitions +appear in the module's prelude. + +Consider for example the following definition module, which implements +a very simple logging facility: + +@example +@B{module} @B{Logger} = + @B{def} @B{int} fd = stderr; + @B{pub} @B{string} originator; + @B{pub} @B{proc} log = (@B{string} msg) @B{void}: + fputs (fd, (originator /= "" | ": ") + msg + "\n"); + + log ("beginning of log\n"); + @B{postlude} + log ("end of log\n"); + @B{fed} +@end example + +@noindent +The @dfn{module text} delimited by @code{@B{def}} and @code{@B{fed}} +gets ascribed to the module indicator @code{@B{Logger}}. Module +indicators are bold tags. Once defined, the module @code{@B{Logger}} +is accessible anywhere within its reach. + +The @dfn{prelude} of the module spans from @code{@B{def}} to either +@code{@B{postlude}}, or to @code{@B{fed}} in case of modules not +featuring a postlude. It consists on a restricted serial clause in a +void strong context, which can contain units and declarations, but no +labels or completers. The declarations in the prelude may be either +publicized or no publicized. As we shall see, publicized indicators +are accessible within the reach of the defining module publicizing +them. Publicized declarations are marked by preceding them with +@code{@B{pub}}. + +In our example the module prelude consists on three declarations and +one unit. The indicator @code{fd} is not publicized and is to be used +internally by the module. The indicators @code{originator} and +@code{log}, on the other hand, are publicized and conform the +interface of the module. Note how the range of the prelude also +covers the postlude: the @code{log} procedure is reachable there, as +it would be @code{fd} as well. + +The @dfn{postlude} of the module is optional and spans from +@code{@B{postlude}} to @code{@B{fed}}. It consists on a serial clause +in a @code{@B{void}} strong context, where definitions, labels and +module accesses are not allowed, just units. + +@node Accessing modules +@subsection Accessing modules + +Once a module is defined (@pxref{Writing modules}) it can be accessed, +provided it is within reach, using an @dfn{access clause}. The access +clause identifies the modules to access and then makes the publicized +definitions of these modules visible within a @dfn{control clause}. + +For example, this is how we could use the logger definition module +defined in a previous section to log the progress of some program that +reads an input file and writes some output file: + +@example +@B{access} @B{Logger} +@B{begin} # Identify ourselves with the program name # + originator := argv (1); + + # Read input file. # + @B{if} @B{NOT} parse_input (argv (2)) + @B{then} log ("error parsing input file"); stop @B{fi}; + + # Write output file. # + @B{if} @B{NOT} write_output (argv (3)) + @B{then} log ("error writing output file"); stop @B{fi}; + + log ("success") +@B{end} +@end example + +@noindent +In this case the controlled clause is the closed clause conforming the +particular program, and the definitions publicized by the logger +module, in this case @code{originator} and @code{log}, can be used +within it. + +@subsubsection Accessing several modules + +An access clause is not restricted to just provide access to a single +module: any number of module indicators can be specified in an access +clause. Suppose that our example processing program has to read and +write the data in JSON format, and that a suitable JSON library is +available in the form of a reachable module. We could then make both +logger and json modules accessible like this: + +@example +@B{access} @B{Logger}, @B{JSON} +@B{begin} # Identify ourselves with the program name # + originator := argv (1); + + @B{JSONVal} data; + + # Read input file. # + @B{if} data := json_from_file (argv (2)); + data = json no val + @B{then} log ("error parsing input file"); stop @B{fi}; + + # Write output file. # + @B{if} @B{not} json_to_file (argv (3), data) + @B{then} log ("error writing output file"); stop @B{fi}; + + log ("success") +@B{end} +@end example + +@noindent +In this version of the program the access clause includes the module +indicator @code{@B{json}}, and that makes the mode indicator +@code{@B{jsonval}} and the tags @code{@B{json no val}}, @code{json +from file} and @code{json to file} visible within the program's +closed clause. + +Note that the following two access clauses are not equivalent: + +@example +@B{access} @B{Logger}, @B{JSON} @B{C} ... @B{C}; +@B{access} @B{Logger} @B{access} @B{JSON} @B{C} ... @B{C}; +@end example + +@noindent +In the first case, a compilation time error is emitted if there is a +conflict among the publicized definitions of both modules; for +example, if both modules were to publicize a procedure called +@code{log}. In the second case, the declaration of @code{log} +publicized by @code{@B{Logger}} would hide the declaration of +@code{log} publicized by @code{@B{JSON}}. This also has implications +related to activation, that we will be discussing in a later section. + +@subsubsection The controlled clause + +The controlled clause in an access clause doesn't have to be a serial +clause, like in the examples above. It can be any enclosed clause, +like for example a loop clause: + +@example +@B{proc} frobnicate frobs = ([]@B{Frob} frobs) @B{void}: + @B{access} @B{Logger} @B{to} @B{UPB} frobs + @B{do} log ("frobnicating " + name @B{of} frob); + frobnicate (frob) + @B{od} +@end example + +@subsubsection The value yielded by an access clause + +The elaboration of an access clause yields a value, which is the value +yielded by the elaboration of the controlled clause. Since the later +is an enclosed clause, coercions get passed into them whenever +required, the usual fashion. + +We can see an example of this in the following procedure, whose body +is a controlled closed clause that yields a @code{@B{real}} value: + +@example +@B{proc} incr factor = (@B{ref}[]@B{real} factors, @B{int} idx) @B{real}: + @B{access} @B{logger} (log ("factor increased"); factors[idx] +:= 1.0) +@end example + +@noindent +Note how the access clause above is in a strong context requiring a +value of mode @code{@B{real}}. The value yielded by the access clause +is the value yielded by the controlled enclosed clause, which in this +case is a closed clause. The strong context and required mode gets +passed to the last unit of the closed clause (the assignation) which +in this case yields a value of mode @code{@B{ref} @B{real}}. The unit +is coerced to @code{@B{real}} by dereferencing, and the resulting +value becomes the value yielded by the access clause. + +@subsubsection Modules accessing other modules + +A definition module may itself access other modules. This is done by +placing the module text as a controlled clause of an access clause. +Suppose we rewrite our logger module so it uses JSON internally to log +JSON objects rather than raw strings. We could do it this way: + +@example +@B{module} @B{logger} = + @B{access} @B{json} + @B{def} @B{int} fd = stderr; + @B{pub} @B{string} originator; + @B{pub} @B{proc} log = (@B{string} msg) @B{void}: + fputs (fd, json array (json string (originator), + json string (msg))); + + log (json string ("beginning of log\n")); + @B{postlude} + log (json string ("end of log\n")); + @B{fed} +@end example + +@noindent +Note how this version of @code{@B{logger}} uses a few definitions +publicized by the @code{@B{json}} module. + +A program accessing @code{@B{logger}} will not see the definitions +publicized by the @code{@B{json}} module. If that is what we +intended, for example to allow the users of the logger to tweak their +own JSON, we would need to specify it this way: + +@example +@B{module} @B{logger} = + @B{access} @B{pub} @B{json} + @B{def} @B{c} ...as before... @B{c} @B{fed} +@end example + +@noindent +In this version the definitions publicized by @code{@B{json}} become +visible to programs accessing @code{@B{logger}}. + +@node Module activation +@subsection Module activation + +In all the examples seen so far the modules were accessed just once. +In these cases, accessing the module via an access-clause caused the +@dfn{activation} of the module. + +Activating a module involves elaborating all the declarations and +units that conform its prelude. Depending on the particular module +definition that gets activated, this may involve all sort of side +effects, such as allocating space for values and initializing them, +opening files, @i{etc}. Once the modules specified in the access +clause are successfully activated, the controlled clause gets +elaborated itself, within the reach of all the publicized definitions +by the activated modules as we saw in the last section. Finally, once +the controlled clause has been elaborated, the module gets +@dfn{revoked} by elaborating the serial clause in its postlude. + +However, nothing prevents some given definition module to be accessed +more than once in the same program. The following program, that makes +use of the @code{@B{logger}} module, exemplifies this: + +@example +@B{access} @B{logger} +@B{begin} originator := argv (1); + log ("executing program"); + @B{c} ... @B{c} + @B{access} @B{logger} (originator := argv (1) + ":subtask"; + log ("doing subtask") + @B{c} ... @B{c}) +@B{end} +@end example + +@noindent +In this program the module @code{@B{logger}} is accessed twice. The +code is obviously written assuming that the inner access clause +triggers a new activation of the @code{@B{logger}} module, allocating +new storage and executing its prelude. This would result in the +following log contents: + +@example +a.out: beginning of log +a.out: executing program +a.out:subtask: beginning of log +a.out:subtask: doing subtask +a.out:subtask: end of log +a.out: end of log +@end example + +@noindent +However, this is not what happens. The module gets only activated +once, as the result of the outer access clause. The inner access +clause just makes the publicized indicators visible in its controlled +clause. The actual resulting log output is: + +@example +a.out: beginning of log +a.out: executing program +a.out:subtask: doing subtask +a.out:subtask: end of log +@end example + +@noindent +Which is not what we intended. Modules are not classes. If we wanted +the logger to support several originators that can be nested, we would +need to add support for it in the definition module. Something like: + +@example +@B{module} @B{logger} = + @B{def} @B{int} fd = stderr, max originators = 10; + @B{int} orig := 0; + [max originators]@B{string} originators; + + @B{pub} @B{proc} push originator = (@B{string} str) @B{void}: + (@B{assert} (orig < max originators); + orig +:= 1; + originators[orig] := str); + @B{pub} @B{proc} pop originator = @B{void}: + (@B{assert} (max originators > 0); + orig -:= 1); + @B{pub} @B{proc} log = (@B{string} msg) @B{void}: + fputs (fd, (originator[orig] /= "" | ": ") + msg + "\n"); + + log ("beginning of log\n"); + @B{postlude} + log ("end of log\n"); + @B{fed} +@end example + +@noindent +Note how in this version of @code{@B{logger}} @code{originators} acts +as a stack of originator strings, and it is not publicized. The +management of the stack is done via a pair of publicized procedures +@code{push originator} and @code{pop originator}. Our program will +now look like: + +@example +@B{access} @B{logger} +@B{begin} push originator (argv (1)); + log ("executing program"); + @B{c} ... @B{c} + @B{access} @B{logger} (push originator ("subtask"); + log ("doing subtask") + @B{c} ... @B{c}; + pop originator) +@B{end} +@end example + +@noindent +And the log output is: + +@example +a.out: beginning of log +a.out: executing program +a.out:subtask: doing subtask +a.out: end of log +@end example + + +-------------------------------------------------------------- + +module-indications are used to find interface-definitions of modules: + + ACCESS FOO SKIP + +Looks for (in order): + + foo.m68 + foo.o + libfoo.so + +Should we use instead: + + ACCESS "foo" SKIP + +That would use for module indicators the same syntax than hole +indicators. + +Modules get accessed, invoked and revoked. + +Access clauses: + +: ACCESS A, B + +Where A and B are ``revelations''. + +In + +: MODULE A = ACCESS B DEF ... FED + +Doesn't reveals any contents of B. Whereas in: + +: MODULE A = ACCESS PUB B DEF .. FED + +The module A is also revealing B's public declarations. So accessing +A provides access to B. + +User-defined preludes go to the user-prelude. + +Invocation and revocation:: How modules are executed. + +It is possible for a definition module to not publicize any +definition. Such modules would be used only for the side effects +produced from executing the prelude and postlude when the module gets +invoked and revoked. XXX: provide an example? + +XXX + +@node Modules and libraries +@subsection Modules and libraries +@cindex library +@cindex prelude packet + +XXX + +@node Modules and protection +@subsection Modules and protection +@cindex protection +@cindex publicized definition + +XXX + +@node Holes +@section Holes +@cindex hole + +XXX + +@node Particular programs +@section Particular programs +@cindex particular program + +An Algol 68 @dfn{particular program} consists on an enclosed clause in +a strong context with target mode @code{@B{void}}, possibly preceded +by a set of zero or more labels. For example: + +@example +hello: +@B{begin} puts ("Hello, world!\n") +@B{end} +@end example + +@noindent +Note that the enclosed clause conforming the particular program +doesn't have to be a closed clause. Consider for example the +following program, that prints out its command line arguments: + +@example +@B{for} i @B{to} argc +@B{do} puts (argv (i) + "\n") @B{od} +@end example + +@menu +* Exit status:: How do programs communicate success or failure. +* The @code{stop} label:: How to terminate a program at any time. +@end menu + +@node Exit status +@subsection Exit status +@cindex exit status + +Some operating systems have the notion of @dfn{exit status} of a +process. In such systems, by default the execution of the particular +program results in an exit status of success. It is possible for the +program to specify an explicit exit status by using the standard +procedure @code{set exit status}, like: + +@example +@b{begin} # ... program code ... # + @B{if} error found; + @B{then} set exit status (1) @B{fi} +@b{end} +@end example + +In POSIX systems the status is an integer, and the system interprets a +value other than zero as a run-time error. In other systems the +status may be of some other type. To support this, the @code{set +error status} procedure accepts as an argument an united value that +accommodates all the supported systems. + +The following example shows a very simple program that prints ``Hello +world'' on the standard output and then returns to the operating +system with a success status: + +@example +@B{begin} puts ("Hello world\n") +@B{end} +@end example + +@node The @code{stop} label +@subsection The @code{stop} label +@cindex @code{stop} + +A predefined label named @code{stop} is defined in the standard +postlude. This label can be jumped to at any time by a program and it +will cause it to terminate and exit. For example: + +@example +@B{begin} @B{if} argc /= 2 + @B{then} puts ("Program requires exactly two arguments."); + goto stop + @B{fi} + @B{C} ... @B{C} +@B{end} +@end example + +@node The standard environment +@section The standard environment +@cindex standard environment + +The environment in which particular programs run is expressed here in +the form of pseudo code: + +@example +(@B{c} standard-prelude @B{c}; + @B{c} library-prelude @B{c}; + @B{c} system-prelude @B{c}; + @B{par} @B{begin} @B{c} system-task-1 @B{c}, + @B{c} system-task-2 @B{c}, + @B{c} system-task-n @B{c}, + @B{c} user-task-1 @B{c}, + @B{c} user-task-2 @B{c}, + @B{c} user-task-m @B{c} + @B{end}) +@end example + +@noindent +Where each user task consists on: + +@example +(@B{c} particular-prelude @B{c}; + @B{c} user-prelude @B{c}; + @B{c} particular-program @B{c}; + @B{c} particular-postlude @B{c}) +@end example + +The only standard system task described in the report is expressed in +pseudo-code as: + +@example +@B{do} @B{down} gremlins; undefined; @B{up} bfileprotect @B{od} +@end example + +@noindent +Which denotes that, once a book (file) is closed, anything may happen. +Other system tasks may exist, depending on the operating system. In +general these tasks in the parallel clause denote the fact that the +operating system is running in parallel (intercalated) with the user's +particular programs. + +@itemize @bullet +@item +The library-prelude contains, among other things, the prelude parts of +the defining modules provided by library. + +@item +The particular-prelude and particular-postlude are common to all the +particular programs. + +@item +The user-prelude is where the prelude parts of the defining modules +involved in the compilation get stuffed. If no defining module is +involved then the user-prelude is empty. +@end itemize + +Subsequent sections in this manual include a detailed description of +the contents of these preludes. + +@node Comments and pragmats +@chapter Comments and pragmats + +Comments and pragmats, also known collectively as @dfn{pragments}, can +appear almost anywhere in an Algol 68 program. Comments are usually +used for documentation purposes, and pragmats contain annotations for +the compiler. Both are handled at the lexical level. + +@menu +* Comments:: Your typical friendly comments. +* Pragmats:: In-source directives for the compiler. +@end menu + +@node Comments +@section Comments + +In the default modern stropping regime supported by GCC comments are +written between @code{@{} and @code{@}} delimiters, and can be nested +to arbitrary depth. For example: + +@example +foo +:= 1; @{ Increment foo. @} +@end example + +If UPPER stropping is selected, this compiler additionally supports +three classical Algol 68 comment styles, in which the symbols marking +the beginning of comments are the same than the symbols marking the +end of comments and therefore can't be nested: @code{@B{comment} +... @B{comment}}, @code{@B{co} ... @B{co}} and @code{# .. #}. For +example: + +@example +@B{comment} + This is a comment. +@B{comment} + +foo := 10; @B{co} this is also a comment @B{co} +foo +:= 1; # and so is this. # +@end example + +Unless @option{-std=algol68} is specified in the command line, two +styles of nestable comments can be also used with UPPER stropping: the +already explained @code{@{ ... @}} and a ``bold'' style that uses +@code{@B{code} ... @B{edoc}}. For example: + +@example +foo := 10; @{ this is a nestable comment in brief style. @} +foo +:= 1; @B{note} this is a nestable comment in bold style. @B{eton}. +@end example + +@example +@B{note} + "Bold" nestable comments. +@B{eton} + +@{ "Brief" nestable comments. @} +@end example + +In UPPER stropping all comment styles are available, both classic and +nestable. In modern SUPPER stropping, which is based on reserved +words, only @code{@{ ... @}} is available. + +@node Pragmats +@section Pragmats + +@cindex pragmat +@dfn{Pragmats} (also known as @dfn{pragmas} in other programming +languages) are directives and annotations for the compiler, and their +usage impacts the compilation process in several ways. A pragmat +starts with either @code{@B{pragmat}} or @code{@B{pr}} and finished +with either @code{@B{pragmat}} or @code{@B{pr}} respectively. +Pragmats cannot be nested. For example: + +@example +@B{pr} include "foo.a68" @B{pr} +@end example + +The interpretation of pragmats is compiler-specific. This chapter +documents the pragmats supported by GCC. + +@menu +* pragmat include:: Include another source file. +@end menu + +@node pragmat include +@subsection pragmat include +@cindex include + +An @dfn{include pragmat} has the form: + +@example +@B{pr} include "PATH" @B{pr} +@end example + +@noindent +Where @code{PATH} is the path of the file whose contents are to be +included at the location of the pragmat. If the provided path is +relative then it is interpreted as relative to the directory +containing the source file that contains the pragmat. + +The @option{-I} command line option can be used in order to add +additional search paths for @code{include}. + +@node Hardware representation +@chapter Hardware representation + +The @dfn{reference language} specified by the Revised Report describes +Algol 68 particular programs as composed by @dfn{symbols}. However, +the Report leaves the matter of the concrete representation of these +symbols, the @dfn{representation language}, open to the several +implementations. This was motivated by the very heterogeneous +computer systems in existence at the time the Report was written, +which made flexibility in terms of representation a crucial matter. + +This flexibility was indeed exploited by the early implementations, +and there was a price to pay for it. A few years after the +publication of the Revised Report the different implementations had +already given rise to a plethora of many related languages that, +albeit being strict Algol 68, differed considerably in appearance. +This, and the fact that people were already engrossed in writing +programs other than compilers that needed to process Algol 68 +programs, such as code formatters and macro processors, prompted the +WG 2.1 to develop and publish a @dfn{Report on the Standard Hardware +Representation for ALGOL 68}, which came out in 1975. + +This compiler generally follows the Standard Hardware Representation, +but deviates from it in a few aspects. This chapter provides an +overview of the hardware representation and documents any deviation. + +@menu +* Representation languages:: From symbols to syntactic marks. +* Worthy characters:: Marks that can appear in a program. +* Base characters:: Mapping of worthy characters to code points. +* Stropping regimes:: Representation of bold words. +* Monads and Nomads:: Characters that can appear in operator names. +* String breaks:: String literals and escape sequences. +@end menu + +@node Representation languages +@section Representation languages + +A program in the strict Algol 68 language is composed by a series of +symbols. These symbols have names such as @code{letter-a-symbol} and +@code{assigns-to-symbol} which are, well, purely symbolic. In fact, +these are notions in the two-level grammar that defines the strict +language. + +A @dfn{representation language} provides a mapping between symbols in +the strict language and the representation of these symbols. Each +representation is a sequence of syntactic marks. For example, the +@code{completion symbol} may be represented by @strong{exit}, where +the marks are the bold letters. The @code{tilde symbol} may be +represented by @code{~}, which is a single mark. The representation of +@code{assigns to symbol} is @code{:=}, which is composed by the two +marks @code{:} and @code{=}. The representation of @code{letter-a} +is, not surprising, the single mark @code{a}. + +The section 9.4 of the Report describes the recommended representation +for all the symbols of the language. The set of all recommendations +constitutes the so-called @dfn{reference language}. Algol 68 +implementations are strongly encouraged to use representation +languages which are similar enough to the reference language, +recognizable ``without further elucidation'', but this is not +strictly required. + +A representation language may specify more than one representation for +a given symbol. For example, in the reference language the @code{is +not symbol} is represented by @strong{isnt}, @code{:/=:} and a variant +of the later where the slash sign is superimposed on the equal sign. +In this case, an implementation can choose to implement any number of +the representations. + +Spaces, tabs and newlines are @dfn{typographical display features} +that, when they appear between symbols, are of no significance and do +not alter the meaning of the program. However, when a space or a tab +appear in string or character denotations, they represent the +@code{space symbol} and the @code{tab symbol} +respectively@footnote{The @code{tab symbol} is a GNU extension}. + +@node Worthy characters +@section Worthy characters +@cindex worthy characters + +The syntactic marks of a representation language, both symbols and +typographical display features, are realized as a set of @dfn{worthy +characters} and the newline. Effectively, an Algol 68 program is a +sequence of @dfn{worthy characters} and newlines. The worthy +characters are: + +@example +a b c d e f g h i j k l m n o p q r s t u v w x y z +A B C D E F G H I J K L M N O P Q R S T U V W X Y Z +0 1 2 3 4 5 6 7 8 9 +space tab " # $ % & ' ( ) * + , - . / : ; < = > @ [ \ ] +^ _ | @ ! ? ~ @{ @} +@end example + +Some of the characters above were considered unworthy by the original +Standard Hardware Representation: + +@table @code +@item ! +It was considered unworthy because many installations didn't have a +vertical bar base character, and @code{!} was used as a base character +for @code{|}. Today every computer system features a vertical bar +character, so @code{!} can qualify as a worthy character. +@item & +The Revised Report specifies that @code{&} is a monad, used as a +symbol for the dyadic @code{@B{and}} operator. The Standard Hardware +representation decided to turn it into an unworthy character, +motivated by the fact that no nomads existed for the other logical +operators @code{@B{not}} and @code{@B{or}}, and also with the goal of +maintaining the set of worthy characters as small as possible to +improve portability. Recognizing that the first motivation still +holds, but not the second, this compiler re-instates @code{&} as a +monad but doesn't use it as an alternative representation of the +@code{@B{and}} operator. +@item ~ +The Standard Hardware Representation vaguely cites some ``severe +difficulties'' with the hardware representation of the tilde +character. Whatever these difficulties were at the time, they surely +don't exist anymore. This compiler therefore recognizes @code{~} as a +worthy character, and is used as a monad. +@item ? +The question mark character was omitted as a worthy character to limit +the size of the worthy set. This compiler recognizes @code{?} as a +worthy character, and is used as a monad. +@item \ +Back-slash wasn't included as a worthy character because back in 1975 +it wasn't supported in EBCDIC (it is now). This compiler recognizes +@code{\} as a worthy character. +@item tab +This compiler recognizes the tabulator character as a worthy +character, and it is used as a typographical display feature. +@end table + +@node Base characters +@section Base characters +@cindex base characters + +The worthy characters described in the previous section are to be +interpreted symbolically rather than visually. The worthy character +@code{|}, for example, is the vertical line character and generally +looks the same in every system. The worthy character @code{space} is +obviously referred by a symbolic name. + +The actual visually distinguishable characters available in an +installation are known as @dfn{base characters}. The Standard +Hardware Representation allows implementations the possibility of +using two or more base characters to represent a single worthy +character. This was the case of the @code{|} character, which was +represented in many implementations by either @code{|} or @code{!}. + +This compiler uses the set of base characters corresponding to the +subset of the Unicode character set that maps one to one to the set of +worthy characters described in the previous section: + +@example +A-Z 65-90 +a-z 97-122 +space 32 +tab 9 +! 33 +" 34 +# 35 +$ 36 +% 37 +& 38 +' 39 +( 40 +) 41 +* 42 ++ 43 +, 44 +- 45 +. 46 +/ 47 +: 58 +; 59 +< 60 += 61 +> 62 +? 63 +@@ 64 +[ 91 +\ 92 +] 93 +^ 94 +_ 95 +| 124 +~ 126 +@end example + +@node Stropping regimes +@section Stropping regimes + +The Algol 68 reference language establishes that certain source +constructs, namely mode indications and operator indications, consist +in a sequence of @dfn{bold letters} and @dfn{bold digits}, known as a +@dfn{bold word}. In contrast, other constructs like identifiers, +field selectors and labels, collectively known as @dfn{tags}, are +composed of regular, non-bold letters and digits. + +What is precisely a bold letter or digit, and how they differ from +non-bold letters and digits, is not specified by the Report. This is +no negligence, but a conscious effort at abstracting the definition of +the so-called @dfn{strict language} from its representation. This +allows different representations of the same language. + +Some representations of Algol 68 are intended to be published in +books, be it paper or electronic devices, and be consumed by persons. +These are called @dfn{publication languages}. In publication +languages bold letters and digits are typically represented by actual +bold alphanumeric typographic marks. An Algol 68 program hand written +on a napkin or a sheet of paper would typically represent bold letters +and digits underlined, or stroked using a different color ink. + +Other representations of Algol 68 are intended to be automatically +processed by a computer. These representations are called +@dfn{hardware languages}. Sometimes the hardware languages are also +intended to be written and read by programmers; these are called +@dfn{programming languages}. + +Unfortunately, computer systems today usually do not yet provide +readily usable and ergonomic bold or underline alphanumeric marks, +despite the existence of Unicode and modern and sophisticated editing +environments. The lack of appropriate input methods surely plays a +role to explain this. Thus, the programming representation languages +of Algol 68 should resort to a technique known as @dfn{stropping} in +order to differentiate bold letters and digits from non-bold letters +and digits. The set of rules specifying the representation of these +characters is called a @dfn{stropping regime}. + +There are three classical stropping regimes for Algol 68, which are +standardized and specified in the Standard Hardware Representation +normative document. These are @dfn{POINT stropping}, @dfn{RES +stropping} and @dfn{UPPER stropping}. The following sections do a +cursory tour over them; for more details the reader is referred to the +Standard Hardware Representation. + +This compiler implements UPPER stropping and SUPPER stropping. + +@menu +* POINT stropping:: +* RES stropping:: +* UPPER stropping:: +* SUPPER stropping:: +@end menu + +@node POINT stropping +@subsection POINT stropping + +POINT stropping is in a way the most fundamental of the three standard +regimes. It was designed to work in installations with limited +character sets that provide only one alphabet, one set of digits, and +a very restricted set of other symbols. + +In POINT stropping a bold word is represented by its constituent +letters and digits preceded by a point character. For example, the +symbol @code{bold begin symbol} in the strict language, which is +represented as @strong{begin} in bold face in the reference language, +would be represented as @code{.BEGIN} in POINT stropping. + +More examples are summarized in the following table. + +@multitable @columnfractions .33 .33 .33 +@headitem Strict language @tab Reference language @tab POINT stropping +@item @code{true symbol} @tab @strong{true} @tab @code{.TRUE} +@item @code{false symbol} @tab @strong{false} @tab @code{.FALSE} +@item @code{integral symbol} @tab @strong{int} @tab @code{.INT} +@item @code{completion symbol} @tab @strong{exit} @tab @code{.EXIT} +@item @code{bold-letter-c-...} @tab @strong{crc32} @tab @code{.CRC32} +@end multitable + +In POINT stropping a tag is represented by writing its constituent +non-bold letters and digits in order. But they are organized in +several @dfn{taggles}. + +Each taggle is a sequence of one or more letters and digits, +optionally followed by an underscore character. For example, the tag +@code{PRINT} is composed of a single taggle, but the tag +@code{PRINT_TABLE} is composed of a first taggle @code{PRINT_} +followed by a second taggle @code{TABLE}. + +To improve readability it is possible to insert zero or more white +space characters between the taggles in a tag. Therefore, the tag +@code{PRINT_TABLE} could have been written @code{PRINT TABLE}, or even +@code{PRINT_ TABLE}. This is the reason why Algol 68 identifiers, +labels and field selectors can and do usually feature white spaces in +them. + +It is important to note that both the trailing underscore characters +in taggles and the white spaces in a tag do not contribute anything to +the denoted tag: these are just stropping artifacts aimed to improve +readability. Therefore @code{FOOBAR} @code{FOO BAR}, @code{FOO_BAR} +and @code{FOO_BAR_} are all representations of the same tag, that +represents the +@code{letter-f-letter-o-letter-o-letter-b-letter-a-letter-r} language +construct. + +Below is the text of an example Algol 68 procedure encoded in POINT +stropping. + +@example +.PROC RECSEL OUTPUT RECORDS = .VOID: +.BEGIN .BITS FLAGS + := (INCLUDE DESCRIPTORS | REC F DESCRIPTOR | REC F NONE); + .RECRSET RES = REC DB QUERY (DB, RECUTL TYPE, + RECUTL QUICK, FLAGS); + .RECWRITER WRITER := REC WRITER FILE NEW (STDOUT); + + SKIP COMMENTS .OF WRITER := .TRUE; + .IF RECUTL PRINT SEXPS + .THEN MODE .OF WRITER := REC WRITER SEXP .FI; + REC WRITE (WRITER, RES) +.END +@end example + +@node RES stropping +@subsection RES stropping + +The early installations where Algol 68 ran not only featured a very +restricted character set, but also suffered from limited storage and +complex to use and time consuming input methods such as card punchers +and readers. It was important for the representation of programs to +be as compact as possible. + +It is likely that is what motivated the introduction of the RES +stropping regime. As its name implies, it removes the need of +stropping many bold words by introducing @dfn{reserved words}. + +A @dfn{reserved word} is one of the bold words specified in the +section 9.4.1 of the Report as a representation of some symbol. +Examples are @strong{at}, @strong{begin}, @strong{if}, @strong{int} +and @strong{real}. + +RES stropping encodes bold words and tags like POINT stropping, but if +a bold word is a reserved word then it can then be written without a +preceding point, achieving this way a more compact, and easier to +read, representation for programs. + +Introducing reserved words has the obvious disadvantage that some tags +cannot be written the obvious way due to the possibility of conflicts. +For example, to represent a tag @code{if} it is not possible to just +write @code{IF}, because it conflicts with a reserved word, but this +can be overcome easily (if not elegantly) by writing @code{IF_} +instead. + +Below is the @code{recsel output records} procedure again, this time +encoded in RES stropping. + +@example +PROC RECSEL OUTPUT RECORDS = VOID: +BEGIN BITS FLAGS + := (INCLUDE DESCRIPTORS | REC F DESCRIPTOR | REC F NONE); + .RECRSET RES = REC DB QUERY (DB, RECUTL TYPE, + RECUTL QUICK, FLAGS); + .RECWRITER WRITER := REC WRITER FILE NEW (STDOUT); + + SKIP COMMENTS OF WRITER := TRUE; + IF RECUTL PRINT SEXPS + THEN MODE .OF WRITER := REC WRITER SEXP FI; + REC WRITE (WRITER, RES) +END +@end example + +Note how user-defined mode an operator indications still require +explicit stropping. + +@node UPPER stropping +@subsection UPPER stropping + +In time computers added support for more than one alphabet by +introducing character sets with both upper and lower case letters, +along with convenient ways to both input and display these. + +In UPPER stropping the bold letters in bold word are represented by +upper-case letters, whereas the letters in tags are represented by +lower-case letters. + +The notions of upper- and lower-case are not applicable to digits, but +since the language syntax assures that it is not possible to have a +bold word that starts with a digit, digits are considered to be bold +if they follow a bold letter or another bold digit. + +Below is the @code{recsel output records} procedure again, this time +encoded in UPPER stropping. + +@example +PROC recsel output records = VOID: +BEGIN BITS flags + := (include descriptors | rec f descriptor | rec f none); + RECRSET res = rec db query (db, recutl type, + recutl quick, flags); + RECWRITER writer := rec writer file new (stdout); + + skip comments of writer := TRUE; + IF recutl print sexps + THEN mode OF writer := rec writer sexp FI; + rec write (writer, res) +END +@end example + +Note how in this regime it is almost never necessary to introduce bold +tags with points. All in all, it looks much more natural to +contemporary readers. UPPER stropping is in fact the stropping regime +of choice today. It is difficult to think of any reason why anyone +would resort to use POINT or RES stropping. + +@node SUPPER stropping +@subsection SUPPER stropping + +In the SUPPER stropping regime bold words are written by writing a +sequence of one or more @dfn{taggles}. Each taggle is written by +writing a letter followed by zero or more other letters and digits and +is optionally followed by a trailing underscore character. The first +letter in a bold word shall be an upper-case letter. The rest of the +letters in the bold word may be either upper- or lower-case. + +For example, @code{RecRset}, @code{Rec_Rset} and @code{RECRset} are +all different ways to represent the same mode indication. This allows +to recreate popular naming conventions such as @code{CamelCase}. + +As in the other stropping regimes, the casing of the letters and the +underscore characters are not really part of the mode or operator +indication. + +Operator indications are also bold words and are written in exactly +the same way than mode indications, but it is usually better to always +use upper-case letters in operator indications. On one side, it looks +better, especially in the case of dyadic operators where the asymmetry +of, for example @code{Equal} would look odd, consider @code{m1 Equal +m2} as opposed to @code{m1 EQUAL m2}. On the other side, tools like +editors can make use of this convention in order to highlight operator +indications differently than mode indications. + +In the SUPPER stropping regime tags are written by writing a sequence +of one or more @dfn{taggles}. Each taggle is written by writing a +letter followed by zero or more other letters and digits and is +optionally followed by a trailing underscore character. All letters +in a tag shall be lower-case letters. + +For example, the identifier @code{list} is represented by a single +taggle, and it is composed by the letters @code{l}, @code{i}, @code{s} +and @code{t}, in order. In the jargon of the strict language we would +spell the tag as @code{letter-l-letter-i-letter-s-letter-t}. + +The label @code{found_zero} is represented by two taggles, +@code{found_} and @code{zero}, and it is composed by the letters +@code{f}, @code{o}, @code{u}, @code{n}, @code{d}, @code{z}, @code{e}, +@code{r} and @code{o}, in order. In the jargon of the strict language +we would spell the tag as @code{letter-f-letter-o-letter-u-letter-n +-letter-d-letter-z-letter-e-letter-r-letter-o}. + +The identifier @code{crc_32} is likewise represented by two taggles, +@code{crc_} and @code{32}. Note how the second taggle contains only +digits. In the jargon of the strict language we would spell the tag +as @code{letter-c-letter-r-letter-c-digit-three-digit-two}. + +The underscore characters are not really part of the tag, but part of +the stropping. For example, both @code{goto found_zero} and +@code{goto foundzero} jump to the same label. + +The @code{recsel output records} procedure, encoded in SUPPER +stropping, looks like below. + +@example +proc recsel_output_records = void: +begin bits flags + := (include_descriptors | rec_f_descriptor | rec_f_none); + RecRset res = rec_db_query (db, recutl_type, + recutl_uick, flags); + RecWriter writer := rec_writer_file_new (stdout); + + skip_comments of writer := true; + if recutl_print_sexps + then mode_ of writer := rec_writer_sexp fi; + rec_write (writer, res) +end +@end example + +@node Monads and Nomads +@section Monads and Nomads +@cindex monads +@cindex nomads + +Algol68 operators, be them predefined or defined by the programmer, +can be referred via either bold tags or sequences of certain +non-alphabetic symbols. For example, the dyadic operator @code{+} is +defined for many modes to perform addition, the monadic operator +@code{@B{entier}} gets a real value and rounds it to an integral +value, and the operator @code{:=:} is the identity relation. Many +operators provide both bold tag names and symbols names, like in the +case of @code{:/=:} that can also be written as @code{@B{isnt}}. + +Bold tags are lexically well delimited, and if the same tag is used to +refer to a monadic operator and to a dyadic operator, no ambiguity can +arise. For example, in the following program it is clear that the +second instance of @code{@B{plus}} refers to the monadic operator, and +the first instance refers to the dyadic operator@footnote{If one would +write @code{@B{plusplus}}, it would be a third different bold tag.}. + +@example +@B{op} @B{PLUS} = (@B{int} a, b) @B{int}: a + b, + @B{PLUS} = (@B{int} a): a; +@B{int} val = 2 @B{PLUS} @B{PLUS} 3; +@end example + +On the other hand, symbols are not lexically delimited as words, and +one symbol can appear immediately following another symbol. This can +lead to ambiguities. For example, if we were to define a C-like +monadic operator @code{++} like: + +@example +@B{op} ++ = (@B{ref} @B{int} a) @B{int}: (@B{int} t = a; a +:=1; t); +@end example + +@noindent +Then the expression @code{++a} would be ambiguous: is it @code{++a} or +@code{+(+a)}?. In a similar way, if we would use @code{++} as the +name of a dyadic operator, an expression like @code{a++b} could be +also interpreted as both @code{a++b} and @code{a+(+b)}. + +To avoid these problems Algol 68 divides the symbols which are +suitable to appear in the name of an operator into two classes: monads +and nomads. @dfn{Monads} are symbols that can be used as monadic +operators. @dfn{Nomads} are symbols which can be used as both monadic +or dyadic operators. Given these two sets, the rules to conform a +valid operator are: + +@itemize @minus +@item A bold tag. +@item Any monad. +@item A monad followed by a nomad. +@item A monad optionally followed by a nomad followed by either @code{:=} or @code{=:}, but not by both. +@end itemize + +@noindent +In the GNU Algol 68 compiler: + +@itemize @minus +@item The set of monads is @code{%^&+-~!?}. +@item The set of nomads is @code{> 1} and +@code{1 - small real < 1}. +@end deftypevr + +@deftypevr Constant @B{int} {bits lengths} +1 plus the number of extra widths of bits which are meaningful. +@end deftypevr + +@deftypevr Constant @B{int} {bits shorths} +1 plus the number of extra shorths of bits which are meaningful. +@end deftypevr + +@deftypevr Constant @B{int} {bits width} +@deftypevrx Constant @B{int} {long bits width} +@deftypevrx Constant @B{int} {long long bits width} +The number of bits in a @code{@B{bits}} value. +@end deftypevr + +@deftypevr Constant @B{int} {bytes lengths} +1 plus the number of extra widths of bytes which are meaningful. +@end deftypevr + +@deftypevr Constant @B{int} {bytes shorths} +1 plus the number of extra shorths of bytes which are meaningful. +@end deftypevr + +@deftypevr Constant @B{int} {bytes width} +@deftypevrx Constant @B{int} {long bytes width} +@deftypevrx Constant @B{int} {long long bytes width} +The number of chars in a @code{@B{bytes}} value. +@end deftypevr + +@deftypevr Constant @B{int} {max abs char} +The largest value which @code{@B{abs}} of a @code{@B{char}} can yield. +@end deftypevr + +@deftypevr Constant @B{char} {null character} +Some character. +@end deftypevr + +@deftypevr Constant @B{char} flip +@deftypevrx Constant @B{char} flop +Characters used to represent @code{@B{true}} and @code{@B{false}} +boolean values in textual transput. +@end deftypevr + +@deftypevr Constant @B{char} {error char} +Character used to represent the digit of a value resulting from a +conversion error in textual transput. +@end deftypevr + +@deftypevr Constant @B{char} blank +The space character. +@end deftypevr + +@deftypevr Constant {@B{l} @B{real}} {L pi} +The number pi. +@end deftypevr + +@node Standard modes +@section Standard modes + +@deftp Mode @B{void} +The only value of this mode is @code{@B{empty}}. +@end deftp + +@deftp Mode @B{bool} +Mode for the boolean truth values @code{@B{true}} and @code{@B{false}}. +@end deftp + +@deftp Mode {@B{l} @B{int}} +Modes for signed integral values. Each @code{@B{long}} or +@code{@B{short}} may increase or decrease the range of the domain, +depending on the characteristics of the current target. Further +@code{@B{long}}s and @code{@B{short}}s may be specified with no +effect. +@end deftp + +@deftp Mode {@B{l} @B{real}} +Modes for signed real values. Each @code{@B{long}} may increase the +upper range of the domain, depending on the characteristics of the +current target. Further @code{@B{long}}s may be specified but with no +effect. +@end deftp + +@deftp Mode @B{char} +Mode for character values. The character values are mapped one-to-one +to code points in the 21-bit space of Unicode. +@end deftp + +@deftp Mode @B{string} {= @B{flex}[1:0]@B{char}} +Mode for sequences of characters. This is implemented as a flexible +row of @code{@B{char}} values. +@end deftp + +@deftp Mode {@B{l} @B{compl}} {= @B{struct} (@B{real} re,im)} +Modes for complex values. Each @code{@B{long}} may increase the +precision of both the real and imaginary parts of the numbers, +depending on the characteristics of the current target. Further +@code{@B{long}}s may be specified with no effect. +@end deftp + +@deftp Mode {@B{l} @B{bits}} +Compact and efficient representation of a row of boolean values. Each +@code{@B{long}} may increase the number of booleans that can be packed +in a bits, depending on the characteristics of the current target. +@end deftp + +@deftp Mode {@B{l} @B{bytes}} +Compact and efficient representation of a row of character values. +Each @code{@B{long}} may increase the number of characters that can be +packed in a bytes, depending on the characteristics of the current +target. +@end deftp + +@node Standard priorities +@section Standard priorities + +@table @code +@item 1 +@itemize @bullet +@item @code{plusab}, @code{+:=} +@item @code{minusab}, @code{-:=} +@item @code{timesab}, @code{*:=} +@item @code{divab}, @code{/:=} +@item @code{overab}, @code{%:=} +@item @code{modab}, @code{%*:=} +@item @code{plusto}, @code{+=:} +@end itemize + +@item 2 +@itemize @bullet +@item @code{or} +@end itemize + +@item 3 +@itemize @bullet +@item @code{and} +@item @code{xor} +@end itemize + +@item 4 +@itemize @bullet +@item @code{@B{eq}}, @code{=} +@item @code{@B{ne}}, @code{/=} +@end itemize + +@item 5 +@itemize @bullet +@item @code{@B{lt}}, @code{<}, +@item @code{@B{le}}, @code{<=} +@item @code{@B{gt}}, @code{>} +@item @code{@B{ge}}, @code{>=} +@end itemize + +@item 6 +@itemize @bullet +@item @code{+} +@item @code{-} +@end itemize + +@item 7 +@itemize @bullet +@item @code{*} +@item @code{/} +@item @code{@B{over}}, @code{%} +@item @code{@B{mod}}, @code{%*} +@item @code{@B{elem}} +@end itemize + +@item 8 +@itemize @bullet +@item @code{**} +@item @code{@B{shl}}, @code{@B{up}} +@item @code{@B{shr}}, @code{@B{down}} +@item @code{@B{up}}, @code{@B{down}} +@item @code{^} +@item @code{@B{lwb}} +@item @code{@B{upb}} +@end itemize + +@item 9 +@itemize @bullet +@item @code{@B{i}} +@item @code{+*} +@end itemize +@end table + +@node Rows operators +@section Rows operators + +The following operators work on any row mode, denoted below using the +pseudo-mode @code{@B{rows}}. + +@deftypefn Operator {} {@B{lwb}} {= (@B{rows} a) @B{int}} +Monadic operator that yields the lower bound of the first bound pair +of the descriptor of the value of @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{upb}} {= (@B{rows} a) @B{int}} +Monadic operator that yields the upper bound of the first bound pair +of the descriptor of the value of @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{lwb}} {= (@B{int} n, @B{rows} a) @B{int}} +Dyadic operator that yields the lower bound in the n-th bound pair of +the descriptor of the value of @code{a}, if that bound pair exists. +Attempting to access a non-existing bound pair results in a run-time +error. +@end deftypefn + +@deftypefn Operator {} {@B{upb}} {= (@B{int} n, @B{rows} a) @B{int}} +Dyadic operator that yields the upper bound in the n-th bound pair of +the descriptor of the value of @code{a}, if that bound pair exists. +Attempting to access a non-existing bound pair results in a run-time +error. +@end deftypefn + +@node Boolean operators +@section Boolean operators + +@deftypefn Operator {} {@B{not}} {= (@B{bool} a) @B{bool}} +@deftypefnx Operator {} {~} {= (@B{bool} a) @B{bool}} +Monadic operator that yields the logical negation of its operand. +@end deftypefn + +@deftypefn Operator {} {@B{or}} {= (@B{bool} a, b) @B{bool}} +Dyadic operator that yields the logical ``or'' of its operands. +@end deftypefn + +@deftypefn Operator {} {@B{and}} {= (@B{bool} a, b) @B{bool}} +@deftypefnx Operator {} {@B{&}} {= (@B{bool} a, b) @B{bool}} +Dyadic operator that yields the logical ``and'' of its operands. +@end deftypefn + +@deftypefn Operator {} {@B{eq}} {= (@B{bool} a, b) @B{bool}} +@deftypefnx Operator {} {=} {= (@B{bool} a, b) @B{bool}} +Dyadic operator that yields @code{@B{true}} if its operands are the +same truth value, @code{@B{false}} otherwise. +@end deftypefn + +@deftypefn Operator {} {@B{ne}} {= (@B{bool} a, b) @B{bool}} +@deftypefnx Operator {} {/=} {= (@B{bool} a, b) @B{bool}} +Dyadic operator that yields @code{@B{false}} if its operands are the +same truth value, @code{@B{true}} otherwise. +@end deftypefn + +@deftypefn Operator {} {@B{abs}} {= (@B{bool} a) @B{int}} +Monadic operator that yields 1 if its operand is @code{@B{true}}, and +0 if its operand is @code{@B{false}}. +@end deftypefn + +@node Integral operators +@section Integral operators + +@subsection Arithmetic + +@deftypefn Operator {} {+} {= (@B{l} @B{int} a) @B{l} @B{int}} +Monadic operator that yields the affirmation of its operand. +@end deftypefn + +@deftypefn Operator {} {-} {= (@B{l} @B{int} a) @B{l} @B{int}} +Monadic operator that yields the negative of its operand. +@end deftypefn + +@deftypefn Operator {} {@B{abs}} {= (@B{l} @B{int} a) @B{l} @B{int}} +Monadic operator that yields the absolute value of its operand. +@end deftypefn + +@deftypefn Operator {} {@B{sign}} {= (@B{l} @B{int} a) @B{int}} +Monadic operator that yields -1 if @code{a} if negative, 0 if @code{a} +is zero and 1 if @code{a} is positive. +@end deftypefn + +@deftypefn Operator {} {@B{odd}} {= (@B{l} @B{int} a) @B{bool}} +Monadic operator that yields @code{@B{true}} if its operand is odd, +@code{@B{false}} otherwise. +@end deftypefn + +@deftypefn Operator {} {+} {= (@B{l} @B{int} a, b) @B{l} @B{int}} +Dyadic operator that yields the addition of its operands. +@end deftypefn + +@deftypefn Operator {} {-} {= (@B{l} @B{int} a, b) @B{l} @B{int}} +Dyadic operator that yields @code{b} subtracted from @code{a}. +@end deftypefn + +@deftypefn Operator {} {*} {= (@B{l} @B{int} a, b) @B{l} @B{int}} +Dyadic operator that yields the multiplication of its operands. +@end deftypefn + +@deftypefn Operator {} {@B{over}} {= (@B{l} @B{int} a, b) @B{l} @B{int}} +@deftypefnx Operator {} {%} {= (@B{l} @B{int} a, b) @B{l} @B{int}} +Dyadic operator that yields the integer division of @code{a} by +@code{b}, rounding the quotient toward zero. +@end deftypefn + +@deftypefn Operator {} {@B{mod}} {= (@B{l} @B{int} a, b) @B{l} @B{int}} +@deftypefnx Operator {} {%*} {= (@B{l} @B{int} a, b) @B{l} @B{int}} +Dyadic operator that yields the remainder of the division of @code{a} +by @code{b}. +@end deftypefn + +@deftypefn Operator {} {/} {= (@B{l} @B{int} a, b) @B{l} @B{real}} +Dyadic operator that yields the integer division with real result of +@code{a} by @code{b}. +@end deftypefn + +@deftypefn Operator {} {**} {= (@B{l} @B{int} a, b) @B{l} @B{int}} +@deftypefnx Operator {} {^} {= (@B{l} @B{int} a, b) @B{l} @B{int}} +Dyadic operator that yields @code{a} raised to the exponent @code{b}. +@end deftypefn + +@subsection Arithmetic combined with assignation + +@deftypefn Operator {} {@B{plusab}} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}} +@deftypefnx Operator {} {+:=} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}} +@dfn{Plus and become}. Dyadic operator that calculates @code{a + b}, +assigns the result of the operation to the name @code{a} and then +yields @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{minusab}} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}} +@deftypefnx Operator {} {-:=} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}} +Dyadic operator that calculates @code{a - b}, assigns the result of +the operation to the name @code{a} and then yields @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{timesab}} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}} +@deftypefnx Operator {} {*:=} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}} +Dyadic operator that calculates @code{a * b}, assigns the result of +the operation to the name @code{a} and then yields @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{overab}} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}} +@deftypefnx Operator {} {%:=} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}} +Dyadic operator that calculates @code{a % b}, assigns the result of +the operation to the name @code{a} and then yields @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{modab}} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}} +@deftypefnx Operator {} {%*:=} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}} +Dyadic operator that calculates @code{a %* b}, assigns the result of +the operation to the name @code{a} and then yields @code{a}. +@end deftypefn + +@subsection Relational + +@deftypefn Operator {} {@B{eq}} {= (@B{l} @B{int} a, b) @B{bool}} +@deftypefnx Operator {} {=} {= (@B{l} @B{int} a, b) @B{bool}} +Dyadic operator that yields whether its operands are equal. +@end deftypefn + +@deftypefn Operator {} {@B{ne}} {= (@B{l} @B{int} a, b) @B{bool}} +@deftypefnx Operator {} {/=} {= (@B{l} @B{int} a, b) @B{bool}} +Dyadic operator that yields whether its operands are not equal. +@end deftypefn + +@deftypefn Operator {} {@B{lt}} {= (@B{l} @B{int} a, b) @B{bool}} +@deftypefnx Operator {} {<} {= (@B{l} @B{int} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is less than @code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{le}} {= (@B{l} @B{int} a, b) @B{bool}} +@deftypefnx Operator {} {<=} {= (@B{l} @B{int} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is less than, or equal to +@code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{gt}} {= (@B{l} @B{int} a, b) @B{bool}} +@deftypefnx Operator {} {>} {= (@B{l} @B{int} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is greater than +@code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{ge}} {= (@B{l} @B{int} a, b) @B{bool}} +@deftypefnx Operator {} {>=} {= (@B{l} @B{int} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is greater than, or equal +to @code{b}. +@end deftypefn + +@subsection Conversion + +@deftypefn Operator {} {@B{shorten}} {= (@B{short} @B{int} a) @B{short} @B{short} @B{int}} +@deftypefnx Operator {} {@B{shorten}} {= (@B{int} a) @B{short} @B{int}} +@deftypefnx Operator {} {@B{shorten}} {= (@B{long} @B{int} a) @B{int}} +@deftypefnx Operator {} {@B{shorten}} {= (@B{long} @B{long} @B{int} a) @B{long} @B{int}} +Monadic operator that yields, if it exists, the integral value that +can be lengthened to the value of @code{a}. If the value doesn't +exist then the operator yields either the most positive integral value +in the destination mode, if @code{a} is bigger than that value, or the +most negative integral value in the destination mode, if @code{a} is +smaller than that value. +@end deftypefn + +@deftypefn Operator {} {@B{leng}} {= (@B{short} @B{short} @B{int} a) @B{short} @B{int}} +@deftypefnx Operator {} {@B{leng}} {= (@B{short} @B{int} a) @B{int}} +@deftypefnx Operator {} {@B{leng}} {= (@B{int} a) @B{long} @B{int}} +@deftypefnx Operator {} {@B{leng}} {= (@B{long} @B{int} a) @B{long} @B{long} @B{int}} +Monadic operator that yields the integral value lengthened from the +value of @code{a}. +@end deftypefn + +@node Real operators +@section Real operators + +@subsection Arithmetic + +@deftypefn Operator {} {+} {= (@B{l} @B{real} a) @B{l} @B{real}} +Monadic operator that yields the affirmation of its operand. +@end deftypefn + +@deftypefn Operator {} {-} {= (@B{l} @B{real} a) @B{l} @B{real}} +Monadic operator that yields the negative of its operand. +@end deftypefn + +@deftypefn Operator {} {@B{abs}} {= (@B{l} @B{real} a) @B{l} @B{real}} +Monadic operator that yields the absolute value of its operand. +@end deftypefn + +@deftypefn Operator {} {@B{sign}} {= (@B{l} @B{real} a) @B{int}} +Monadic operator that yields -1 if @code{a} if negative, 0 if @code{a} +is zero and 1 if @code{a} is positive. +@end deftypefn + +@deftypefn Operator {} {+} {= (@B{l} @B{real} a, b) @B{l} @B{real}} +Dyadic operator that yields the addition of its operands. +@end deftypefn + +@deftypefn Operator {} {-} {= (@B{l} @B{real} a, b) @B{l} @B{real}} +Dyadic operator that yields @code{b} subtracted from @code{a}. +@end deftypefn + +@deftypefn Operator {} {*} {= (@B{l} @B{real} a, b) @B{l} @B{real}} +Dyadic operator that yields the multiplication of its operands. +@end deftypefn + +@deftypefn Operator {} {/} {= (@B{l} @B{real} a, b) @B{l} @B{real}} +Dyadic operator that yields the realeger division with real result of +@code{a} by @code{b}. +@end deftypefn + +@deftypefn Operator {} {**} {= (@B{l} @B{real} a, b) @B{l} @B{real}} +@deftypefnx Operator {} {^} {= (@B{l} @B{real} a, b) @B{l} @B{real}} +Dyadic operator that yields @code{a} raised to the real exponent @code{b}. +@end deftypefn + +@deftypefn Operator {} {**} {= (@B{l} @B{real} a, @B{int} b) @B{l} @B{real}} +@deftypefnx Operator {} {^} {= (@B{l} @B{real} a, @B{int} b) @B{l} @B{real}} +Dyadic operator that yields @code{a} raised to the integral exponent +@code{b}. +@end deftypefn + +@subsection Arithmetic combined with assignation + +@deftypefn Operator {} {@B{plusab}} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}} +@deftypefnx Operator {} {+:=} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}} +@dfn{Plus and become}. Dyadic operator that calculates @code{a + b}, +assigns the result of the operation to the name @code{a} and then +yields @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{minusab}} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}} +@deftypefnx Operator {} {-:=} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}} +Dyadic operator that calculates @code{a - b}, assigns the result of +the operation to the name @code{a} and then yields @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{timesab}} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}} +@deftypefnx Operator {} {*:=} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}} +Dyadic operator that calculates @code{a * b}, assigns the result of +the operation to the name @code{a} and then yields @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{divab}} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}} +@deftypefnx Operator {} {/:=} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}} +Dyadic operator that calculates @code{a / b}, assigns the result of +the operation to the name @code{a} and then yields @code{a}. +@end deftypefn + +@subsection Relational + +@deftypefn Operator {} {@B{eq}} {= (@B{l} @B{real} a, b) @B{bool}} +@deftypefnx Operator {} {=} {= (@B{l} @B{real} a, b) @B{bool}} +Dyadic operator that yields whether its operands are equal. +@end deftypefn + +@deftypefn Operator {} {@B{ne}} {= (@B{l} @B{real} a, b) @B{bool}} +@deftypefnx Operator {} {/=} {= (@B{l} @B{real} a, b) @B{bool}} +Dyadic operator that yields whether its operands are not equal. +@end deftypefn + +@deftypefn Operator {} {@B{lt}} {= (@B{l} @B{real} a, b) @B{bool}} +@deftypefnx Operator {} {<} {= (@B{l} @B{real} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is less than @code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{le}} {= (@B{l} @B{real} a, b) @B{bool}} +@deftypefnx Operator {} {<=} {= (@B{l} @B{real} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is less than, or equal to +@code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{gt}} {= (@B{l} @B{real} a, b) @B{bool}} +@deftypefnx Operator {} {>} {= (@B{l} @B{real} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is greater than +@code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{ge}} {= (@B{l} @B{real} a, b) @B{bool}} +@deftypefnx Operator {} {>=} {= (@B{l} @B{real} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is greater than, or equal +to @code{b}. +@end deftypefn + +@subsection Conversions + +@deftypefn Operator {} {@B{round}} {= (@B{l} @B{real} a) @B{int}} +Monadic operator that yields the nearest integer to its operand. +@end deftypefn + +@deftypefn Operator {} {@B{entier}} {= (@B{l} @B{real} a) @B{int}} +Monadic operator that yields the integer equal to @code{a}, or the +next integer below (more negative than) @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{shorten}} {= (@B{long} @B{real} a) @B{real}} +@deftypefnx Operator {} {@B{shorten}} {= (@B{long} @B{long} @B{real} a) @B{long} @B{real}} +Monadic operator that yields, if it exists, the real value that +can be lengthened to the value of @code{a}. If the value doesn't +exist then the operator yields either the most positive real value +in the destination mode, if @code{a} is bigger than that value, or the +most negative real value in the destination mode, if @code{a} is +smaller than that value. +@end deftypefn + +@deftypefn Operator {} {@B{leng}} {= (@B{real} a) @B{long} @B{real}} +@deftypefnx Operator {} {@B{leng}} {= (@B{long} @B{real} a) @B{long} @B{long} @B{real}} +Monadic operator that yields the real value lengthened from the +value of @code{a}. +@end deftypefn + +@node Character operators +@section Character operators + +@subsection Relational + +@deftypefn Operator {} {@B{eq}} {= (@B{char} a, b) @B{bool}} +@deftypefnx Operator {} {=} {= (@B{char} a, b) @B{bool}} +Dyadic operator that yields whether its operands are equal. +@end deftypefn + +@deftypefn Operator {} {@B{ne}} {= (@B{char} a, b) @B{bool}} +@deftypefnx Operator {} {/=} {= (@B{char} a, b) @B{bool}} +Dyadic operator that yields whether its operands are not equal. +@end deftypefn + +@deftypefn Operator {} {@B{lt}} {= (@B{char} a, b) @B{bool}} +@deftypefnx Operator {} {<} {= (@B{char} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is less than @code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{le}} {= (@B{char} a, b) @B{bool}} +@deftypefnx Operator {} {<=} {= (@B{char} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is less than, or equal to +@code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{gt}} {= (@B{char} a, b) @B{bool}} +@deftypefnx Operator {} {>} {= (@B{char} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is greater than @code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{ge}} {= (@B{char} a, b) @B{bool}} +@deftypefnx Operator {} {>=} {= (@B{char} a, b) @B{bool}} +Dyadic operator that yields whether @code{a} is greater than, or equal +to @code{b}. +@end deftypefn + +@subsection Conversions + +@deftypefn Operator {} {@B{ABS}} {= (@B{char} a) @B{int}} +Monadic operator that yields an unique integer for each permissable +value of @code{@B{char}}. +@end deftypefn + +@deftypefn Operator {} {@B{REPR}} {= (@B{int} a) @B{char}} +The opposite of @code{@B{abs}} of a character. +@end deftypefn + +@node String operators +@section String operators + +@subsection Relational + +@deftypefn Operator {} {@B{eq}} {= (@B{string} a, b) @B{bool}} +@deftypefnx Operator {} {=} {= (@B{string} a, b) @B{bool}} +Dyadic operator that yields whether its operands are equal. Two +strings are equal if they contain the same sequence of characters. +@end deftypefn + +@deftypefn Operator {} {@B{ne}} {= (@B{string} a, b) @B{bool}} +@deftypefnx Operator {} {/=} {= (@B{string} a, b) @B{bool}} +Dyadic operator that yields whether its operands are not equal. +@end deftypefn + +@deftypefn Operator {} {@B{lt}} {= (@B{string} a, b) @B{bool}} +@deftypefnx Operator {} {<} {= (@B{string} a, b) @B{bool}} +Dyadic operator that yields whether the string @code{a} is less than +the string @code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{le}} {= (@B{string} a, b) @B{bool}} +@deftypefnx Operator {} {<=} {= (@B{string} a, b) @B{bool}} +Dyadic operator that yields whether the string @code{a} is less than, +or equal to string @code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{gt}} {= (@B{string} a, b) @B{bool}} +@deftypefnx Operator {} {>} {= (@B{string} a, b) @B{bool}} +Dyadic operator that yields whether the string @code{a} is greater +than the string @code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{ge}} {= (@B{string} a, b) @B{bool}} +@deftypefnx Operator {} {>=} {= (@B{string} a, b) @B{bool}} +Dyadic operator that yields whether the string @code{a} is greater +than, or equal to the string @code{b}. +@end deftypefn + +@subsection Composition + +@deftypefn Operator {} {+} {= (@B{string} a, b) @B{string}} +Dyadic operator that yields the concatenation of the two given +strings as a new string. +@end deftypefn + +@deftypefn Operator {} {+} {= (@B{string} a, @B{char} b) @B{string}} +Dyadic operator that yields the concatenation of the given string +@code{a} and a string whose contents are the character @code{b}. +@end deftypefn + +@deftypefn Operator {} {*} (= (@B{int} a, @B{string} b) @B{string}) +@deftypefnx Operator {} {*} (= (@B{string} b, @B{int} a) @B{string}) +Dyadic operator that yields the string @code{a} concatenated @code{a} +times to itself. If @code{a} is less than zero then it is interpreted +to be zero. +@end deftypefn + +@subsection Composition combined with assignation + +@deftypefn Operator {} {@B{plusab}} {= (@B{ref} @B{string} a, @B{string} b) @B{ref} @B{string}} +@deftypefnx Operator {} {+:=} {= (@B{ref} @B{string} a, @B{string} b) @B{ref} @B{string}} +@dfn{Plus and become}. Dyadic operator that calculates @code{a + b}, +assigns the result of the operation to the name @code{a} and then +yields @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{plusto}} {= (@B{string} b, @B{ref} @B{string} a) @B{ref} @B{string}} +@deftypefnx Operator {} {+=:} {= (@B{string} b, @B{ref} @B{string} b) @B{ref} @B{string}} +Dyadic operator that calculates @code{a + b}, assigns the result of +the operation to the name @code{a} and then yields @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{timesab}} {= (@B{ref} @B{string} a, @B{string} b) @B{ref} @B{string}} +@deftypefnx Operator {} {*:=} {= (@B{ref} @B{string} a, @B{string} b) @B{ref} @B{stringl}} +@dfn{Plus and become}. Dyadic operator that calculates @code{a * b}, +assigns the result of the operation to the name @code{a} and then +yields @code{a}. +@end deftypefn + +@node Complex operators +@section Complex operators + +@node Bits operators +@section Bits operators + +@subsection Logical + +@deftypefn Operator {} {@B{NOT}} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}} +@deftypefnx Operator {} {~} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}} +Monadic operator that yields the element-wise not logical operation in +the elements of the given bits operand. +@end deftypefn + +@deftypefn Operator {} {@B{AND}} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}} +@deftypefnx Operator {} {&} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}} +Dyadic operator that yields the element-wise and logical operation in +the elements of the given bits operands. +@end deftypefn + +@deftypefn Operator {} {@B{OR}} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}} +Dyadic operator that yields the element-wise ``or'' logical operation +in the elements of the given bits operands. +@end deftypefn + +@subsection Shifting + +@deftypefn Operator {} {@B{SHL}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}} +@deftypefnx Operator {} {@B{UP}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}} +Dyadic operator that yields the given bits operand shifted @code{n} +positions to the left. Extra elements introduced on the right are +initialized to @code{@B{false}}. +@end deftypefn + +@deftypefn Operator {} {@B{SHR}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}} +@deftypefnx Operator {} {@B{DOWN}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}} +Dyadic operator that yields the given bits operand shifted @code{n} +positions to the right. Extra elements introduced on the left are +initialized to @code{@B{false}}. +@end deftypefn + +@subsection Relational + +@deftypefn Operator {} {@B{eq}} {= (@B{l} @B{bits} a, b) @B{bool}} +@deftypefnx Operator {} {=} {= (@B{l} @B{bits} a, b) @B{bool}} +Dyadic operator that yields whether its operands are equal. Two +bits are equal if they contain the same sequence of booleans. +@end deftypefn + +@deftypefn Operator {} {@B{ne}} {= (@B{l} @B{bits} a, b) @B{bool}} +@deftypefnx Operator {} {/=} {= (@B{l} @B{bits} a, b) @B{bool}} +Dyadic operator that yields whether its operands are not equal. +@end deftypefn + +@deftypefn Operator {} {@B{lt}} {= (@B{l} @B{bits} a, b) @B{bool}} +@deftypefnx Operator {} {<} {= (@B{l} @B{bits} a, b) @B{bool}} +Dyadic operator that yields whether the bits @code{a} is less than +the bits @code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{le}} {= (@B{l} @B{bits} a, b) @B{bool}} +@deftypefnx Operator {} {<=} {= (@B{l} @B{bits} a, b) @B{bool}} +Dyadic operator that yields whether the bits @code{a} is less than, +or equal to bits @code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{gt}} {= (@B{l} @B{bits} a, b) @B{bool}} +@deftypefnx Operator {} {>} {= (@B{l} @B{bits} a, b) @B{bool}} +Dyadic operator that yields whether the bits @code{a} is greater than +the bits @code{b}. +@end deftypefn + +@deftypefn Operator {} {@B{ge}} {= (@B{l} @B{bits} a, b) @B{bool}} +@deftypefnx Operator {} {>=} {= (@B{l} @B{bits} a, b) @B{bool}} +Dyadic operator that yields whether the bits @code{a} is greater +than, or equal to the bits @code{b}. +@end deftypefn + +@subsection Conversions + +@deftypefn Operator {} {@B{abs}} {= (@B{l} @B{bits} a) @B{l} @B{int}} +Monadic operator that yields the integral value whose constituent bits +correspond to the booleans stored in @code{a}. @xref{@code{@B{bin}} +and @code{@B{abs}} of negative integral values}. +@end deftypefn + +@deftypefn Operator {} {@B{bin}} {= (@B{l} @B{int} a) @B{l} @B{bits}} +Monadic operator that yields the bits value whose boolean elements map +the bits in the given integral operand. @xref{@code{@B{bin}} and +@code{@B{abs}} of negative integral values}. +@end deftypefn + +@deftypefn Operator {} {@B{shorten}} {= (@B{long} @B{bits} a) @B{bits}} +@deftypefnx Operator {} {@B{shorten}} {= (@B{long} @B{long} @B{bits} a) @B{long} @B{bits}} +Monadic operator that yields the bits value that can be lengthened to +the value of @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{leng}} {= (@B{bits} a) @B{long} @B{bits}} +@deftypefnx Operator {} {@B{leng}} {= (@B{long} @B{bits} a) @B{long} @B{long} @B{bits}} +Monadic operator that yields the bits value lengthened from the value +of @code{a}. The lengthened value features @code{@B{false}} in the +extra left positions added to match the lengthened size. +@end deftypefn + +@node Bytes operators +@section Bytes operators + +@node Semaphore operators +@section Semaphore operators + +@node Math procedures +@section Math procedures + +@subsection Arithmetic + +@deftypefn Procedure {} {@B{sqrt}} {= (@B{l} @B{real} a) @B{l} @B{real}} +Procedure that yields the square root of the given real argument. +@end deftypefn + +@subsection Logarithms + +@deftypefn Procedure {} {@B{ln}} {= (@B{l} @B{real} a) @B{l} @B{real}} +Procedure that yields the base @code{e} logarithm of the given real +argument. +@end deftypefn + +@deftypefn Procedure {} {@B{exp}} {= (@B{l} @B{real} a) @B{l} @B{real}} +Procedure that yields the exponential function of the given real +argument. This is the inverse of @code{@B{ln}}. +@end deftypefn + +@subsection Trigonometric + +@deftypefn Procedure {} {@B{sin}} {= (@B{l} @B{real} a) @B{l} @B{real}} +Procedure that yields the sin trigonometric function of the given real +argument. +@end deftypefn + +@deftypefn Procedure {} {@B{arcsin}} {= (@B{l} @B{real} a) @B{l} @B{real}} +Procedure that yields the arc-sin trigonometric function of the given real +argument. +@end deftypefn + +@deftypefn Procedure {} {@B{cos}} {= (@B{l} @B{real} a) @B{l} @B{real}} +Procedure that yields the cos trigonometric function of the given real +argument. +@end deftypefn + +@deftypefn Procedure {} {@B{arccos}} {= (@B{l} @B{real} a) @B{l} @B{real}} +Procedure that yields the arc-cos trigonometric function of the given real +argument. +@end deftypefn + +@deftypefn Procedure {} {@B{tan}} {= (@B{l} @B{real} a) @B{l} @B{real}} +Procedure that yields the tan trigonometric function of the given real +argument. +@end deftypefn + +@deftypefn Procedure {} {@B{arctan}} {= (@B{l} @B{real} a) @B{l} @B{real}} +Procedure that yields the arc-tan trigonometric function of the given +real argument. +@end deftypefn + +@node Extended prelude +@chapter Extended prelude +@cindex prelude, extended + +This chapter documents the GNU extensions to the standard prelude. +The facilities documented below are available to Algol 68 programs +only if the @option{gnu68} language dialect is selected, which is the +default. + +The extended prelude is available to Algol 68 programs without needing +to import any module, provided they are compiled as @code{gnu68} code, +which is the default. + +@menu +* Extended priorities:: Priorities of extended operators. +* Extended environment enquiries:: Information about the implementation. +* Extended rows operators:: Rows and associated operations. +* Extended boolean operators:: Operations on boolean operands. +* Extended bits operators:: Bits and associated operations. +* Extended math procedures:: Mathematical constants and functions. +@end menu + +@node Extended priorities +@section Extended priorities + +@table @code +@item 3 +@itemize @bullet +@item @code{@B{xor}} +@end itemize + +@item 8 +@itemize @bullet +@item @code{@B{elems}} +@end itemize +@end table + +@node Extended environment enquiries +@section Extended environment enquiries + +An @dfn{environment enquiry} is a constant, whose value may be useful +to the programmer, that reflects some characteristic of the particular +implementation. The values of these enquiries are also determined by +the architecture and operating system targeted by the compiler. + +@deftypevr Constant {@B{l} @B{int}} {L min int} +The most negative integral value. +@end deftypevr + +@deftypevr Constant {@B{l} @B{real}} {L min real} +The most negative real value. +@end deftypevr + +@deftypevr Constant {@B{l} @B{real}} {L infinity} +Positive infinity expressed in a real value. +@end deftypevr + +@deftypevr Constant {@B{l} @B{real}} {L minus infinity} +Negative infinity expressed in a real value. +@end deftypevr + +@deftypevr Constant @B{char} {replacement char} +A character that is unknown, unrecognizable or unrepresentable in +Unicode. +@end deftypevr + +@deftypevr Constant @B{char} {eof char} +@B{char} value that doesn't denote an actual char, but an end-of-file +situation. +@end deftypevr + +@node Extended rows operators +@section Extended rows operators + +The following operators work on any row mode, denoted below using the +pseudo-mode @code{@B{rows}}. + +@deftypefn Operator {} {@B{elems}} {= (@B{rows} a) @B{int}} +Monadic operator that yields the number of elements implied by the +first bound pair of the descriptor of the value of @code{a}. +@end deftypefn + +@deftypefn Operator {} {@B{elems}} {= (@B{int} n, @B{rows} a) @B{int}} +Dyadic operator that yields the number of elements implied by the n-th +bound pair of the descriptor of the value of @code{a}. +@end deftypefn + +@node Extended boolean operators +@section Extended boolean operators + +@deftypefn Operator {} {@B{xor}} {= (@B{bool} a, b) @B{bool}} +Dyadic operator that yields the exclusive-or operation of the given +boolean arguments. +@end deftypefn + +@node Extended bits operators +@section Extended bits operators + +@deftypefn Operator {} {@B{xor}} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}} +Dyadic operator that yields the bit exclusive-or operation of the +given bits arguments. +@end deftypefn + +@node Extended math procedures +@section Extended math procedures + +@subsection Logarithms + +@deftypefn Procedure {} {@B{log}} {= (@B{l} @B{real} a, b) @B{l} @B{real}} +Procedure that calculates the base ten logarithm of the given arguments. +@end deftypefn + +@node POSIX prelude +@chapter POSIX prelude + +The POSIX prelude provides facilities to perform simple transput (I/O) +based on POSIX file descriptors, accessing the file system, +command-line arguments, environment variables, etc. + +This prelude is available to Algol 68 programs without needing to +import any module, provided they are compiled as @code{gnu68} code, +which is the default. + +@menu +* POSIX process:: Process exit status. +* POSIX command line:: Parsing command-line arguments. +* POSIX environment:: Environment variables. +* POSIX errors:: Error handling and error descriptions. +* POSIX files:: Creating, opening and closing files. +* POSIX sockets:: Communication endpoints. +* POSIX string transput:: Reading and writing characters and strings. +@end menu + +@node POSIX process +@section POSIX process + +The Algol 68 program can report an exit status to the operating system +once they stop running. The exit status reported by default is zero, +which corresponds to success. + +@deftypefn Procedure {} {set exit status} {= (@B{int} status)} +Procedure that sets the exit status to report to the operating system +once the program stop executing. The default exit status is 0 which, +by convention, is interpreted by POSIX systems as success. A value +different to zero is interpreted as an error status. This procedure +can be invoked more than one, the previous exit status being +overwritten. +@end deftypefn + +@node POSIX command line +@section POSIX command line + +Algol 68 programs can access the command-line arguments passed to them +by using the following procedures. + +@deftypefn Procedure {} {argc} {= @B{int}} +Procedure that yields the number of arguments passed in the command +line, including the name of the program. +@end deftypefn + +@deftypefn Procedure {} {argv} {= (@B{int} n) @B{string}} +Procedure that yields the @code{n}th argument passed in the command +line. The first argument is always the name used to invoke the +program. If @code{n} is out of range then this procedure returns the +empty string. +@end deftypefn + +@node POSIX environment +@section POSIX environment + +@deftypefn Procedure {} {getenv} {= (@B{string} varname) @B{string}} +Procedure that yields the value of the environment variable +@code{varname} as a string. If the specified environmental variable +is not defined the this procedure returns an empty string. +@end deftypefn + +@node POSIX errors +@section POSIX errors + +When a call to a procedure in this prelude results in an error, the +called procedure signals the error in some particular way and also +sets a global @code{errno} to a code describing the error. For +example, trying to opening a file that doesn't exist will result in +@code{fopen} returning -1, which signals an error. The caller can +then inspect the global @code{errno} to see what particular error +prevented the operation to be completed: in this case, @code{errno} +will contain the error code corresponding to ``file doesn't exist''. + +@deftypefn Procedure {} {errno} {= @B{int}} +This procedure yields the current value of the global @code{errno}. +The yielded value reflects the error status of the last executed POSIX +prelude operation. +@end deftypefn + +@deftypefn Procedure {} {strerror} {= (@B{int} ecode) @B{string}} +This procedure gets an error code and yields a string containing an +explanatory short description of the error. It is typical to pass the +output of @code{errno} to this procedure. +@end deftypefn + +@deftypefn Procedure {} {perror} {= (@B{string} msg) @B{void}} +This procedure prints the given string @code{msg} in the standard +error output, followed by a colon character, a space character and +finally the string error of the current value of @code{errno}. +@end deftypefn + +@node POSIX files +@section POSIX files + +File descriptors are @code{@B{int}} values that identify open files +that can be accessed by the program. The @code{fopen} procedure +allocates file descriptors as it opens files, and the descriptor is +used in subsequent transput calls to perform operations on the files. + +@subsection Standard file descriptors + +There are three descriptors, however, which are automatically opened +when the program starts executing and automatically closed when the +program finishes. These are: + +@deftypevr Constant {@B{int}} {stdin} +File descriptor associated with the standard input. Its value is @code{0}. +@end deftypevr + +@deftypevr Constant {@B{int}} {stdout} +File descriptor associated with the standard output. Its value is @code{1}. +@end deftypevr + +@deftypevr Constant {@B{int}} {stderr} +File descriptor associated with the standard error. Its value is @code{2}. +@end deftypevr + +@subsection Opening and closing files + +@deftypefn Procedure {} {fopen} {= (@B{string} pathname, @B{bits} flags) @B{int}} +Open the file specified by @code{pathname}. The argument @code{flags} +is a combination of @code{file o} flags as defined below. If the +specified file is successfully opened while satisfying the constraints +implied by @code{flags} then this procedure yields a file descriptor +that is used in subsequent I/O calls to refer to the open +file. Otherwise, this procedure yields -1. The particular error can +be inspected by calling the @code{errno} procedure. +@end deftypefn + +@deftypefn Procedure {} {fclose} {= (@B{int} fd) @B{int}} +Close the given file descriptor, which no longer refers to any file. +This procedure yields zero on success, and -1 on error. In the later +case, the program can look at the particular error by calling the +@code{errno} procedure. +@end deftypefn + +@subsection Creating files + +@deftypefn Procedure {} {fcreate} {= (@B{string} pathname, @B{bits} mode) @B{int}} +Create a file with name @code{pathname}. The argument @code{mode} is +a @code{@B{bits}} value containing a bit pattern that determines the +permissions on the created file. The bit pattern has the form +@code{8rUGO}, where @code{U} reflects the permissions of the user who +owns the file, @code{U} reflects the permissions of the users +pertaining to the file's group, and @code{O} reflects the permissions +of all other users. The permission bits are 1 for execute, 2 for +write and 4 for read. If the file is successfully created then this +procedure yields a file descriptor that is used in subsequent I/O +calls to refer to the newly created file. Otherwise, this procedure +yields -1. The particular error can be inspected by calling the +@code{errno} procedure. +@end deftypefn + +@subsection Flags for @code{fopen} + +The following flags can be combined using bit-wise operators. Note +that in POSIX systems the effective mode of the created file is the +mode specified by the programmer masked with the process's +@dfn{umask}. + +@deftypevr Constant {@B{bits}} {file o default} +Flag for @code{fopen} indicating that the file shall be opened with +whatever capabilities allowed by its permissions. +@end deftypevr + +@deftypevr Constant {@B{bits}} {file o rdwr} +Flag for @code{fopen} indicating that the file shall be opened for +both reading and writing. +@end deftypevr + +@deftypevr Constant {@B{bits}} {file o rdonly} +Flag for @code{fopen} indicating that the file shall be opened for +reading only. This flag is not compatible with @code{file o rdwr} nor +with @code{file o wronly}. +@end deftypevr + +@deftypevr Constant {@B{bits}} {file o wronly} +Flag for @code{fopen} indicating that the file shall be opened for +write only. This flag is not compatible with @code{file o rdwr} nor +with @code{file o rdonly}. +@end deftypevr + +@deftypevr Constant {@B{bits}} {file o trunc} +Flag for @code{fopen} indicating that the opened file shall be +truncated upon opening it. The file must allow writing for this flag +to take effect. The effect of combining @code{file o trunc} and +@code{file o rdonly} is undefined and varies among implementations. +@end deftypevr + +@subsection Getting file properties + +@deftypefn Procedure {} {fsize} {= (@B{int} fd) @B{long} @B{long} @B{int}} +Return the size in bytes of the file characterized by the file +descriptor @code{fd}. If the system entity characterized by the given +file descriptor doesn't have a size, if the size of the file cannot be +stored in a @code{@B{long} @B{long} @B{int}}, or if there is any other +error condition, this procedure yields -1 and @code{errno} is set +appropriately. +@end deftypefn + +@deftypefn Procedure {} {lseek} {= (@B{int} fd, @B{long int} offset, @B{int} whence) @B{long long int}} +Set the file offset of the file characterized by the file descriptor @code{fd} +depending on the values of @code{offset} and @code{whence}. On success, the +resulting offset, as measured in bytes from the beginning of the file, is +returned. Otherwise, -1 is returned, @code{errno} is set to indicate the error, +and the file offset remains unchanged. The effects of @code{offset} and +@code{whence} are: +@itemize +@item +If @code{whence} is @code{seek set}, the file offset is set to @code{offset} +bytes. +@item +If @code{whence} is @code{seek cur}, the file offset is set to its current +location plus @code{offset}. +@item +If @code{whence} is @code{seek end}, the file offset is set to the size of the +file plus @code{offset}. +@end itemize +@end deftypefn + +@node POSIX sockets +@section POSIX sockets + +A program can communicate with other computers, or with other +processes running in the same computer, via sockets. The sockets are +identified by file descriptors. + +@deftypefn Procedure {} {fconnect} {= (@B{string} host, @B{int} port) @B{int}} +This procedure creates a stream socket and connects it to the given +@code{host} using port @code{port}. The established communication is +full-duplex, and allows sending and receiving data using transput +until it gets closed. On success this procedure yields a file +descriptor. On error this procedure yields -1 and @code{errno} is set +appropriately. +@end deftypefn + +@node POSIX string transput +@section POSIX string transput + +The following procedures read or write characters and strings from and +to open files. The external encoding of the files is assumed to be +UTF-8. Since Algol 68 @code{@B{char}}s are UCS-4, this means that +reading or writing a character may involve reading or writing more +than one byte, depending on the particular Unicode code points +involved. + +@subsection Output of strings and chars + +@deftypefn Procedure {} {putchar} {= (@B{char} c) @B{char}} +Write the given character to the standard output. This procedure +yields @code{c} in case the character got successfully written, or +@code{eof char} otherwise. +@end deftypefn + +@deftypefn Procedure {} {puts} {= (@B{string} str) @B{void}} +Write the given string to the standard output. +@end deftypefn + +@deftypefn Procedure {} {fputc} {= (@B{int} fd, @B{char} c) @B{int}} +Write given character @code{c} to the file with descriptor @code{fd}. +This procedure yields @code{c} on success, or @code{eof char} on +error. +@end deftypefn + +@deftypefn Procedure {} {fputs} {= (@B{int} fd, @B{string} str) @B{int}} +Write the given string @code{str} to the file with descriptor +@code{fd}. This procedure yields the number of bytes written on +success, or 0 on error. +@end deftypefn + +@subsection Input of strings and chars + +@deftypefn Procedure {} {getchar} {= @B{char}} +Read a character from the standard input. This procedure yields the +read character in case the character got successfully read, or +@code{eof char} otherwise. +@end deftypefn + +@deftypefn Procedure {} {gets} {= (@B{int} n) @B{ref} @B{string}} +Read a string composed of @code{n} characters from the standard input +and yield a reference to it. If @code{n} is bigger than zero then +characters get read until either @code{n} characters have been read or +the end of line is reached. If @code{n} is zero or negative then +characters get read until either a new line character is read or the +end of line is reached. +@end deftypefn + +@deftypefn Procedure {} {fgetc} {= (@B{int} fd) @B{int}} +Read a character from the file with descriptor @code{fd}. This +procedure yields the read character in case a valid Unicode character +got successfully read. If an unrecognizable or unknown character is +found then this procedure yields @code{replacement char}. In case of +end of file this procedure yields @code{eof char}. +@end deftypefn + +@deftypefn Procedure {} {fgets} {= (@B{int} fd, @B{int} n) @B{ref} @B{string}} +Read a string from the file with descriptor @code{fd} and yield a +reference to it. If @code{n} is bigger than zero then characters get +read until either @code{n} characters have been read or the end of +line is reached. If @code{n} is zero or negative then characters get +read until either a new line character is read or the end of line is +reached. +@end deftypefn + +@node Language extensions +@chapter Language extensions + +This chapter documents the GNU extensions implemented by this compiler +on top of the Algol 68 programming language. These extensions +collectively conform a strict @dfn{superlanguage} of Algol 68, and are +enabled by default. To disable them the user can select the strict +Algol 68 standard by passing the option @option{-std=algol68} when +invoking the compiler. + +@menu +* @code{@B{bin}} and @code{@B{abs}} of negative integral values:: +* Bold taggles:: Using underscores in mode and operator indications. +@end menu + +@node @code{@B{bin}} and @code{@B{abs}} of negative integral values +@section @code{@B{bin}} and @code{@B{abs}} of negative integral values + +The @code{@B{bin}} operator gets an integral value and yields a +@code{@B{bits}} value that reflects the internal bits of the integral +value. The semantics of this operator, as defined in the Algol 68 +standard prelude, are: + +@example +@B{op} @B{bin} = (L @B{int} a) L @B{bits}: + @B{if} a >= L 0 + @B{then} L @B{int} b := a; L @B{bits}; + @B{for} i @B{from} L bits width @B{by} -1 @B{to} 1 + @B{do} (L F @B{of} c)[i] := @B{odd} b; b := b % L 2 @B{od}; + c + @B{fi}; +@end example + +The @code{@B{abs}} operator performs the inverse operation of +@code{@B{bits}}. Given a @code{L @B{bits}} value, it yields the +@code{L @B{int}} value whose bits representation is the bits value. +The semantics of this operator, as defined in the Algol 68 prelude, +are: + +@example +@B{op} @B{abs} = (L @B{bits} a) L @B{int}: +@B{begin} L @B{int} c := L 0; + @B{for} i @B{to} L bits width + @B{do} c := L 2 * c + K @B{abs} (L F @B{of} a)[i] @B{od}; + c +@B{end} +@end example + +@noindent +Note how the @code{@B{bin}} of a negative integral value is not +defined: the implicit else-part of the conditional yields +@code{@B{skip}}, which is defined as any bits value in that context. +Note also how @code{@B{abs}} doesn't make any provision to check +whether the resulting value is positive: it assumes it is so. + +The GNU Algol 68 compiler, when working in strict Algol 68 mode +(@option{-std=algol68}), makes @code{@B{bin}} to always yield @code{L +@B{bits} (@B{skip})} when given a negative value, as mandated by the +report. But the skip value is always the bits representation of zero, +@i{i.e.} 2r0. Strict Algol 68 programs, however, must not rely on +this. + +When GNU extensions are enabled (@option{-std=gnu68}) the +@code{@B{bin}} of a negative value yields the two's complement bit +pattern of the value rather than zero. Therefore, @code{@B{bin} - +@B{short} @B{short} 2} yields @code{2r11111110}. And @code{@B{abs} +@B{short} @B{short} 2r11111110} yields -2. + +@node Bold taggles +@section Bold taggles + +This compiler supports the stropping regimes known as UPPER and +SUPPER. In both regimes bold words are written by writing their +constituent bold letters and digits, in order. In UPPER regime all +the letters of a bold word are to be written using upper-case. In +SUPPER regime, only the first bold letter is required to be written +using upper-case, and this only when the bold word is not a reserved +word. + +When a bold word comprises several natural words, it may be a little +difficult to distinguish them at first sight. Consider for example +the following code, written fist in UPPER stropping: + +@example +MODE TREENODE = STRUCT (TREENODEPAYLOAD data, REF TREENODE next), + TREENODEPAYLOAD = STRUCT (INT code, REAL average, mean); +@end example + +@noindent +Then written in SUPPER stropping: + +@example +mode TreeNode = struct (TreeNodePayload data, REF TreeNode next), + TreeNodePayload = struct (int code, real average, mean); +@end example + +Particularly in UPPER stropping, it may be difficult to distinguish +the constituent natural words at first sight. + +In order to improve this, this compiler implements a GNU extension +called @dfn{bold taggles} that allows to use underscore characters +(@code{_}) within mode and operator indications as a visual aid to +improve readability. When this extension is enabled, mode indications +and operator indications consist in a sequence of the so-called +@dfn{bold taggles}, which are themselves sequences of one or more bold +letters or digits optionally terminated by an underscore character. + +With bold taggles enabled the program above could have been written +using UPPER stropping as: + +@example +MODE TREE_NODE = STRUCT (TREE_NODE_PAYLOAD data, REF TREE_NODE next), + TREE_NODE_PAYLOAD = STRUCT (INT code, REAL average, mean); +@end example + +@noindent +And using SUPPER stropping as: + +@example +mode Tree_Node = struct (Tree_Node_Payload data, ref Tree_Node next), + Tree_Node_Payload = struct (int code, real average, mean); +@end example + +@noindent +Which is perhaps more readable for most people. Note that the +underscore characters are not really part of the mode or operator +indication. Both @code{TREE_NODE} and @code{TREENODE} denote the same +mode indication. Note also that, following the definition, constructs +like @code{Foo__bar} and @code{_Baz} are not valid indications. + +Bold taggles are available when the gnu68 dialect of the language is +selected. @xref{Dialect options}. + +@include gpl_v3.texi +@include fdl.texi + +@node Option Index +@unnumbered Option Index + +@command{ga68}'s command line options are indexed here without any initial +@samp{-} or @samp{--}. Where an option has both positive and negative forms +(such as @option{-f@var{option}} and @option{-fno-@var{option}}), relevant +entries in the manual are indexed under the most appropriate form; it may +sometimes be useful to look up both forms. + +@printindex op + +@node General Index +@unnumbered Index + +@printindex cp + +@bye diff --git a/gcc/algol68/ga68.vw b/gcc/algol68/ga68.vw new file mode 100644 index 000000000000..54511c927fbe --- /dev/null +++ b/gcc/algol68/ga68.vw @@ -0,0 +1,1845 @@ +{ ga68.vw - The GNU Algol 68 strict language -*- vw -*- + + Copyright (C) 2025 Jose E. Marchesi + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. } + +{ This file contains an annotated description of the syntax of the GNU + Algol 68 strict language. GNU Algol 68 aims to be a super-language + of Algol 68. + + Extension to the strict Revised Report incorporated into GNU Algol + 68 are: + + [US] This is the GNU68-2025-001-unsafe GNU extension. It adds an + unsafe clause that marks a controlled clause as containing + unsafe constructs which are known by the programmer, and makes + the compiler to avoid certain diagnostics. See the GNU Algol + 68 Compiler manual for more information. + + [SC] This is the GNU68-2025-003-andth-orel GNU extension. It adds + two units that act as pseudo-operators providing logical AND + and OR functions with short-circuited elaboration. See the GNU + Algol 68 Compiler manual for more information. + + [MR] A modules and separated compilation system based on the modules + system recomended by IFIP Working Group 2.1 Standing + Subcommittee on Algol 68 Support, described in: + + A Modules and Separate Compilation Facility for Algol 68 by + Lindsey and Boom. + + [NC] This is the GNU68-2025-005-nestable-comments GNU extension. It + adds support for nestable block comments. + + The metaproduction rules, hyper-rules and hyper-alternatives + introduced by each extension are clearly marked in the sections + below. You can easily search for them using the extensions tags in + the list above. For example, to look for the extensions introduced + by the modules and separated compilation system, search for [MR]. + + The few deviations to the RR Algol 68 are clearly marked as well in + this specification. + + A complete description of the semantics of the Algol 68 subset of + the described language and the extensions is not included in this + file. The reader is referred to the Revised Report and other + documentation corresponding to the extensions, like the GNU Algol 68 + compiler manual. + + The sectioning and the enumeration of metaproduction rules and of + hyper-rules, including cross-references, are the same than in the + Report. The annotations and pragmatics added between curly brackets + explain the meaning of the rules and how they describe the syntax of + the language. Note that thanks to the expressive power of VW + grammars the syntax expressed by this description covers much more + than what is usually expressed by context-free grammars in the + descriptions of other languages that typically use some variant of + the BNF notation. + + Sample code in examples and pragmatics is expressed using the UPPER + stropping regime. + + This file is better browsed using the Emacs vw-mode, which provides + automatic indentation, font-lock, and other facilities like the + hiding of annotations an the following of cross-references. See the + vw-mode manual for more information, including a primer on VW + grammars and the formal description used in both the original Report + and this file. } + +1 Language and metalanguage + +1.2 General metaproduction rules + +1.2.1 Metaproduction rules of modes + +A) MODE :: PLAIN ; STOWED ; REF to MODE ; PROCEDURE ; + UNITED ; MU definition of MODE ; MU application. +B) PLAIN :: INTREAL ; boolean ; character. +C) INTREAL :: SIZETY integral ; SIZETY real. +D) SIZETY :: long LONGSETY ; short SHORTSETY ; EMPTY. +E) LONGSETY :: long LONGSETY ; EMPTY. +F) SHORTSETY :: short SHORTSETY ; EMPTY. +G) EMPTY :: . +H) STOWED :: structured with FIELDS mode ; + FLEXETY ROWS of MODE. +I) FIELDS :: FIELD ; FIELDS FIELD. +J) FIELD :: MODE field TAG{942A}. +K) FLEXETY :: flexible ; EMPTY. +L) ROWS :: row ; ROWS row. +M) REF :: reference ; transient reference. +N) PROCEDURE :: procedure PARAMETY yielding MOID. +O) PARAMETY :: with PARAMETERS ; EMPTY. +P) PARAMETERS :: PARAMETER ; PARAMETERS PARAMETER. +Q) PARAMETER :: MODE parameter. +R) MOID :: MODE ; void. +S) UNITED :: union of MOODS mode. +T) MOODS :: MOOD ; MOODS MOOD. +U) MOOD :: PLAIN ; STOWED ; reference to MODE ; PROCEDURE ; void. +V) MU :: muTALLY. +W) TALLY :: i ; TALLY i. + +1.2.2 Metaproduction rules associated with phrases and coercion + +{ Extensions: + [MR] access + [US] unsafe } + +A) ENCLOSED :: closed ; collateral ; parallel ; CHOICE{34A} ; + loop ; access ; unsafe. +B) SOME :: SORT MOID NEST. +C) SORT :: strong ; firm ; meek ; weak ; soft. + +{ Modules are activated by means of access-clauses. } + +1.2.3 Metaproduction rules associated with nests + +{ Extensions: + [MR] MODSETY, MOD, MODS, REVSETY, REVS, REV, + TAU, INKSETY, INKS, INK } + +A) NEST :: LAYER ; NEST LAYER. +B) LAYER :: new DECSETY LABSETY INKSETY. +C) DECSETY :: DECS ; EMPTY. +D) DECS :: DEC ; DECS DEC. +E) DEC :: MODE TAG{942A} ; priority PRIO TAD{942F} ; + MOID TALLY TAB{942D} ; DUO TAD{942F} MONO TAM{492K} ; + MOD. +F) PRIO :: i ; ii ; iii ; + iii i ; iii ii ; iii iii ; + iii iii i ; iii iii ii ; iii iii iii. +G) MONO :: procedure with PARAMETER yielding MOID. +H) DUO :: procedure with PARAMETER1 PARAMETER2 yielding MOID. +I) LABSETY :: LABS ; EMPTY. +J) LABS :: LAB ; LABS LAB. +K) LAB :: label TAG{942A}. +L) MODSETY :: MODS ; EMPTY. +M) MODS :: MOD ; MODS MOD. +N) MOD :: module REVS TAB. +O) REVSETY :: REVS ; EMPTY. +P) REVS :: REV ; REVS REV. +Q) REV :: TAU reveals DECSETY INKS. +R) TAU :: MU. +S) INKSETY :: INKS ; EMPTY. +T) INKS :: INK ; INKS INK. +U) INK :: invoked TAU. + +{ The primal environment is just 'new'. } + +1.3 General hyper-rules + +1.3.1 Syntax of general predicates + +A) NOTION :: ALPHA ; NOTION ALPHA. +B) ALPHA :: a ; b ; c ; d ; e ; f ; g ; h ; i ; j; + k ; l ; m ; n ; o ; p ; q ; r ; s ; t; + u ; v ; w ; x ; y ; z. +C) NOTETY :: NOTION ; EMPTY. +D) THING :: NOTION ; + (NOTETY1) NOTETY2 ; + THING (NOTETY1) NOTETY2. +E) WHETHER :: where ; unless. + +a) where true : EMPTY. +b) unless false : EMPTY. +c) where THING1 and THING2 : where THING1, where THING2. +d) where THING1 or THING2 : where THING1 ; where THING2. +e) unless THING1 and THING2 : unless THING1; unless THING2. +f) unless THING1 or THING2 : unless THING1, unless THING2. +g) WHETHER (NOTETY1) is (NOTETY2) : + WHETHER (NOTETY1) begins with (NOTETY2){h,i,j} + and (NOTETY2) begins with (NOTETY1){h,i,j}. +h) WHETHER (EMPTY) begins with (NOTION){g,j} : + WHETHER false{b,-}. +i) WHETHER (NOTETY1) begins with (EMPTY){g,j} : + WHETHER true{a,-}. +j) WHETHER (ALPHA1 NOTETY1) begins with + (ALPHA2 NOTETY2){g,j,m} : + WHETHER (ALPHA1) coincides with (ALPHA2) in + (abcdefghijklmnopqrstuvwxyz){k,l,-} + and (NOTETY1) begins with (NOTETY2){h,i,j}. +k) where (ALPHA) coincides with (ALPHA) in (NOTION){j} : + where true{a}. +l) unless (ALPHA1) coincides with (ALPHA2) in (NOTION){j} : + where (NOTION) contains (ALPHA1 NOTETY ALPHA2){m} + or (NOTION) contains (ALPHA2 NOTETY ALPHA1){m}. +m) WHETHER (ALPHA NOTETY) contains (NOTION){l,m} : + WHETHER (ALPHA NOTETY) begins with (NOTION){j} + or (NOTETY) contains (NOTION){m,n}. +n) WHETHER (EMPTY) contains (NOTION){m} : WHETHER false{b,-}. + +1.3.3 Syntax of general constructions + +A) STYLE :: brief ; bold ; style TALLY. + +a) NOTION option : NOTION ; EMPTY. +b) NOTION sequence{b} : NOTION ; NOTION, NOTION sequence{b}. +c) NOTION list{c} : + NOTION ; NOTION, and also{94f} token, NOTION list{c}. +d) NOTETY STYLE pack : + STYLE begin{94f,-} token, NOTETY, STYLE end{94f,-} token. +e) NOTION STYLE bracket : + STYLE sub{94f,-} token, NOTION, STYLE bus{94f,-} token. +f) THING1 or alternatively THING2 : THING1 ; THING2. + +2 The computer and the program + +2.2 The program + +2.2.1 Syntax + +a) program : program token, strong integral new closed clause{31a}. + +{ The value yielded by the elaboration of the program is the exit + status returned by the process to the operating system upon + termination. This is a slight deviation from the Report, which + instead specifies: + + a) program : strong void new closed clause. + + and mandates that the production tree of a particular program should + be akin to the production of the program in the strict language. } + +3 Clauses + +3.0.1 Syntax + +{ Extensions: + [MR] "NEST module text publishing REVS defining LAYER", + "NEST LAYER1 LAYER2 module series with DECSETY + without DECSETY", + "SOID NEST access clause" } + +a) *phrase : SOME unit{32d} ; NEST declaration of DECS{41a}. +b) *SORT MODE expression : SORT MODE NEST UNIT{5A}. +c) *statement : strong void NEST UNIT{5A}. +d) *MOID constant : MOID NEST DEFIED identifier with TAG{48a,b} ; + MOID NEST denoter{80a}. +e) *MODE variable : + reference to MODE NEST DEFIED identifier with TAG{48a,b}. +f) *NEST range : + SOID NEST serial clause defining LAYER{32a} ; + SOID NEST chooser CHOICE STYLE clause{34b} ; + SOID NEST case part of choice using UNITED{34i} ; + NEST STYLE repeating part with DEC{35e} ; + NEST STYLE while do part{35f} ; + PROCEDURE NEST routine text{541a,b} ; + NEST module text publishing REVS defining LAYER{49c,-} ; + NEST LAYER1 LAYER2 module series + with DECSETY without DECSETY1{49d} ; + SOID NEST access clause{36a}. + +{ The rules b and c establish a precise definition of "expressions" + and "statements". The former are units yielding values of a mode + other than VOID in any context. The later are units in a strong + context with a-posteriori mode of VOID, that get voided. } + +{ The rules d and e establish a precise definition of "constants" and + "variables". The former are either a denotation or an identifier of + some mode. The second are identifiers of a "reference to" mode. } + +{ The rule f introduces a paranotion for all the constructs that + introduce new ranges. } + +3.1 Closed clauses + +3.1.1 Syntax + +A) SOID :: SORT MOID. +B) PACK :: STYLE pack. + +a) SOID NEST closed clause{22a,5D,551a,A341h,A349a} : + SOID NEST serial clause defining LAYER{32a} PACK. + +{ Examples: + a) BEGIN x := 1; y := 2 END } + +3.2 Serial clauses + +3.2.1 Syntax + +{ Extensions: + [MR] "establishing clause" } + +a) SOID NEST serial clause defining new PROPSETY{31a,34f,1,35h} : + SOID NEST new PROPSETY series with PROPSETY{b}. +b) SOID NEST series with PROPSETY{a,b,35c} : + strong void NEST unit{d}, go on{94f} token, + SOID NEST series with PROPSETY{b} ; + where (PROPSETY) is (DECS DECSETY LABSETY), + NEST declaration of DECS{41a}, go on{94f} token, + SOID NEST series with DECSETY LABSETY{b} ; + where (PROPSETY) is (LAB LABSETY), + NEST label definition of LAB{c}, + SOID NEST series with LABSETY{b} ; + where (PROPSETY) is (LAB LABSETY) + and SOID balances SOID1 and SOID2{3}, SOID1 NEST unit{d}, + completion{94f} token, NEST label definition of LAB{c}, + SOID2 NEST series with LABSETY{b} ; + where (PROPSETY) is (EMPTY), + SOID NEST unit{d}. +c) NEST label definition of label TAG{b} : + label NEST defining identifier with TAG{48a}, label{94f} token. +d) SOME unit{b,33b,g,34i,35d,46m,n,521c,532e,541a,b,543c,A34Ab,c,d} : + SOME UNIT{5A,-}. +e) WHETHER SORT MOID balances + SORT1 MOID1 an SORT2 MOID2{b,33b,34d,h} : + WHETHER SORT balances SORT1 and SORT2{f} + and MOID balances MOID1 and MOID2{g}. +f) WHETHER SORT balances SORT1 and SORT2{e,522a} : + where (SORT1) is (strong), WHETHER (SORT2) is (SORT) ; + where (SORT2) is (strong), WHETHER (SORT1) is (SORT). +g) WHETHER MOID balances MOID1 and MOID2{3} : + where (MOID1) is (MOID2), WHETHER (MOID) is (MOID1) ; + where (MOID1) is (transient MOID2), + WHETHER (MOID) is (MOID1) ; + where (MOID2) is (transient MOID1), + WHETHER (MOID) is (MOID2). + +h) *SOID unitary clause : SOID NEST unit{d}. +i) *establishing clause : + SOID NEST serial clause defining LAYER{32a} ; + MODE NEST enquiry clause defining LAYER{34c}. + +{ The paranotion establishing-clause encompasses both module-texts and + revelations. } + +{ Examples: + b) read (x1); REAL s:= 0; + sum: FOR i TO n DO (x1[i] > 0 | s :+= x1[i] | nonpos) OD EXIT + nonpos: print (s) + + REAL s := 0; + sum: FOR i TO n DO (x1[i] > 0 | s :+= x1[i] | nonpos) OD EXIT + nonpos: print (s) + + sum: FOR i TO n DO (x1[i] > 0 | s :+= x1[i] | nonpos) OD EXIT + nonpos: print (s) + + FOR i TO n DO (x1[i] > 0 | s :+= x1[i] | nonpos) OD EXIT + nonpos: print (s) + c) sum: + d) print (s) } + +3.3 Collateral and parallel clauses + +3.3.1 Syntax + +a) strong void NEST collateral clause{5D,551a} : + strong void NEST joined portrait{b} PACK. +b) SOID NEST joined portrait{a,b,c,d,34g} : + were SOID balances SOID1 and SOID2{32e}, + SOID1 NEST unit{32d}, and also{94f} token, + SOID2 NEST unit{32d} + or alternatively SOID2 NEST joined portrait{b}. +c) strong void NEST parallel clause{5D,551a} : + parallel{94f} token, strong void NEST joined portrait{b} PACK. +d) strong ROWS of MODE NEST collateral clause{5D,551a} : + where (ROWS) is (row), + strong MODE NEST joined portrait{b} PACK ; + where (ROWS) is (row ROWS1), + strong ROWS1 of MODE NEST joined portrait{b} PACK ; + EMPTY PACK. +e) strong structured with + FIELDS FIELD mode NEST collateral clause{5D,551a} : + NEST FIELDS FIELD portrait{f} PACK. +f) NEST FIELDS FIELD portrait{3,f} : + NEST FIELDS portrait{f,g}, an also{94f} token, + NEST FIELD portrait{g}. +g) NEST MODE field TAG portrait{f} : strong MODE NEST unit{32d}. + +h) *structure display : + strong structured with FIELDS FIELD mode NEST collateral clause{e}. +i) *row display : + strong ROWS of MODE NEST collateral clause{d}. +j) *display : strong STOWED NEST collateral clause{d,e}. +k) *vacuum : EMPTY PACK. + +3.4 Choice clauses + +3.4.1 Syntax + +A) CHOICE :: choice using boolean ; CASE. +B) CASE :: choice using intgral ; choice using UNITED. + +a) SOID NEST1 CHOICE clause{5D,551a,A341h,A349a} : + CHOICE STYLE start{91a,-}, + SOID NEST1 chooser CHOICE STYLE clause{b}, + CHOICE STYLE finish{91e,-}. +b) SOID NEST1 chooser choice using MODE STYLE clause{a,l} : + MODE NEST1 enquiry clause defining LAYER2{c,-}, + SOID NEST1 LAYER2 alternate choice using MODE STYLE clause{d}. +c) MODE NEST1 enquiry clause defining new DECSETY2{b,35g} : + meek MODE NEST1 new DESETY2 series with DECSETY2{32b}. +d) SOID NEST2 alternate CHOICE STYLE clause{b} : + SOID NEST2 in CHOICE STYLE clause{e} ; + where SOID balances SOID1 and SOID2{32e}, + SOID1 NEST2 in CHOICE STYLE clause{3}, + SOID2 NEST2 out CHOICE STYLE clause{l}. +e) SOID NEST2 in CHOICE STYLE clause{d} : + CHOICE STYLE in{91b,-}, SOID NEST2 in part of CHOICE{f,g,h}. +f) SOID NEST2 in part of choice using boolean{e} : + SOID NEST2 serial clause defining LAYER3{32a}. +g) SOID NEST2 in part of choice using integral{e} : + SOID NEST2 joined portrait{33b}. +h) SOID NEST2 in part of choice using UNITED{e,h} : + SOID NEST2 case part of choice using UNITED{i} ; + where SOID balances SOID1 and SOID2{32e}, + SOID1 NEST2 case part of choice using UNITED{i}, + and also{94f} token, + SOID2 NEST2 in part of choice using UNITED{h}. +i) SOID NEST2 case part of choice using UNITED{h} : + MOID NEST2 LAYER3 specification defining LAYER3{jk,-}, + where MOID unites to UNITED{64b}, + SOID NEST2 LAYER3 unit{32d}. +j) MODE NEST3 specification defining new MODE TAG3{i} : + NEST3 declarative defining new MODE TAG3{541e} brief pack, + colon{94f} token. +k) MOID NEST3 specification defining new EMPTY{i} : + formal MOID NEST3 declarer{46b} brief pack, colon{94f} token. +l) SOID NEST2 out CHOICE STYLE clause{d} : + CHOICE STYLE out{91d,-}, + SOID NEST2 serial lause defining LAYER3{32a} ; + CHOICE STYLE again{91c,-}, + SOID NEST2 chooser CHOICE2 STYLE clause{b}, + where CHOICE2 may follow CHOICE{m}. +m) WHETHER choice using MODE2 may follow choice using MODE1{l} : + where (MODE1) is (MOOD), WHETHER (MODE2) is (MODE1) ; + where (MODE1) begins with (union of), + WHETHER (MODE2) begins with (union of). + +n) *SOME choice clause : SOME CHOICE clause{a}. +o) *SOME conditional clause : SOME choice using boolean clause{a}. +p) *SOME case clause : SOME choice using integral clause{a}. +q) *SOME conformity clause : SOME choice using UNITED clause{a}. + +3.5 Loop clauses + +3.5.1 Syntax + +A) FROBYT :: from ; by ; to. + +a) strong void NEST1 loop clause{5D,551a} : + NEST1 STYLE for part defining new integral TAG2{b}, + NEST1 STYLE intervals{c}, + NEST1 STYLE repeating part with integral TAG2{e}. +b) NEST1 STYLE for part defining new integral TAG2{a} : + STYLE for{94g,-} token, + integral NEST1 new integral TAG2 defining identifier + with TAG2{48a} ; + where (TAG2) is (letter aleph), EMPTY. +c) NEST1 STYLE intervals{a} : + NEST1 STYLE from part{d} option, + NEST1 STYLE by part{d} option, + NEST1 STYLE to part{d} option. +d) NEST1 STYLE FROBYT part{c} : + STYLE FROBYT{94g,-} token, meek integral NEST1 unit{32d}. +e) NEST1 STYLE repeating part with DEC2{a} : + NEST1 new DEC2 STYLE while do part{f} ; + NEST1 new DEC2 STYLE do part{h}. +f) NEST2 STYLE while do part{e} : + NEST2 STYLE while part defining LAYER3{g}, + NEST2 LAYER3 STYLE do part{h}. +g) NEST2 STYLE while part defining LAYER3{f} : + STYLE while{94g,-} token, + boolean NEST2 enquiry clause defining LAYER3{34c,-}. +h) NEST3 STYLE do part{3,f} : + STYLE do{94g,-} token, + strong void NEST3 serial clause defining LAYER4{32a}, + STYLE od{94g,-} token. + +3.6 Access clauses + +{ Extensions: + [MR] GMR } + +{ Access clauses contain a controlled-clause, which is an + enclosed-clause. } + +3.6.1 Syntax + +a) SOID NEST access clause{5D,551a,A341h,A349a} : + NEST revelation publishing EMPTY defining LAYER{b}, + SOID NEST LAYER ENCLOSED clause{a,31a,33a,c,d,e,34a,35a,-}. +b) NEST revelation publishing REVSETY + defining new DECSETY INKSETY{a,49c} : + access{94d} token, + NEST joined module call publishing REVSETY revealing REVS{c}, + where DECSETY INKS revealed by REVS{e,f} + and NEST filters INKSETY out of INKS{h}. +c) NEST joined module call publishing REVSETY revealing RES{b,c} : + NEST moule call publishing REVSETY revealing REVS{d,-} ; + where (REVSETY) is (REVSETY1 REVSETY2) + an (REVS) is (REVS1 REVS2), + NEST module call publishing REVSETY1 revealing REVS1{d,-}, + and also{94f} token, + NEST joined module call publishing REVSETY2 revealing REVS2{c}. +d) NEST module call publishing REVSETY revealing REVS{c} : + where (REVSETY) is (EMPTY), + module REVS NEST applied module indication with TAB{48b} ; + where (REVSETY) is (REVS), + public{94d} token, + module REVS NEST applied module indication with TAB{48b}. +e) WHETHER DECSETY1 DECSETY2 INKS1 INKSETY2 revealed by + TAU reveals DECSETY1 INKS1 REVSETY3 + TAU reveals DECSETY1 INKS1 REVSETY4{b,e,f} : + WHETHER DECSETY DECSETY2 INKS1 INKSETY2 revealed by + TAU reveals DECSETY1 INKS1 REVSETY3 REVSETY4{e,f}. +f) WHETHER DECSETY1 DECSETY2 INKS1 INKSETY2 revealed by + TAU reveals DECSETY1 INKS1 REVSETY2{b,e,f} : + WHETHER DECSETY2 INKSETY2 revealed by REVSETY2 + and DECSETY1 independent DECSETY2{71a,b,c}. +g) WHETHER EMPTY revealed by EmPTY{e,f} : WHETHER true. +h) WHETHER NEST filters INKSETY1 out of INKSETY INK{b} : + unless INK ientified in NEST{72a}, + WHETHER (INKSETY) is (INKSETY2 INK) + and NEST INK filers INKSETY2 out of INKSETY{h,i} ; + where INK identified in NEST{72a}, + WHETHER NEST filters INKSETY1 out of INKSETY{h,i}. +i) WHETHER NEST filters EMPTY out of EMPTY{h} : WHETHER true. + +{ Examples: + a) ACCESS A, B (gets (f, a); puts (a)) + b) ACCESS A, B + c) A, B + d) A + PUB B } + +{ In rule b, the 'invoke TAU's enveloped by 'INKS' represent those + modules which might need to be invoked at any module-call whose + applied-module-indication identified a particular + defining-module-indication, whereas those enveloped by 'INKSETY' + represent only those which need invocation in the particular + context, the remainder having already being elaborated, as can be + determined statically from the 'NEST'. The presence of 'INKSETY' in + the nest of all descendent constructs of the access-clause ensures + that all modules now invoked will never be invoked again within + those descendents. } + +{ Rule f ensures the independence of declarations revealed by one + revelation; thus + + MODULE A = DEF PUB REAL x FED, B = DEF PUB REAL x FED; + ACCESS A, B (x) + + is not produced. However, rule e allows a given declaration to be + revealed by two public accesses of the same module, as in + + MODULE A = DEF PUB REAL x FED; + MODULE B = ACCESS PUB A DEF REAL y FED, + C = ACCESS PUB A DEF REAL z FED; + ACCESS B C (x + y + z) + + in which the module-definitions for both B and C reveal x, by virtue + of the PUB A in their constituent revelations. } + +{ Note that a particular-program may now consist of a + joined-label-definition followed by an access-clause. The + defining-module- indications identified thereby would be in the + library-prelude or the user-prelude. } + +3.7 Unsafe clauses + +{ Extensions: [US] } + +{ Unsafe clauses contain a controlled-clause, which is an enclosed-clause. } + +3.7.1 Syntax + +a) SOID NEST unsafe clause : + unsafe{94f} token, SOID NEST ENCLOSED clause{a,31a,33a,c,d,e,34a,35a,-}. + +{ Examples: + a) UNSAFE (ptr := dst) } + +4 Declarations, declarers and indicators + +4.1 Declarations + +4.1.1 Syntax + +{ Extensions: + [MR] module + "declaration with DECSETY without DECSETY1" } + +A) COMMON :: mode ; priority ; MODINE identity ; + reference to MODINE variable ; MODINE operation ; + PARAMETER ; MODE FIELDS ; module. + { MODINE :: MODE ; routine. } + +a) NEST declaration of DECS{a,32b} : + NEST COMMON declaration of DECS{42a,43a,44a,e,45a,-} ; + where (DECS) is (DECS1 DECS2), + NEST COMMON declaration of DECS1{42a,43a,44a,e,45a,-}, + and also{94f} token, NEST declaration of DECS2{a}. +b) NEST COMMON joined definition of PROPS PROP{b,42a,43a,44a,e,45a,46e,541e} : + NEST COMON joined definition of PROPS{b,c}, + and also{94f} token, + NEST COMMON joined definition of PROP{c}. +c) NEST COMMON joined definition of PROP{b,42a,43a,44a,e,45a,46e,541e} : + NEST COMMON definition of PROP{42b,43b,44c,f,45c,46f,541f,-}. + +d) *definition of PROP : + NEST COMMON definition of PROP{42b,43b,44c,f,45c,46f,541f} ; + NEST label definition of PROP{32}. +e) NEST declaration with DECSETY without DECSETY1{49e} : + where (DECSETY without DECSETY1) is (EMPTY without DECS1), + NEST COMMON declaration of DECS1{42a,43a,44a,e,45a,49a,-} ; + where (DECSETY without DECSETY1) is (DECS without EMPTY), + public{94d} token, + NEST COMMON declaration of DECS{42a,43a,44a,e,45a,49a,-} ; + where (DECSETY without DECSETY1) is + (DECSETY without DECS1 DECSETY2), + NEST COMMON declaration of DECS1{42a,43a,44a,e,45a,49a,-}, + and also{94f} token, + NEST declaration with DECSETY without DECSETY2{e} ; + where (DECSETY without DECSETY1) is + (DECS DECSETY3 without DECSETY1), + public{94d} token, + NEST COMMON declaration of DECS{42a,43a,44a,e,45a,49a,-}, + and also{94f} token, + NEST declaration with DECSETY3 without DECSETY1{e}. + +{ Rule e determines how a "NEST declaration with DECSETY without + DECSETY1" results into two groups of declarations. The declarations + in 'DECSETY' are public and syntactically preceded by PUB. The + declarations in 'DECSETY1 are non-public and are not marked by + PUB. } + +4.2 Mode declarations + +4.2.1 Syntax + +a) NEST mode declaration of DECS{41a} : + mode{94d} token, NEST mode joined definition of DECS{41b,c}. +b) NEST mode definition of MOID TALLY TAB{41c} : + where (TAB) is (bold TAG) or (NEST) is (new LAYER), + MOID TALLY NEST defining mode indication with TAB{48a}, + is defined as{94d} token, + actual MOI TALLY NEST declarer{c}. +c) actual MOID TALLY1 NEST declarer{b} : + where (TALLY1) is (i), + actual MOID NEST declarator{46c,d,g,h,o,s,-} ; + where (TALLY1) is (TALLY2 i), + MOID TALLY2 NEST applied mode indication with TAB2{48b}. + +{ The use of TALLY excludes circular chains of mode-definitions such + as `mode a = b, b = a'. } + +4.3 Priority declarations + +4.3.1 Syntax + +a) NEST priority declaration of DECS{41a} : + priority{94d} token, NEST priority joined definition of DECS{41b,c}. +b) NEST priority definition of priority PRIO TAD{41c} : + priority PRIO NEST definining operator with TAD{48a}, + is defined as{94d} token, DIGIT{94b} token, + where DIGIT counts DIGIT{94b} token, + where DIGIT counts PRIO{c,d}. + {DIGIT :: digit zero ; digit one ; digit two ; digit three ; + digit four ; digit five ; digit six ; digit seven ; + digit eight ; digit nine.} +c) WHETHER DIGIT1 counts PRIO i{b,c} : + WHETHER DIGIT2 counts PRIO{c,d}, + where (digit one igit two digit three digit four + digit five digit six digit seven digit eight digit nine) + contains (DIGIT2 DIGIT1). +d) WHETHER digit one counts i{b,c} : WHETHER true. + +4.4 Identifier declarations + +4.4.1 Syntax + +A) MODINE :: MODE ; routine. +B) LEAP :: local ; heap ; primal. + +a) NEST MODINE identity declaration of DECS{41a} : + formal MODINE NEST declarer{b,46b}, + NEST MODINE identity joined definition of DECS{41b,c}. +b) VICTAL routine NEST declarer{a,523b} : procedure{94d} token. +c) NEST MODINE identity definition of MODE TAG{41c} : + MODE NEST defining identifier with TAG{48a}, + is defined as{94d} token, MODE NEST source for MODINE{d}. +d) MODE NEST source for MODINE{c,f,45c} : + where (MODINE) is (MODE), MODE NEST source{521c} ; + where (MODINE) is (routine), MODE NEST routine text{541a,b,-}. +e) NEST reference to MODINE variable declaration of DECS{41a} : + reference to MODINE NEST LEAP sample generator{523b}, + NEST reference to MODINE variable joined definition of DECS{41b,c}. +f) NEST reference to MODINE variable definition + of reference to MODE TAG{41c} : + reference to MODE NEST defining identifier with TAG{48a}, + becomes{94c} token, MODE NEST soure for MODINE{d} ; + where (MODINE) is (MODE), + reference to MODE NEST defining identifier with TAG{48a}. + +g) *identifier declaration : + NEST MODINE identity declaration of DECS{a} ; + NEST reference to MODINE variable declaration of DECS{e}. + +4.5 Operation declarations + +4.5.1 Syntax + +A) PRAM :: DUO ; MONO. +B) TAO :: TAD ; TAM. + +a) NEST MODINE operation delarations of DECS{41a} : + operator{94d} token, formal MODINE NEST plan{b,46p,-}, + NEST MODINE operation joined definition of DECS{41b,c}. +b) formal routine NEST plan{a} : EMPTY. +c) NEST MODINE operation definition of PRAM TAO{41c} : + PRAM NEST defining operator with TAO{48a}, + is defined as{94d} token, PRAM NEST source for MODINE{44d}. + +4.6 Declarers + +4.6.1 Syntax + +A) VICTAL :: VIRACT ; formal. +B) VIRACT :: virtual ; actual. +C) MOIDS :: MOID ; MOIDS MOID. + +a) VIRACT MOID NEST declarer{c,e,g,h,523a,b} : + VIRACT MOID NEST declarator{c,d,g,h,o,s,-} ; + MOID TALLY NEST applied mode indication with TAB{48b,-}. +b) formal MOID NEST declarer{e,h,p,r,u,34k,44a,541a,b,e,551a} : + where MOID deflexes to MOID{47a,b,c,-}, + formal MOID NEST declarator{c,d,h,o,s,-} ; + MOID1 TALLY NEST applied mode indication with TAB{48b,-}, + where MOID1 deflexes to MOID{47a,b,c,-}. +c) VICTAL reference to MODE NEST declarator{a,b,42c} : + reference to{94d} token, virtual MODE NEST declarer{a}. +d) VICTAL structured with FIELDS mode NEST declarator{a,b,42c} : + structure{94d} token, + VICTAL FIELDS NEST portrayer of FIELDS{e} brief pack. +e) VICTAL FIELDS NEST portrayer of FIELDS1{d,e} : + VICTAL MODE NEST declarer{a,b}, + NEST MODE FIELDS joined definition of FIELDS1{41b,c} ; + where (FIELDS1) is (FIELDS2 FIELDS3), + VICTAL MODE NEST declarer{a,b}, + NEST MODE FIELDS joined definition of FIELDS2{41b,c}, + and also{94f} token, + VICTAL FIELDS NEST portrayer of FIELDS3{e}. +f) NEST MODE FIELDS definition of MODE field TAG{41c} : + MODE field FIELDS defining field selector with TAG{48c}. +g) VIRACT flexible ROWS of MODE NEST declarator{a,42c} : + flexible{94d} token, VIRACT ROWS of MODE NEST declarer{a}. +h) VICTAL ROWS of MODE NEST declarator{a,b,42c} : + VICTAL ROWS NEST rower{i,j,k,l} STYLE bracket, + VICTAL MODE NEST declarer{a,b,}. +i) VICTAL row ROWS NEST rower{h,i} : + VICTAL row NEST rower{j,k,l}, and also{94f} token, + VICTAL ROWS NEST rower{i,j,k,l}. +j) actual row NEST rower{h,i} : + NEST lower bound{m}, up to{94f} token, NEST upper bound{n} ; + NEST upper bound{n}. +k) virtual row NEST rower{h,i} : up to{94f} token option. +l) formal row NEST rower{h,i} : up to{94f} token option. +m) NEST lower bound{j,532f,g} : meek integral NEST unit{32d}. +n) NEST upper bound{j,532f} : meek integral NEST unit{32d}. +o) VICTAL PROCEDURE NEST declarator{a,b,42c} : + procedure{94d} token, formal PROCEDURE NEST plan{p}. +p) formal procedure PARAMETY yieling MOID NEST plan{o,45a} : + where (PARAMETY) is (EMPTY), formal MOID NEST declarer{b} ; + PARAMETERS NEST joined declarer{q,r} brief pack, + formal MOID NEST declarer{b}. +q) PARAMETERS PARAMETER NEST joined declarer{p,q} : + PARAMETERS NEST joined declarer{q,r}, and also{94f} token, + PARAMETER NEST joined declarer{r}. +r) MODE parameter NEST joined declarer{p,q} : + formal MODE NEST declarer{b}. +s) VICTAL union of MOODS1 MOOD1 mode NEST declarator{a,b,42c} : + unless EMPTY with MOODS1 MOOD1 incestuous{47f}, + union of{94d} token, + MOIDS NEST joined declarer{t,u} brief pack, + where MOIDS ravels to MOODS2{47g} + and safe MOODS1 MOOD1 subset of safe MOODS2{73l} + and safe MOODS2 subset of safe MOODS1 MOOD1{731,m}. +t) MOIDS MOID NEST joined declarer{s,t} : + MOIDS NEST joined declarer{t,u}, an also{94f} token, + MOID NEST joined declarer{u}. +u) MOID NEST joined declarer{s,t} : formal MOID NEST declarer{b}. + +4.7 Relationships between modes + +4.7.1 Syntax + +A) NONSTOWED :: PLAIN ; REF to MODE ; PROCEDURE ; UNITED ; void. +B) MOODSETY :: MOODS ; EMPTY. +C) MOIDSETY :: MOIDS ; EMPTY. + +a) WHETHER NONSTOWED deflexes to NONSTOWED{b,e,46b,521c,62a,71n} : + WHETHER true. +b) WHETHER FLEXETY ROWS of MODE1 deflexes to ROWS of MODE2{b,e,46b,521c,62a,71n} : + WHETHER MODE1 deflexes to MODE2{a,b,c,-}. +c) WHETHER structured with FIELDS1 mode deflexes to + structured with FIELDS2 mode{b,e,46b,521c,62a,71n} : + WHETHER FIELDS1 deflexes to FIELDS2{d,e,-}. +d) WHETHER FIELDS1 FIELD1 deflexes to FIELDS2 FIELD2{c,d} : + WHETHER FIELDS1 deflexes to FIELDS2{d,e,-} + and FIELD1 deflexes to FIELD2{e,-}. +e) WHETHER MODE1 field TAG deflexes to MODE2 field TAG{c,d} : + WHETHER MODE1 deflexes to MODE2{a,b,c,-}. + +f) WHETHER MOODSETY1 with MOODSETY2 inestuous{f,46s} : + where (MOODSETY2) is (MOOD MOODSETY3), + WHETHER MOODSETY1 MOOD with MOODSETY3 incestuous{f} + or MOOD is firm union of MOODSETY1 MOODSETY3 mode{71m} ; + where (MOODSETY2) is (EMPTY), WHETHER false. + +g) WHETHER MOIDS ravels to MOODS{g,46s} : + where (MOIDS) is (MOODS), WHETHER true ; + where (MOIDS) is + (MOODSETY union of MOODS1 mode MOIDSETY), + WHETHER MOODSETY MOODS1 MOIDSETY ravels to MOODS{g}. + +{ The hyperrules from a) to e) implement a predicate deflexes-to that + determines whether a given mode deflexes to another mode. Any + non-stowed mode deflexes to any other non-stowed mode. A row mode + deflexes to another row mode if the ranks of the modes are the same + and the mode of the former's elements deflexes to the mode of the + later's elements. A structured mode deflexes to another structured + mode if they have the same number of fields with the same tags and + their modes deflex. } + +{ The hyperrule f) implements a predicate that determines whether two + provided sets of moods are incestuous, i.e. whether they contain + modes which are firmly related. } + +{ The hyperrule g) determines whether a set of moods and + united modes may be ravelled. } + +4.8 Indicators and field selectors + +4.8.1 Syntax + +{ Extensions: + [MR] INK, "module indication", "module REVS", "invoked", TAU } + +A) INDICATOR :: identifier ; mode indication ; operator ; + module indication. +B) DEFIED :: defining ; applied. +C) PROPSETY :: PROPS ; EMPTY. +D) PROPS :: PROP ; PROPS PROP. +E) PROP :: DEC ; LAB ; FIELD ; INK. +F) QUALITY :: MODE ; MOID TALLY ; DYADIC ; label ; MODE field ; + module REVS ; invoked. +G) TAX :: TAG ; TAB ; TAD ; TAM ; TAU. + +a) QUALITY NEST new PROPSETY1 QUALITY TAX PROPSETY2 + defining INDICATOR with TAX{32c,35b,42b,43b,44c,f,45c,541f} : + where QUALITY TAX independent PROPSETY1 PROPSETY2{71a,b,c}, + TAX{942A,D,F,K} token. +b) QUALITY NEST applied INDICATOR with TAX{42c,46a,b,5D,542a,b,544a} : + where QUALITY TAX identified in NEST{72a}, + TAX{942A,D,F,K} token. +c) MODE field PROPSETY1 MODE field TAG PROPSETY2 defining + field selector with TAG{46f} : + where MODE field TAG independent PROPSETY1 PrOPSETY2{71a,b,c}, + TAX{942A} token. +d) MODE field FIELDS applied field selector with TAG{531a} : + where MODE field TAG resides in FIELDS{72b,c,-}, + TAG{942A} token. + +e) *QUALITY NEST DEFIED indicator with TAX : + QUALITY NEST DEFIED INDICATOR with TAX{a,b}. +f) *MODE DEFIED field seletor with TAG : + MODE field FIELDS DEFIED field selector with TAG{c,d}. + +{ MODs are introduced into a nest by module-declarations. + INKs are introduced into a nest by module-calls. } + +{ Modules are ascribed to module-indications by means of + module-declarations. } + +4.9 Module declarations + +4.9.1 Syntax + +a) NEST1 module declaration of MODS{41a,e} : + module{94d} token, + NEST1 module joined definition of MODS{41b,c}. +b) NEST1 module definition of module RESETY REV TAB{41c} : + where (REV) is (TAU reveals DECSETY invoked TAU) + and (TAB) is (bold TAG), + where (NEST1) is (NOTION1 invoked TAU NOTETY2), + unless (NOTION1 NOTETY2) contains (invoked TAU), + module REVSETY REV NEST1 defining module indication with TAB{48a}, + is defined as{94d} token, + NEST1 module text publishing REVSETY REV defining LAYER{c,-}. +c) NEST1 module text + publishing REVSETY TAU reveals DECSETY INKSETY INK + defining new DECSETY1 DECSETY INK{b} : + where (INKSETY) is (EMPTY) and (REVSETY) is (EMPTY), + def{94d} token, + NEST1 new new DECSETY1 DECSETY INK module series + with DECSETY without DECSETY1{d}, + fed{94d} token ; + NEST1 revelation publishing REVSETY defining LAYER{36b}, + def{94d} token, + NEST1 LAYER new DECSETY1 DECSETY INK module series + with DECSETY without DECSETY1{d}, + fed{94d} token, + where (LAYER) is (new DECSETY2 INKSETY). +d) NEST3 module series with DECSETY without DECSETY1{c} : + NEST3 module prelude with DECSETY without DECSETY1{e}, + NEST3 module postlude{f} option. +e) NEST3 module prelude with DECSETY1 without DECSETY2{d,e} : + strong void NEST3 unit{32d}, go on{94f} token, + NEST3 module prelude with DECSETY1 without DECSETY2{e} ; + where (DECSETY1 without DECSETY2) is + (DECSETY3 DECSETY4 without DECSETY5 DECSETY6>, + NEST3 declaration with DECSETY3 without DECSETY5{41e}, + go on{94f} token, + NEST3 module prelude with DECSETY4 without DECSETY6{e} ; + where (DECSETY1 without DECSETY2) is (EMPTY without EMPTY), + strong void NEST3 unit{32d} ; + NEST3 declaration with DECSETY1 without DECSETY2{41e}. +f) NEST3 module postlude{d} : + postlude{94d} token, strong void NEST3 series with EMPTY{32b}. + +g) *module text : + NEST module text publishing REVS defining LAYER{c}. + +{ Examples: + a) MODULE A = DEF STRING s; gets (s); + PUB STRING t = "file"+s, PUB REAL a FED, + B = ACCESS A DEF PUB INT fd; + fopen (fd, file o rdonly) + POSTLUDE close (f) FED + + b) A = DEF STRING s; gets (s); + PUB STRING t = "file"+s, PUB REAL a FED + + B = ACCESS A DEF PUB FILE f; + fopen (fd, file o rdonly) + POSTLUDE close (f) FED + + c) DEF STRING s; gets (s); + PUB STRING t = "file"+s, PUB REAL a FED + + ACCESS A DEF PUB FILE f; + fopen (fd, file o rdonly) + POSTLUDE close (f) FED + + d) STRING s; gets (s); PUB STRING t = "file"+s, PUB real a + + PUB FILE f; fopen (fd, file o rdonly) POSTLUDE close (f) + + e) STRING s; gets (s); PUB STRING t = "file"+s, PUB real a + + PUB FILE f; fopen (fd, file o rdonly) + + f) POSTLUDE close (f) } + +{ Note that the EMPTY (for PROPSETY) in rule f enforces that a module + postlude cannot contain declarations, labels or module accesses. + Only units are allowed. } + +{ Rule b ensures that a unique 'TAU' is associated with each + module-text accessible from any given point in the program. This is + used to ensure that an invoke ATU' can be identified in the nest of + all descendent constructs of any access-clause or module-text which + invokes that module-text. + + In general, a module-text-publishing-REVS-defining-LAYER T makes + 'LAYER' visible within itself, and makes the properties revealed by + 'REVS' visible wherever T is accessed. 'LAYER' includes both a + 'DECSETY' corresponding to its public declarations and an INK' which + links T to its unique associated 'TAU' and signifies in the nest + that T is now known to be invoked. REVS' always reveals 'DECSETY + INKSETY INK' (but not 'DECSETY1'), where INKSETY' signifies the + invocation of any other modules accessed by T. 'REVS' may also + reveal the publications of the other modules accessed by T if their + module-calls within T contained a public-token. } + +5 Units + +5.1 Syntax + +{ Extensions: + [MR] formal hole, virtual hole } + +A) UNIT{32d} :: + assignation{521a} coercee ; identity relation{522a} coercee ; + routine text{541a,b} coercee ; jump{544a} ; skip{552a} ; + and function{57a} ; or function{57b} ; + formal hole{561b} ; virtual hole{561a} ; + TERTIARY{B}. +B) TERTIARY{A,521b,522a} :: + ADIC formula{542a,b} coercee ; nihil ; + SECONDARY{C}. +C) SECONDARY{B,531a,542c} :: + LEAP generator{523a} coercee ; selection{531a} coercee ; + PRIMARY{D}. +D) PRIMARY{C,532a,543a} :: + slice{532a} coercee ; call{543a} coercee ; + format text{A341a} coercee ; + applied identifier with TAG{48b} coercee ; + ENCLOSED clause{31a,33a,c,d,e,34a,35a}. + +a) *SOME hip : + SOME jump{544a} : SOME skip{552a} ; SOME nihil{524a}. + +5.2 Units associated with names + +5.2.1 Assignations + +5.2.1.1 Syntax + +a) REF to MODE NEST assignation{5A} : + REF to MODE NEST destination{b}, becomes{94c} token, + MODE NEST source{c}. +b) REF to MODE NEST destination{a} : + soft REF to MODE NEST TERTIARY{5B}. +c) MODE1 NEST source{a,44d} : + strong MODE2 NEST unit{32d}, + where MODE1 deflexes to MODE2{47a,b,c,-}. + +5.2.2 Identity relations + +5.2.2.1 Syntax + +a) boolean NEST identity relation{5A} : + where soft balances SORT1 and SORT2{32f}, + SORT1 reference to MODE NEST TERTIARY1{5B}, + identity relator{b}, + SORT2 reference to MODE NEST TERTIARY2{5B}. +b) identity relator{a} : is{94f} token ; is not{94f} token. + +5.2.3 Generators + +5.2.3.1 Syntax + +a) reference to MODE NEST LEAP generator{5C} : + LEAP{94d,-} token, actual MODE NEST declarer{46a}. +b) reference to MODINE NEST LEAP sample generator{44e} : + LEAP{94d,-} token, actual MODINE NEST declarer{44b,46a} ; + where (LEAP) is (local), actual MODINE NEST declarer{44b,46a}. + +5.2.4 Nihils + +5.2.4.1 Syntax + +a) strong reference to MODE NEST nihil{5B} : + nil{94f} token. + +5.3 Units associated with stowed values + +5.3.1 Selections + +5.3.1.1 Syntax + +A) REFETY :: REF to ; EMPTY. +B) REFLEXETY :: REF to ; REF to flexible ; EMPTY. + +a) REFETY MODE1 NEST selection{5C} : + MODE1 field FIELDS applied field selector with TAG{48d}, + of{94f} token, weak REFLEXETY ROWS of structured with + FIELDS mode NEST SECONDARY{5C}, + where (REFETY) is derived from (REFLEXETY){b,c,-}. +b) WHETHER (transient reference to) is derived from + (REF to flexible){a,532,66a} : + WHETHER true. +c) WHETHER (REFETY) is derived from (REFETY){a,532a,66a} : + WHETHER true. + +5.3.2 Slices + +5.3.2.1 Syntax + +A) ROWSETY :: ROWS ; EMPTY. + +a) REFETY MODE1 NEST slice{5D} : + weak REFLEXETY ROWS1 of MODE1 NEST PRIMARY{5D}, + ROWS1 leaving EMPTY NEST indexer{b,c,-} STYLE bracket, + where (REFETY) is derived from (REFLEXETY){531b,c,-} ; + where (MODE1) is (ROWS2 of MODE2), + weak REFLEXETY ROWS1 of MODE2 NEST PRIMARY{5D}, + ROWS1 leaving ROWS2 NEST indexer{b,d,-} STYLE bracket, + where (REFETY) is derived from (REFLEXETY){531b,c,-}. +b) row ROWS leaving ROWSETY1 ROWSETY2 NEST indexer{a,b} : + row leaing ROWSETY1 NEST indexer{c,d,-}, and also{94f} token, + ROWS leaving ROWSETY2 NEST indexer{b,c,d,-}. +c) row leaving EMPTY NEST indexer{a,b} : NEST subscript{3}. +d) row leaving row NEST indexer{a,b} : + NEST trimmer{f} ; NEST revised lower bound{g} option. +e) NEST subscript{c} : meek integral NEST unit{32d}. +f) NEST trimmer{d} : + NEST lower bound{46m} option, up to{94f} token, + NEST upper bound{46n} option, + NEST revised lower bound{g} option. +g) NEST revised lower bound{d,f} : + at{94f} token, NEST lower bound{46m}. + +h) *trimscript : + NEST subscript{e} ; NEST trimmer{f}; + NEST revised lower bound{g} option. +i) *indexer : + ROWS leaving ROWSETY NEST indexer{b,c,d}. +j) *boundscript : + NEST subscript{e} ; NEST lower bound{46m} ; + NEST upper bound{46n} ; NEST revised lowe bound{g}. + +5.4 Units associated with routines + +5.4.1 Routine texts + +5.4.1.1 Syntax + +a) procedure yielding MOID NEST1 routine text{44d,5A} : + formal MOID NEST1 declarer{46b}, routine{94f} token, + strong MOID NEST1 unit{32d}. +b) procedure with PARAMETERS yielding + MOID NEST1 routine text{44d,5A} : + NEST1 new DECS2 declarative defining + new DECS2{e} brief pack, + where DECS2 like PARAMETERS{c,d,-}, + formal MOID NEST1 declarer{46b}, routine{94f} token, + strong MOID NEST1 new DECS2 unit{32d}. +c) WHETHER DECS DEC like PARAMETERS PARAMETER{b,c} : + WHETHER DECS like PARAMETERS{c,d-} + and DEC like PARAMETER{d,-}. +d) WHETHER MODE TAG like MODE parameters{b,c} : + WHETHER true. +e) NEST2 declarative defining new DECS2{b,e,34j} : + formal MODE NEST2 declarer{46b}, + NEST2 MODE parameter joined definition of DECS2{41b,c} ; + where (DECS2) is (DECS3 DECS4), + formal MODE NEST2 declarer{46b}, + NEST2 MODE parameter joind definition of DECS3{41b,c}, + and also{94f} token, NEST2 declarative defining new DECS4{3}. +f) NEST2 MODE parameter efinition of MODE TAG2{41c} : + MDOE NEST2 defining identifier with TAG2{48a}. + +g) *formal MODE parameter : + NEST MODE parameter definition of MODE TAG{f}. + +5.4.2 Formulas + +5.4.2.1 Syntax + +A) DYADIC :: priority PRIO. +B) MONADIC :: priority iii iii iii i. +C) ADIC :: DYADIC ; MONADIC. +D) TALLETY :: TALLY ; EMPTY. + +a) MOID NEST DYADIC formula{c,5B} : + MODE1 NEST DYADIC TALLETY operand{c,-}, + procedure with MODE1 parameter MODE2 parameter + yielding MOID NEST applied operator with TAD{48b}, + where DYADIC TAD identified in NEST{72a}, + MODE2 NEST DYADIC TALLY operand{c,-}. +b) MOID NEST MONADIC formula{c,5B} : + procedure with MODE parameter yielding MOID + NEST applied operator ith TAM{48b}, + MODE NEST MONADIC operand{c}. +c) MODE NEST ADIC operand{a,b} : + firm MODE NEST ADIC formula{a,b} coercee{61b} ; + where (ADIC) is (MONADIC), firm MODE NEST SECONDARY{5C}. + +d) *MOID formula : MOID NEST ADIC formula{a,b}. +e) *DUO dyadic operator with TAD : + DUO NEST DEFIED operator with TAD{48a,b}. +f) *MONO monadic operator with TAM : + MONO NEST DEFIED operator with TAM{48a,b}. +g) *MODE operand : MODE NEST ADIC operand{c}. + +5.4.3 Calls + +5.4.3.1 Syntax + +a) MOID NEST call{5D} : + meek procedure with PARAMETERS yielding MOID NEST PRIMARY{5D}, + actual NEST PARAMETERS{b,c} brief pack. +b) actual NEST PARAMETERS PARAMETER{a,b} : + actual NEST PARAMETERS{b,c}, and also{94f} token, + actual NEST PARAMETER{c}. +c) actual NEST MODE parameter{a,b} : strong MODE NEST unit{32d}. + +5.4.4 Jumps + +5.4.4.1 Syntax + +a) strong MOID NEST jump{5A} : + go to{b} option, + label NEST applied identifier with TAG{48b}. +b) go to{a} : STYLE go to{94f,-} token ; + STYLE go{94f,-} token, STYLE to symbol{94g,-}. + +5.5 Units associated with values of any mode + +5.5.1 Casts + +5.5.1.1 Syntax + +a) MOID NEST cast{5D} : + formal MOID NEST declarer{46b}, + strong MOID NEST ENCLOSED clause{31a,33c,d,e,34a,35a,-}. + +5.5.2 Skips + +5.5.2.1 Syntax + +a) strong MOID NEST skip{5A} : skip{94f} token. + +5.6 Holes + +5.6.1 Syntax + +A) LANGUAGE :: algol sixty eight ; fortran ; c language ; cpp language. +B) ALGOL68 :: algol sixty eight. +C) FORTRAM :: fortran. +D) CLANG :: c language. +E) CPPLANG :: cpp language. +F) DLANG :: d language. + +a) strong MOID NEST virtual hole{5A} : + virtual nest symbol, strong MOID NEST closed clause{31a}. +b) strong MOID NEST formal hole{5A} : + formal nest{94d} token, MOID LANGUAGE indication{e,f,-}, + hole indication{d}. +c) MOID NEST actual hole{A6a} : + strong MOID NEST ENCLOSED clause{31a,33a,c,34a,35a,36a,-}. +d) hole indication{b} : + character denotation{814a} ; row of character denotation{83a}. +e) MOID ALGOL68 indication{b} : EMPTY. +f) MOID FORTRAN indication{b} : bold letter f letter o letter r letter t + letter r letter a letter n token. +g) MOID CLANG indication{b} : bold letter c letter l letter a letter n + letter g. +e) MOID CPPLANG indication{b} : bold letter c letter p letter p letter l + letter a letter n letter g. +f) MOID DLANG indication{b} : bold letter d letter l letter a letter n + letter g. + +{ Since no representation is provided for the virtual-nest-symbol, the + user is unable to construct virtual-holes for himself, but a + mechanism is provided (10.6.2.a) for constructing them out of + formal- and actual-holes. } + +5.7 Short-circuit logical functions + +{ Extensions: [SC] } + +{ The short-circuit logical functions are pseudo-operators providing + logical AND and OR functions with short-circuited elaboration. } + +5.7.1 Syntax + +a) boolean NEST and function{5A} : + meek boolean NEST TERTIARY1, andth{94c} token, meek boolean NEST TERTIARY2. + +b) boolean NEST or function{5A} : + meek boolean NEST TERTIARY1, orel{94c} token, meek boolean NEST TERTIARY2. + +c) *boolean NEST short circuit function : + boolean NEST and function{a} ; boolean NEST or function{b}. + +{ Examples: + a) UPB str > 2 ANDTH str[3] /= "x" + b) error = 0 OREL (print ("error"); stop; SKIP) } + +6 Coercion + +6.1 Coercees + +6.1.1 Syntax + +A) STRONG{a,66a} :: + FIRM{B} ; widened to{65a,b,c,d} ; rowed to{66a} ; + voided for{67a,b}. +B) FIRM{A,b} :: MEEK{C} ; united to{64a}. +C) MEEK{B,c,d,64a,63a,64a,65a,b,c,d} :: + unchanged from{f} ; dereferenced to{62a} ; deprocedured to{63a}. +D) SOFT{e,63b} :: + unchanged from{f} ; softly deprocedured to{63b}. +E) FORM :: MORF ; COMORF. +F) MORF :: + NEST selection ; NEST slice ; NEST routine text ; + NEST ADIC formula ; NEST call ; + NEST applied identifier with TAG. +G) COMORF :: + NEST assignation ; NEST identity relation ; + NEST LEAP generator ; NEST cast ; NEST denoter ; + NEST format text. + +a) strong MOID FORM coercee{5A,B,C,D,A341i} : + where (FORM) is (MORF), STRONG{A} MOID MORF ; + where (FORM) is (COMORF), STRONG{A} MOID COMORF, + unless (STRONG MOID) is (deprocedured to void). +b) firm MODE FORM coercee{5A,B,C,D,542c} : FIRM{B} MODE FORM. +c) meek MODE FORM coercee{5A,B,C,D} : MEEK{C} MOID FORM. +d) weak REFETY STOWED FORM coercee{5A,B,C,D} : + MEEK{C} REFETY STOWED FORM, + unless (MEEK) is (dereferenced to) + and (REFETY) is (EMPTY). +e) soft MODE FORM coercee{5A,B,C,D} : SOFT{D} MODE FORM. +f) unchanged from MOID FORM{C,D,67a,b} : MOID FORM. + +g) *SORT MOID coercee : SORT MOID FORM coercee{a,b,c,d,e}. +h) *MOID coercend : MOID FORM. + +{ Examples: + a) 3.14 (in x := 3.14) + b) 3.14 (in x + 3.14) + c) sin (in sin (x)) + d) x1 (in x1[2] := 3.14) + e) x (in x := 3.14) } + +6.2 Dereferencing + +6.2.1 Syntax + +a) dereferenced to{61C} MODE1 FORM : + MEEK{61C} REF to MODE2 FORM, + where MODE2 deflexes to MODE1{47a,b,c,-}. + +{ Examples: + a) x in (real (x)) } + +6.3 Deproceduring + +6.3.1 Syntax + +a) deprocedured to{61C,67a} MOID FORM : + MEEK{61C} procedure yielding MOID FORM. +b) softly deprocedured to{61D} MODE FORM : + SOFT{61D} procedure yielding MODE FORM. + +{ Examples: + a) random (in real (random)) + b) x or y (in x or y := 3.14, given + PROC x or y = REF REAL: (random < .5 | x | y)) } + +6.4 Uniting + +6.4.1 Syntax + +a) united to{64B} UNITED FORM : + MEEK{61C} MOID FORM, + where MOID unites to UNITED{b}. +b) WHETHER MOID1 unites to MOID2{a,34i,71m} : + where MOID1 equivalent MOID2{73a}, WHETHER false ; + unless MOID1 equivalent MOID2{73a}, + WHETHER safe MOODS1 subset of safe MOODS2{73l,m,n}, + where (MOODS1) is (MOID1) + or (union of MOODS1 mode) is (MOID1), + where (MOODS2) is (MOIDS2) + or (union of MOODS2 mode) is (MOIDS2). + +{ Examples: + a) x (in uir := x) + u (in UNION(CHAR,INT,VOID)(u), in a reach containing + UNION(INt,VOID) u := EMPTY) } + +6.5 Widening + +6.5.1 Syntax + +A) BITS :: structured with + row of boolean field SITHETY letter aleph mode. +B) BYTES :: structured with + row of character field SITHETY letter aleph mode. +C) SITHETY :: LENGTH LENGTHETY ; SHORT SHORTHETY ; EMPTY. +D) LENGTH :: letter l letter o letter n letter g. +E) SHORT :: letter s letter h letter o letter r letter t. +F) LENGTHETY :: LENGTH LENGTHETY ; EMPTY. +G) SHORTHETY :: SHORT SHORTHETY ; EMPTY. + +a) widened to{b,61A} SIZETY real FORM : + MEEK{61C} SIZETY integral FORM. +b) widened to{61A} structured with SIZETY real field letter r letter e + SIZETY real field letter i letter m mode FORM : + MEEK{61C} SIZETY real FORM ; + widened to{a} SIZETY real FORM. +c) widened to{61A} row of boolean FORM : MEEK{61C} BIT FORM. +d) widened to{61A} row of character FORM : MEEK{61C} BYTES FORM. + +{ Examples: + a) 1 (in x := 1) + b) 1.0 (in z := 1.0) + 1 (in z := 1) + c) 2r101 (in []BOOL(2r101)) + d) r (in []CHAR(r)) } + +6.6 Rowing + +6.6.1 Syntax + +a) rowed to{61A} REFETY ROWS1 of MODE FORM : + where (ROWS1) is (row), + STRONG{61A} REFLEXETY MODE FORM, + where (REFETY) is derived from (REFLEXETY){531b,c,-} ; + where (ROWS1) is (row ROWS2), + STRONG{61A} REFLEXETY ROWS2 of MODE FORM, + where (REFETY) is derived from (REFLEXETY){531b,c,-}. + +{ Examples: + a) 4.13 (in [1:1]REAL b1 := 4.13) + x1 (in [1:1,1:n]REAL b2 := x1) } + +6.7 Voiding + +6.7.1 Syntax + +A) NONPROC :: PLAIN ; STOWED ; REF to NONPROC ; + procedure with PARAMETERS yielding MOID ; UNITED. + +a) voided to{61A} void MORF : + deprocedured to{63a} NONPROC MORF ; + unchanged from{61f} NONPROC MORF. +b) voided to{61A} void COMORF : + unchanged from{61f} MODE COMORF. + +{ Examples: + a) random (in SKIP; random;) + next random (last random) + (in SKIP; next random (lat random);) + b) PROC VOID (pp) (in PROC PROC VOID pp = PROC VOID : (print (1); + VOID : print (2)); PROC VOID (pp);) } + +8 Denotations + +8.1 Plain denotations + +8.1.0.1 Syntax + +A) SIZE:: long ; short. +B) *NUMERAL :: fixed point numeral ; variable point numeral ; + floating point numeral. + +a) SIZE INTREAL denotation{a,80a} : + SIZE symbol{94d}, INTREAL, denotation{a,811a,812a}. + +b) *plain denotation : + PLAIN denotation{a,811a,812a,813a,814a} ; void denotation{815a}. + +{ Example: + a) LONG 0 } + +8.1.1 Integral denotations + +8.1.1.1 Syntax + +a) integral denotation{80a,810a} : fixed point numeral{b}. +b) fixed point numeral{a,812c,d,f,i,A341h} : digit cypher{c} sequence. +c) digit cypher{b} : DIGIT symbol{94b}. + +{ Examples: + a) 4096 + b) 4096 + c) 4 } + +8.1.2 Real denotations + +8.1.2.1 Syntax + +a) real denotation{80a,810a} : + variable point numeral{b} ; floating point numeral{e}. +b) variable point numeral{a,f} : + integral part{c} option, fractional part{d}. +c) integral part{b} : fixed point numeral{811b}. +d) fractional part{b} : point symbol{94b}, fixed point numeral{811b}. +e) floating point numeral{a} : stagnant part{f}, exponent part{g}. +f) stagnant part{e} : + fixed point numeral{811b} : variable point numeral{b}. +g) exponent part{e} : + times ten to the power choice{h}, power of then{i}. +h) times ten to the power choice{g} : + times ten to the power symbol{94b} ; letter e symbol{94a}. +i) power of ten{g}: plusminus{j} option, fixed point numeral{811b}. +j) plusminus{i} : plus symbol{94c} ; mius symbol{94c}. + +{ Examples: + a) 0.00123 + 1.23e-3 + b) 0.00123 + c) 0 + d) .00123 + e) 1.23e-3 + f) 123 + 1.23 + g) E-3 + h) E + i) -3 + j) + + - } + +8.1.3 Boolean denotations + +8.1.3.1 Syntax + +a) boolean denotation{80a} : true{94b} symbol ; false{94b} smbol. + +{ Examples: + a) TRUE + FALSE } + +8.1.4 Character denotations + +8.1.4.1 Syntax + +a) character denotation{80a} : + quote{94b} symbol, string item{b}, quote sybol{94b}. +b) string item{a,83b} : + character glyph{c} ; quote image symbol{94f} ; other string item{d}. +c) character glyph{b,92c} : + LETTER symbol{94a} ; DIGIT symbol{94b} ; + point sybol{94b} ; open symbol{94f} ; close symbol{94f} ; + comma symbol{94b} ; space symbol{94b} ; + plus symbol{94c} ; minus symbol{94c}. + +{ A production rule may be added for the notion 'other string item' + each of whose alternatives is a symbol 1.1.3.1.f which is different + from any terminal production of 'character glyph' and which is not + 'quote symbol' } + +{ Examples: + a) "a" + b) a + "" + ? + c) a 1 . ( ) , . space + - } + +8.1.5 Void denotation + +5.1.5.1 Syntax + +a) void denotation{80a} : empty{94b} symbol. + +{ Example: + a) EMPTY } + +8.2 Bits denotations + +8.2.1 Syntax + +A) RADIX :: radix two ; radix four ; radix eight ; radix sixteen. + +a) structured with row of boolean field + LENGTH LENGTHETY letter aleph mode denotation{a,80a} : + long{94d} symbol, structured with row of boolean field + LENGTHETY letter aleph mode denotation{a,c}. +b) structured with row of boolean field + SHORT SHORTHTETY letter aleph mode denotation{b,80a} : + short{94d} symbol, + structured with row of boolean field SHORTHETY letter aleph mode denotation{b,c}. +c) structured wih row of boolean field + letter aleph mode denotation{a,b,80a} : + RADIX{d,e,f,g}, letter r symbol{94a}, RADIX digit{h,i,j,k} sequence. +d) radix two{c,A347b} : digit two{94b} symbol. +e) radix four{c,A347b} : digit four{94b} symbol. +f) radix eight{c,A347b} : digit eight{94b} symbol. +g) radix sixteen{c,A347b} : digit one symbol{94b}, digit six symbol{94b}. +h) radix two digit{c,i} : digit zero symbol{94b} ; digit one symbol{94b}. +i) radix four digit{c,j} : + radix two digit{h} ; digit two symbol{94b} ; + digit three symbol{94b}. +j) raidx eight digit{c,k} : + radix four digit{i} ; digit four symbol{94b} ; + digit five symbol{94b} ; digit six symbol{94b} ; + digit seven symbol{94b}. +k) radix sixteen digit{c} : + radix eight digit{j} ; digit eight symbol{94b} ; + digit nine symbol{94b} ; letter a symbol{94a} ; + letter b symbol{94a} ; letter e symbol{94a} ; letter d symbol{94a} ; + letter e symbol{94a} ; letter f symbol{94a}. + +l) *bits denotation : BITS denotation{a,b,c}. +m) *radix digit : RADIX digit{h,i,j,k}. + +{ Examples: + a) LONG 2r101 + b) SHORT 16rffff + c) 8r231 } + +8.3 String denotations + +8.3.1 Syntax + +a) row of character denotation{80a} : + quote{94b} symbol, string{b} option, quote symbol{94b}. +b) string{a} : string item{814b}, string item{814b} sequence. + +c) *string denotation : row of charater denotation{a}. + +{ Examples: + a) "abc" + b) abc } + +9 Tokens and symbols + +9.1 Tokens + +{ Tokens are symbols possibly preceded by pragments. } + +9.1.1 Syntax + +a) CHOICE STYLE start{34a} : + where (CHOICE) is (choice using boolean), + STYLE if{94f,-} token ; + where (CHOICE) is (CASE), STYLE case{94f,-} token. +b) CHOICE STYLE in{34e} : + where (CHOICE) is (choice using boolean), + STYLE then{94f,-} token ; + where (CHOICE) is (CASE), STYLE in{94f,-} token. +c) CHOICE STYLE again{34l} : + where (CHOICE) is (choice using boolean), + STYLE else if{94f,-} token ; + where (CHOICE) is (CASE), STYLE ouse{94f,-} token. +d) CHOICE STYLE out{34l} : + where (CHOICE) is (choice using boolean), + STYLE else{94f,-} token ; + where (CHOICE) is (CASE), STYLE out{94f,-} token. +e) CHOICE STYLE finish{34a} : + whre (CHOICE) is (choice using boolean), + STYLE fi{94f,-} token ; + where (CHOICE) is (CASE), STYLE esac{94f,-} token. +f) NOTION token : + pragment{92a} sequence option, + NOTION symbol{94a,b,c,d,e,f,g,h}. + +g) *token : NOTION token{f}. +h) *symbol : NOTION symbol{94a,b,c,d,e,f,g,h}. + +9.2 Comments and pragmats + +9.2.1 Syntax + +{ Extensions: + [NC] nestable comments. } + +A) PRAGMENT :: pragmat ; comment. + +a) pragment{80a,91f,A341b,h,A348a,b,c,A349a,A34Ab} : PRAGMENT{b}. +b) PRAGMENT{a} : + STYLE PRAGMENT symbol{94h,-}, + STYLE PRAGMENT item{c} sequence option, + STYLE PRAGMENT symbol{94h,-} ; + STYLE nestable comment{d}. +c) STYLE PRAGMENT item{b} : + character glyph{814c} ; STYLE other PRAGMENT item{d}. +d) STYLE nestable comment{b} : + STYLE comment begin symbol{94h,-}, + STYLE nestable comment contents{e} sequence, + STYLE comment end symbol{94h,-}. +e) STYLE nestable comment contents{d} : + STYLE nestable comment item{c} sequence option, + STYLE nestable comment{d} option. +f) STYLE nestable comment item{e} : + character glyph{814c} ; STYLE other nestable comment item{d}. + +{ A production rule may be added for each notion designated by 'STYLE + other PRAGMENT item' each of whose alternatives is a symbol + different from any terminal production of 'character glyph', and + such that no terminal production of any 'STYLE other PRAGMENT item' + is the corresponding 'STYLE PRAGMENT symbol'. This allows to nest + different comment or pragmat for example. } + +9.4 The reference language + +9.4.1 Representations of symbols + +{ Extensions: + [CS] andth symbol, orel symbol + [MR] access symbol, module symbol, def symbol, public symbol, + postlude symbol, formal nest symbol, egg symbol + [US] unsafe symbol } + +{ This section of the Report doesn't describe syntax, but lists all + the different symbols along with their representation in the + reference language. We only include here symbols corresponding to + the GNU extensions implemented by this compiler. } + + symbol representation + +c) andth symbol{57a} ANDTH + orel symbol{57b} OREL +d) module symbol{49a} MODULE + access symbol{36b} ACCESS + def symbol{49c} DEF + fed symbol{49c} FED + public symbol{36d,41e} PUB + postlude symbol{49f} POSTLUDE + formal nest symbol{56b} NEST + egg symbol{A6a,c} EGG +f) unsafe symbol{37a} UNSAFE +h) bold comment begin symbol{92a} NOTE + bold comment end symbol{92a} ETON + brief comment begin symbol{92a} { + brief comment end symbol{92a} } + +10.1.1 Syntax + +{ Extensions: + [MR] user, user task } + +A) EXTERNAL :: user. + +f) NEST1 user task{d} : + NEST2 particular prelude with DECS{c}, + NEST2 user prelude with MODSETY{c}, + NEST2 particular program{g} PACK, go on{94f} token, + NEST2 particualr poslude{i}, + where (NEST2) is (NEST1 new DECS MODSETY STOP). + +10.6 Packets + +10.6.1 Syntax + +a) MOID NEST new MODSETY ALGOL68 stuffing packet{A7a} : + egg{94d} token, hole indication{56d}, is defined as{94d} token, + MOID NEST new MODSETY actual hole{56c}. + +{ b) Note that the rules for "MOID NEST new MODSETY LANGUAGE stuffing + packets" for other languages are not explicitly included in the + syntax. These rules conceptually transform all such + LANGUAGE-stuffing-packets into ALGOL68-stuffing-packets with the + same meaning. } + +c) NEST new MODSETY1 MODS definition module packet of MODS{A7a} : + egg{94d} token, hole indication{56d}, is defined as{94d} token, + NEST new MODSETY1 MODS module declaration of MODS{49a}, + where MODS absent from NEST{e}. +d) new LAYER1 new DECS MODSETY1 MODS STOP + prelude packet of MODS{A7a} : + new LAYER1 new DECS MODSETY1 MODS STOP + module declaration of MODS{4a}, + where MODS absent from new LAYER1{e}. +e) WHETHER MODSETY MOD absent from NEST{c,d} : + WHETEHR MODSETY absent from NEST{e,f} + and MOD independent PROPSETY{71a,b,c}, + where PROPSETY collected properties from NEST{g,h}. +f) WHETHER EMPTY absent from NEST{e} : + WHETHER true. +g) WHETHER PROPSETY1 PROPSETY2 collected properties from + NEST new PROPSETY2{e,g} : + WHETHER PROPSETY1 collected properties from NEST {g,h}. +h) WHETHER EMPTY collected properties from new EMPTY{e,g} : + WHETHER true. + +i) *NEST new PROPSETY packet : + MOID NEST new PROPSETY LANGUAGE stuffing packet{a,b} ; + NEST new PROPSETY definition module packet of MODS{c} ; + NEST new PROPSETY particular program{A1g} ; + NEST new PROPSETY prelude packet of MODS{d}. +j) *letter symbol : LETTER symbol{94a}. +k) *digit symbol : DIGIT symbol{94b}. + +{ Examples: + + a) EGG "abc" = ACCESS A,B (x := 1; y := 2; print (x+y)) + c) EGG "abc" = MODULE A = DEF PUB REAL x FED + d) MODULE B = DEF PUB REAL y FED + + The thre examples above would form a compatible collection of + packets when taken in conjunction with the particular-program BEGIN + NEST "abc" END } + +{ In rule a above, 'MODSETY' envelops the 'MOD's defined by al the + definition-module-packets that are being stuffed along with the + stuffing-packet. + + In rules c and d, 'MODSETY1' need only envelop the 'MOD's for those + modules actually accessed from within that packet. + + The semantics related to packets are only defined if, for a + collection of packets being stuffed together, all the 'MOD's + enveloped by the various 'MODSETY1's are enveloped by 'MODSETY'. } + +{ A stuffing packet contains the definition of an actual-hole. For + Algol 68 this consists on an enclosed-clause. For other values of + the metanotion 'LANGUAGE' it is different, and it is expected to be + translated somehow to an equivalent Algol 68 definition, + conceptually naturally. + + A definition module packet contains the definition of an actual-hole + which consists in one or more joined module declarations, with the + restriction that none of the declared modules shall exist in the + static environment at the formal-hole. + + A prelude packet contains one or more joined module declarations. } + +10.7 Compilation systems + +{ An implementtion of Algol 68 in which packets of a collection are + compiled into a collection of object-modules should conform to the + provisions of this section. } + +10.7.1 Syntax + +{ Note that we use the notion "compilation unit" rather than the + original "compilation input" used in the IFIP modules definition. } + +A) *LAYERS :: LAYER ; LAYERS LAYER. + +a) compilation unit : + MOID NEST new MODSETY LANGUAGE stuffing packet{A6a,b}, + MOID NEST hole interface{d}, + joined module interface with MODSETY{b,c} ; + NEST new MODSETY1 MODS definition module packet of MODS{A6c}, + MOID NEST hole interface{d}, + joined module interface with MODSETY1{b,c}, + module interface with MODS{d} option ; + new LAYER1 new DECS MODSETY STOP particular program{A1g}, + { void new LAYER1 new DECS STOP hole interface,} + unless (DECS) contains (MODULE), + joined module interface with MODSETY{b,c} ; + new LAYER1 new DECS MODSETY1 MODS STOP + prelude packet of MODS{A6d}, + { void new LAYER1 new DECS STOP hole interface,} + unless (DECS) contains (module), + joined module interface with MODSETY1{b,c}, + module interface with MODS{d} option. +b) joined module interface with MODS MODSETY{a,b} : + module interface with MODS{d}, + joined module interface with MODSETY{b,c}. +c) joined module inteface with EMPTY{a,b} : EMPTY. + +{ A compilation-unit is either a stuffing packet, a definition module + packet, a particular program, or a prelude packet. The packets + shall be accompanied by the required hole and module interface + information. } + +{ d) Hyper-rules for "MOID NEST hole interface", "module interface + with MODS" and "MOID NEST object module". The terminal + productions will most likely be in some cryptic notation + understood only by the compiler, i.e. the interface data. } + +{ The inclusion of the hypernotions "void new LAYER1 new DECS STOP + hole interface" within pragmatic remarks in rule a is intended to + signify that this information (which describes the standard + environment) must clearly be available to the compiler, but that it + may well not be provided in the form of an explicit + hole-interface. } diff --git a/gcc/algol68/lang-specs.h b/gcc/algol68/lang-specs.h new file mode 100644 index 000000000000..737270c41f7a --- /dev/null +++ b/gcc/algol68/lang-specs.h @@ -0,0 +1,24 @@ +/* lang-specs.h -- gcc driver specs for Algol 68 frontend. + Copyright (C) 2025 Jose E. Marchesi. + + GCC is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 3, or (at your option) any later + version. + + GCC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* This is the contribution to the `default_compilers' array in gcc.cc for the + Algol 68 language. */ + +{".a68", "@algol68", 0, 1, 0}, + {"@algol68", + "a681 %i %(cc1_options) %{I*} %{L*} %D %{!fsyntax-only:%(invoke_as)}", 0, 1, + 0}, diff --git a/gcc/algol68/lang.opt b/gcc/algol68/lang.opt new file mode 100644 index 000000000000..5fcbfadcdb36 --- /dev/null +++ b/gcc/algol68/lang.opt @@ -0,0 +1,122 @@ +; Options for the Algol 68 front end. +; Copyright (C) 2025 Free Software Foundation, Inc. +; +; GCC is free software; you can redistribute it and/or modify it under +; the terms of the GNU General Public License as published by the Free +; Software Foundation; either version 3, or (at your option) any later +; version. +; +; GCC is distributed in the hope that it will be useful, but WITHOUT ANY +; WARRANTY; without even the implied warranty of MERCHANTABILITY or +; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +; for more details. +; +; You should have received a copy of the GNU General Public License +; along with GCC; see the file COPYING3. If not see +; . + +; See the GCC internals manual for a description of this file's format. + +; Please try to keep this file in ASCII collating order. + +; Describes command-line options used by this frontend + +Language +Algol68 + +I +Algol68 Joined Separate +; Documented in c-family/c.opt + +Wextensions +Algol68 Warning Var(warn_algol68_extensions) LangEnabledBy(Algol68, Wextra) +Warn for usage of non-portable extensions of Algol 68. + +Wvoiding +Algol68 Warning Var(warn_algol68_voiding) LangEnabledBy(Algol68, Wextra) +Warn when voiding occurs. + +Wextra +Algol68 Warning +; Documented in common.opt + +Wscope +Algol68 Warning Var(warn_algol68_scope) +Warn for potential name scope violations. + +Enum +Name(warn_hidden_declarations_level) Type(int) UnknownError(argument %qs to %<-Whidden-declaration%> not recognized) + +EnumValue +Enum(warn_hidden_declarations_level) String(none) Value(0) + +EnumValue +Enum(warn_hidden_declarations_level) String(prelude) Value(1) + +EnumValue +Enum(warn_hidden_declarations_level) String(all) Value(2) + +Whidden-declarations +Algol68 Alias(Whidden-declarations=,prelude,none) +Warn about hidden declarations in inner scopes. + +Whidden-declarations= +Algol68 Warning Var(warn_algol68_hidden_declarations) Enum(warn_hidden_declarations_level) Joined RejectNegative LangEnabledBy(Algol68,Wall) +-Whidden-declarations=[none|prelude|all] Warn about declarations hidden in inner scopes. + +fbrackets +Algol68 Var(flag_brackets) +-fbrackets Consider [ .. ] and { .. } as being equivalent to ( .. ). + +fassert +Algol68 Var(flag_assert) +Generate code for assert contracts. + +fcheck= +Algol68 RejectNegative JoinedOrMissing +-fcheck=[...] Specify which runtime checks are to be performed. + +fa68-dump-modes +Algol68 Var(flag_a68_dump_modes) +Dump Algol 68 modes after parsing. + +fa68-dump-ast +Algol68 Var(flag_a68_dump_ast) +Dump Algol 68 parse tree after parsing. + +fa68-dump-module-interfaces +Algol68 Var(flag_a68_dump_moif) +Dump the interfaces of module definitions in the compiled packet. + +static-libga68 +Driver +Link the GNU Algol run-time library statically in the compilation. + +shared-libga68 +Driver +Link the GNU Algol 68 run-time library dynamically in the compilation. + +std=algol68 +Algol68 +Compile strict Algol 68 as defined by the Revised Report + +std=gnu68 +Algol68 +Accept GNU extensions to Algol 68 + +; Stropping regimes. + +fstropping= +Algol68 Joined RejectNegative Enum(stropping_regime) Var(flag_stropping_regime) +-fstropping=[upper|supper] Stropping regime to expect in Algol 68 programs. + +Enum +Name(stropping_regime) Type(int) UnknownError(unknown stropping_regime setting %qs) + +EnumValue +Enum(stropping_regime) String(upper) Value(0) + +EnumValue +Enum(stropping_regime) String(supper) Value(1) + +; This comment is to ensure we retain the blank line above. diff --git a/gcc/algol68/lang.opt.urls b/gcc/algol68/lang.opt.urls new file mode 100644 index 000000000000..3fea50a3fded --- /dev/null +++ b/gcc/algol68/lang.opt.urls @@ -0,0 +1,47 @@ +; Autogenerated by regenerate-opt-urls.py from gcc/algol68/lang.opt and generated HTML + +I +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) + +Wextensions +LangUrlSuffix_Algol68(ga68/Warnings-options.html#index-Wextensions) + +Wvoiding +LangUrlSuffix_Algol68(ga68/Warnings-options.html#index-Wno-voiding) + +Wextra +UrlSuffix(gcc/Warning-Options.html#index-Wextra) LangUrlSuffix_D(gdc/Warnings.html#index-Wextra) LangUrlSuffix_Fortran(gfortran/Error-and-Warning-Options.html#index-Wextra) + +Wscope +LangUrlSuffix_Algol68(ga68/Warnings-options.html#index-Wno-scope) + +Whidden-declarations +LangUrlSuffix_Algol68(ga68/Warnings-options.html#index-Whidden-declarations) + +Whidden-declarations= +LangUrlSuffix_Algol68(ga68/Warnings-options.html#index-Whidden-declarations) + +fbrackets +LangUrlSuffix_Algol68(ga68/Dialect-options.html#index-fbrackets) + +fassert +LangUrlSuffix_D(gdc/Runtime-Options.html#index-fassert) LangUrlSuffix_Algol68(ga68/Runtime-options.html#index-fassert) + +fcheck= +LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcheck) LangUrlSuffix_Algol68(ga68/Runtime-options.html#index-fcheck) + +fa68-dump-modes +LangUrlSuffix_Algol68(ga68/Developer-options.html#index-fa68-dump-modes) + +fa68-dump-ast +LangUrlSuffix_Algol68(ga68/Developer-options.html#index-fa68-dump-ast) + +fa68-dump-module-interfaces +LangUrlSuffix_Algol68(ga68/Developer-options.html#index-fa68-dump-module-interfaces) + +static-libga68 +LangUrlSuffix_Algol68(ga68/Linking-options.html#index-static-libga68) + +shared-libga68 +LangUrlSuffix_Algol68(ga68/Linking-options.html#index-shared-libga68) + diff --git a/gcc/analyzer/ChangeLog b/gcc/analyzer/ChangeLog index f96b31323565..58fc1f406724 100644 --- a/gcc/analyzer/ChangeLog +++ b/gcc/analyzer/ChangeLog @@ -1,3 +1,21 @@ +2025-11-28 Jakub Jelinek + + * known-function-manager.cc (known_function_manager::add): Avoid + arithmetics between enumerators from different enum types. + (known_function_manager::get_internal_fn): Likewise. + +2025-11-27 Jonathan Wakely + + * constraint-manager.cc (equiv_class::operator==): Add const + qualifier. + * constraint-manager.h (equiv_class::operator==): Likewise. + +2025-11-25 David Malcolm + + * sm-malloc.cc (deref_before_check::emit): Add logging of the + various conditions for late-rejection of a + -Wanalyzer-deref-before-check warning. + 2025-11-12 David Malcolm * program-state.cc (log_set_of_svalues): Avoid -Wformat-security diff --git a/gcc/analyzer/constraint-manager.cc b/gcc/analyzer/constraint-manager.cc index 58c60feae369..c8cc71593cc0 100644 --- a/gcc/analyzer/constraint-manager.cc +++ b/gcc/analyzer/constraint-manager.cc @@ -1175,7 +1175,7 @@ equiv_class::hash () const meaningful. */ bool -equiv_class::operator== (const equiv_class &other) +equiv_class::operator== (const equiv_class &other) const { if (m_constant != other.m_constant) return false; // TODO: use tree equality here? diff --git a/gcc/analyzer/constraint-manager.h b/gcc/analyzer/constraint-manager.h index 4339ea665d84..38686b7e696b 100644 --- a/gcc/analyzer/constraint-manager.h +++ b/gcc/analyzer/constraint-manager.h @@ -258,7 +258,7 @@ class equiv_class equiv_class (const equiv_class &other); hashval_t hash () const; - bool operator== (const equiv_class &other); + bool operator== (const equiv_class &other) const; void add (const svalue *sval); bool del (const svalue *sval); diff --git a/gcc/analyzer/known-function-manager.cc b/gcc/analyzer/known-function-manager.cc index 3b645a8c90f8..fad34ad38b0f 100644 --- a/gcc/analyzer/known-function-manager.cc +++ b/gcc/analyzer/known-function-manager.cc @@ -83,8 +83,8 @@ known_function_manager::add (enum internal_fn ifn, std::unique_ptr kf) { gcc_assert (ifn < IFN_LAST); - delete m_combined_fns_arr[ifn + END_BUILTINS]; - m_combined_fns_arr[ifn + END_BUILTINS] = kf.release (); + delete m_combined_fns_arr[ifn + int (END_BUILTINS)]; + m_combined_fns_arr[ifn + int (END_BUILTINS)] = kf.release (); } /* Get any known_function for FNDECL for call CD. @@ -137,7 +137,7 @@ const known_function * known_function_manager::get_internal_fn (enum internal_fn ifn) const { gcc_assert (ifn < IFN_LAST); - return m_combined_fns_arr[ifn + END_BUILTINS]; + return m_combined_fns_arr[ifn + int (END_BUILTINS)]; } /* Get any known_function for NAME, without type-checking. diff --git a/gcc/analyzer/sm-malloc.cc b/gcc/analyzer/sm-malloc.cc index 8ce771062ca6..88bfc74888c6 100644 --- a/gcc/analyzer/sm-malloc.cc +++ b/gcc/analyzer/sm-malloc.cc @@ -1612,19 +1612,34 @@ class deref_before_check : public malloc_diagnostic bool emit (diagnostic_emission_context &ctxt) final override { + LOG_SCOPE (ctxt.get_logger ()); + logger *logger = ctxt.get_logger (); + /* Don't emit the warning if we can't show where the deref and the check occur. */ if (!m_deref_enode) - return false; + { + if (logger) + logger->log ("rejecting: no deref enode"); + return false; + } if (!m_check_enode) - return false; + { + if (logger) + logger->log ("rejecting: no check enode"); + return false; + } /* Only emit the warning for intraprocedural cases. */ const program_point &deref_point = m_deref_enode->get_point (); const program_point &check_point = m_check_enode->get_point (); if (!program_point::effectively_intraprocedural_p (deref_point, check_point)) - return false; + { + if (logger) + logger->log ("rejecting: not effectively intraprocedural"); + return false; + } /* Reject the warning if the check occurs within a macro defintion. This avoids false positives for such code as: @@ -1661,7 +1676,11 @@ class deref_before_check : public malloc_diagnostic a source of real bugs; see e.g. PR 77425. */ location_t check_loc = m_check_enode->get_point ().get_location (); if (linemap_location_from_macro_definition_p (line_table, check_loc)) - return false; + { + if (logger) + logger->log ("rejecting: check occurs within macro definition"); + return false; + } /* Reject warning if the check is in a loop header within a macro expansion. This rejects cases like: @@ -1676,16 +1695,29 @@ class deref_before_check : public malloc_diagnostic would just be noise if we reported it. */ if (loop_header_p (m_check_enode->get_point ()) && linemap_location_from_macro_expansion_p (line_table, check_loc)) - return false; + { + if (logger) + logger->log + ("rejecting: check occurs in loop header macro expansion"); + return false; + } /* Reject if m_deref_expr is sufficiently different from m_arg for cases where the dereference is spelled differently from the check, which is probably two different ways to get the same svalue, and thus not worth reporting. */ if (!m_deref_expr) - return false; + { + if (logger) + logger->log ("rejecting: no deref_expr"); + return false; + } if (!sufficiently_similar_p (m_deref_expr, m_arg)) - return false; + { + if (logger) + logger->log ("rejecting: not sufficiently similar to arg"); + return false; + } /* Reject the warning if the deref's BB doesn't dominate that of the check, so that we don't warn e.g. for shared cleanup @@ -1697,7 +1729,11 @@ class deref_before_check : public malloc_diagnostic if (!dominated_by_p (CDI_DOMINATORS, m_check_enode->get_supernode ()->m_bb, m_deref_enode->get_supernode ()->m_bb)) - return false; + { + if (logger) + logger->log ("rejecting: deref doesn't dominate the check"); + return false; + } return ctxt.warn ("check of %qE for NULL after already" " dereferencing it", diff --git a/gcc/c-family/ChangeLog b/gcc/c-family/ChangeLog index 741c11e634c6..46d0d308059f 100644 --- a/gcc/c-family/ChangeLog +++ b/gcc/c-family/ChangeLog @@ -1,3 +1,53 @@ +2025-11-30 Andrew Pinski + + * c.opt.urls: Regenerate. + +2025-11-26 Alejandro Colomar + + * c-common.cc (c_common_reswords): Add _Maxof & _Minof keywords. + (c_maxof_type, c_minof_type): New functions. + * c-common.def (MAXOF_EXPR, MINOF_EXPR): New trees. + * c-common.h (enum rid): Add RID_MAXOF & RID_MINOF constants. + (c_maxof_type, c_minof_type): New prototypes. + +2025-11-26 Jakub Jelinek + + * c-opts.cc (c_common_init_options): Call set_std_cxx20 rather than + set_std_cxx17. + * c.opt (std=c++2a): Change description to deprecated option wording. + (std=c++20): Remove experimental support part. + (std=c++2b): Change description to deprecated option wording. + (std=gnu++2a): Likewise. + (std=gnu++20): Remove experimental support part. + (std=gnu++2b): Change description to deprecated option wording. + +2025-11-25 Jason Merrill + + * c.opt: Add --compile-std-module. + +2025-11-25 Jakub Jelinek + + PR middle-end/120052 + * c-ubsan.cc (ubsan_instrument_bounds): For VLAs use + 1 instead of 0 as first IFN_UBSAN_BOUNDS argument and only + use the addend without TYPE_MAX_VALUE (TYPE_DOMAIN (type)) + in the 3rd argument. + +2025-11-25 Jakub Jelinek + + PR middle-end/122624 + * c-common.cc (c_common_get_alias_set): Fix up handling of BITINT_TYPE + and non-standard INTEGER_TYPEs. For unsigned _BitInt(1) always return + -1. For other unsigned types set TYPE_ALIAS_SET to get_alias_set of + corresponding signed type and return that. For signed types check if + corresponding unsigned type has TYPE_ALIAS_SET_KNOWN_P and if so copy + its TYPE_ALIAS_SET and return that. + +2025-11-25 Kito Cheng + + * c-opts.cc (c_common_post_options): Skip register_include_chains + when cpp_opts->preprocessed is set. + 2025-11-22 Sandra Loosemore Julian Brown waffl3x diff --git a/gcc/c-family/c-common.cc b/gcc/c-family/c-common.cc index ef1ce62068dd..3cec729c901c 100644 --- a/gcc/c-family/c-common.cc +++ b/gcc/c-family/c-common.cc @@ -397,6 +397,8 @@ const struct c_common_resword c_common_reswords[] = { "_Alignas", RID_ALIGNAS, D_CONLY }, { "_Alignof", RID_ALIGNOF, D_CONLY }, { "_Countof", RID_COUNTOF, D_CONLY }, + { "_Maxof", RID_MAXOF, D_CONLY }, + { "_Minof", RID_MINOF, D_CONLY }, { "_Atomic", RID_ATOMIC, D_CONLY }, { "_BitInt", RID_BITINT, D_CONLY }, { "_Bool", RID_BOOL, D_CONLY }, @@ -4164,6 +4166,48 @@ c_countof_type (location_t loc, tree type) return value; } +/* Implement the _Maxof operator: + Return the maximum representable value of an integer type. */ + +tree +c_maxof_type (location_t loc, tree type) +{ + if (!INTEGRAL_TYPE_P (type)) + { + error_at (loc, "invalid application of %<_Maxof%> to type %qT", type); + return error_mark_node; + } + if (!COMPLETE_TYPE_P (type)) + { + error_at (loc, "invalid application of %<_Maxof%> to incomplete type %qT", + type); + return error_mark_node; + } + + return TYPE_MAX_VALUE (type); +} + +/* Implement the _Minof operator: + Return the minimum representable value of an integer type. */ + +tree +c_minof_type (location_t loc, tree type) +{ + if (!INTEGRAL_TYPE_P (type)) + { + error_at (loc, "invalid application of %<_Minof%> to type %qT", type); + return error_mark_node; + } + if (!COMPLETE_TYPE_P (type)) + { + error_at (loc, "invalid application of %<_Minof%> to incomplete type %qT", + type); + return error_mark_node; + } + + return TYPE_MIN_VALUE (type); +} + /* Handle C and C++ default attributes. */ enum built_in_attribute diff --git a/gcc/c-family/c-common.def b/gcc/c-family/c-common.def index 0bcc4998afe6..9b1f034579b7 100644 --- a/gcc/c-family/c-common.def +++ b/gcc/c-family/c-common.def @@ -53,6 +53,12 @@ DEFTREECODE (USERDEF_LITERAL, "userdef_literal", tcc_exceptional, 3) /* Represents a 'countof' expression. */ DEFTREECODE (COUNTOF_EXPR, "countof_expr", tcc_expression, 1) +/* Represents a 'maxof' expression. */ +DEFTREECODE (MAXOF_EXPR, "maxof_expr", tcc_expression, 1) + +/* Represents a 'minof' expression. */ +DEFTREECODE (MINOF_EXPR, "minof_expr", tcc_expression, 1) + /* Represents a 'sizeof' expression during C++ template expansion, or for the purpose of -Wsizeof-pointer-memaccess warning. */ DEFTREECODE (SIZEOF_EXPR, "sizeof_expr", tcc_expression, 1) diff --git a/gcc/c-family/c-common.h b/gcc/c-family/c-common.h index 8b7f4ae44717..6a92bd6ef762 100644 --- a/gcc/c-family/c-common.h +++ b/gcc/c-family/c-common.h @@ -105,7 +105,7 @@ enum rid /* C extensions */ RID_ASM, RID_TYPEOF, RID_TYPEOF_UNQUAL, RID_ALIGNOF, RID_ATTRIBUTE, - RID_COUNTOF, + RID_COUNTOF, RID_MAXOF, RID_MINOF, RID_C23_VA_START, RID_VA_ARG, RID_EXTENSION, RID_IMAGPART, RID_REALPART, RID_LABEL, RID_CHOOSE_EXPR, RID_TYPES_COMPATIBLE_P, RID_BUILTIN_COMPLEX, RID_BUILTIN_SHUFFLE, @@ -893,6 +893,8 @@ extern void c_apply_type_quals_to_decl (int, tree); extern tree c_sizeof_or_alignof_type (location_t, tree, bool, bool, int); extern tree c_alignof_expr (location_t, tree); extern tree c_countof_type (location_t, tree); +extern tree c_maxof_type (location_t, tree); +extern tree c_minof_type (location_t, tree); /* Print an error message for invalid operands to arith operation CODE. NOP_EXPR is used as a special case (see truthvalue_conversion). */ extern void binary_op_error (rich_location *, enum tree_code, tree, tree); diff --git a/gcc/c-family/c-opts.cc b/gcc/c-family/c-opts.cc index 1e0f0c59ade0..8da51759dfd3 100644 --- a/gcc/c-family/c-opts.cc +++ b/gcc/c-family/c-opts.cc @@ -274,9 +274,9 @@ c_common_init_options (unsigned int decoded_options_count, } } - /* Set C++ standard to C++17 if not specified on the command line. */ + /* Set C++ standard to C++20 if not specified on the command line. */ if (c_dialect_cxx ()) - set_std_cxx17 (/*ISO*/false); + set_std_cxx20 (/*ISO*/false); global_dc->get_source_printing_options ().colorize_source_p = true; } diff --git a/gcc/c-family/c.opt b/gcc/c-family/c.opt index 8da089780c4e..e1576c9c3c37 100644 --- a/gcc/c-family/c.opt +++ b/gcc/c-family/c.opt @@ -2618,15 +2618,15 @@ Conform to the ISO 2017 C++ standard. std=c++2a C++ ObjC++ Alias(std=c++20) Undocumented -Conform to the ISO 2020 C++ standard (experimental and incomplete support). +Deprecated in favor of -std=c++20. std=c++20 C++ ObjC++ -Conform to the ISO 2020 C++ standard (experimental and incomplete support). +Conform to the ISO 2020 C++ standard. std=c++2b C++ ObjC++ Alias(std=c++23) Undocumented -Conform to the ISO 2023 C++ standard (published in 2024; experimental and incomplete support). +Deprecated in favor of -std=c++23. std=c++23 C++ ObjC++ @@ -2720,15 +2720,15 @@ Conform to the ISO 2017 C++ standard with GNU extensions. std=gnu++2a C++ ObjC++ Alias(std=gnu++20) Undocumented -Conform to the ISO 2020 C++ standard with GNU extensions (experimental and incomplete support). +Deprecated in favor of -std=gnu++20. std=gnu++20 C++ ObjC++ -Conform to the ISO 2020 C++ standard with GNU extensions (experimental and incomplete support). +Conform to the ISO 2020 C++ standard with GNU extensions. std=gnu++2b C++ ObjC++ Alias(std=gnu++23) Undocumented -Conform to the ISO 2023 C++ standard with GNU extensions (published in 2024; experimental and incomplete support). +Deprecated in favor of -std=gnu++23. std=gnu++23 C++ ObjC++ diff --git a/gcc/c-family/c.opt.urls b/gcc/c-family/c.opt.urls index 1f9e6ba95d9f..9430f4bc2f9c 100644 --- a/gcc/c-family/c.opt.urls +++ b/gcc/c-family/c.opt.urls @@ -23,7 +23,7 @@ H UrlSuffix(gcc/Preprocessor-Options.html#index-H) LangUrlSuffix_D(gdc/Code-Generation.html#index-H) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-H) I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) M UrlSuffix(gcc/Preprocessor-Options.html#index-M) LangUrlSuffix_D(gdc/Code-Generation.html#index-M) diff --git a/gcc/c/ChangeLog b/gcc/c/ChangeLog index 07472e7202fd..974dd6d768fc 100644 --- a/gcc/c/ChangeLog +++ b/gcc/c/ChangeLog @@ -1,3 +1,18 @@ +2025-11-27 Jakub Jelinek + + PR c/121506 + * c-typeck.cc (c_type_tag): If TYPE_NAME is TYPE_DECL + with non-NULL DECL_NAME, return that. + +2025-11-26 Alejandro Colomar + + * c-parser.cc (c_parser_maxof_or_minof_expression): New func. + (c_parser_unary_expression): Add RID_MAXOF & RID_MINOF cases. + * c-tree.h (c_expr_maxof_type): New prototype. + (c_expr_minof_type): New prototype. + * c-typeck.cc (c_expr_maxof_type): New function. + (c_expr_minof_type): New function. + 2025-11-22 Sandra Loosemore Julian Brown diff --git a/gcc/c/c-parser.cc b/gcc/c/c-parser.cc index aa7b50c8a234..b4dc741c6fd4 100644 --- a/gcc/c/c-parser.cc +++ b/gcc/c/c-parser.cc @@ -1865,6 +1865,7 @@ static struct c_expr c_parser_unary_expression (c_parser *); static struct c_expr c_parser_sizeof_or_countof_expression (c_parser *, enum rid); static struct c_expr c_parser_alignof_expression (c_parser *); +static struct c_expr c_parser_maxof_or_minof_expression (c_parser *, enum rid); static struct c_expr c_parser_postfix_expression (c_parser *); static struct c_expr c_parser_postfix_expression_after_paren_type (c_parser *, struct c_declspecs *, @@ -10642,6 +10643,8 @@ c_parser_cast_expression (c_parser *parser, struct c_expr *after) unary-expression: __alignof__ unary-expression __alignof__ ( type-name ) + _Maxof ( type-name ) + _Minof ( type-name ) && identifier (C11 permits _Alignof with type names only.) @@ -10774,6 +10777,9 @@ c_parser_unary_expression (c_parser *parser) return c_parser_sizeof_or_countof_expression (parser, rid); case RID_ALIGNOF: return c_parser_alignof_expression (parser); + case RID_MAXOF: + case RID_MINOF: + return c_parser_maxof_or_minof_expression (parser, rid); case RID_BUILTIN_HAS_ATTRIBUTE: return c_parser_has_attribute_expression (parser); case RID_EXTENSION: @@ -11017,6 +11023,67 @@ c_parser_alignof_expression (c_parser *parser) } } +/* Parse a _Maxof or _Minof expression. */ + +static struct c_expr +c_parser_maxof_or_minof_expression (c_parser *parser, enum rid rid) +{ + const char *op_name = (rid == RID_MAXOF) ? "_Maxof" : "_Minof"; + struct c_expr result; + location_t expr_loc; + struct c_type_name *type_name; + matching_parens parens; + gcc_assert (c_parser_next_token_is_keyword (parser, rid)); + + location_t start; + location_t finish = UNKNOWN_LOCATION; + + start = c_parser_peek_token (parser)->location; + + pedwarn (start, OPT_Wpedantic, "ISO C does not support %qs", op_name); + + c_parser_consume_token (parser); + c_inhibit_evaluation_warnings++; + if (!c_parser_next_token_is (parser, CPP_OPEN_PAREN)) + { + c_parser_error (parser, "expected %<(%>"); + goto fail; + } + parens.consume_open (parser); + expr_loc = c_parser_peek_token (parser)->location; + if (!c_token_starts_typename (c_parser_peek_token (parser))) + { + error_at (expr_loc, "invalid application of %qs to something not a type", op_name); + parens.skip_until_found_close (parser); + goto fail; + } + type_name = c_parser_type_name (parser, true); + if (type_name == NULL) + { + // c_parser_type_name() has already diagnosed the error. + parens.skip_until_found_close (parser); + goto fail; + } + parens.skip_until_found_close (parser); + finish = parser->tokens_buf[0].location; + if (type_name->specs->alignas_p) + error_at (type_name->specs->locations[cdw_alignas], + "alignment specified for type name in %qs", op_name); + c_inhibit_evaluation_warnings--; + if (rid == RID_MAXOF) + result = c_expr_maxof_type (expr_loc, type_name); + else + result = c_expr_minof_type (expr_loc, type_name); + set_c_expr_source_range (&result, start, finish); + return result; +fail: + c_inhibit_evaluation_warnings--; + result.set_error (); + result.original_code = ERROR_MARK; + result.original_type = NULL; + return result; +} + /* Parse the __builtin_has_attribute ([expr|type], attribute-spec) expression. */ diff --git a/gcc/c/c-tree.h b/gcc/c/c-tree.h index ff63d69e85d5..80b147154032 100644 --- a/gcc/c/c-tree.h +++ b/gcc/c/c-tree.h @@ -856,6 +856,8 @@ extern struct c_expr c_expr_sizeof_type (location_t, struct c_type_name *); extern struct c_expr c_expr_countof_expr (location_t, struct c_expr); extern struct c_expr c_expr_countof_type (location_t loc, struct c_type_name *); +extern struct c_expr c_expr_maxof_type (location_t loc, struct c_type_name *); +extern struct c_expr c_expr_minof_type (location_t loc, struct c_type_name *); extern struct c_expr parser_build_unary_op (location_t, enum tree_code, struct c_expr); extern struct c_expr parser_build_binary_op (location_t, diff --git a/gcc/c/c-typeck.cc b/gcc/c/c-typeck.cc index e1d2d1173dc7..a34ca2ab97c4 100644 --- a/gcc/c/c-typeck.cc +++ b/gcc/c/c-typeck.cc @@ -610,9 +610,9 @@ c_type_tag (const_tree t) return NULL_TREE; if (TREE_CODE (name) == TYPE_DECL) { - /* A TYPE_DECL added by add_decl_expr. */ - gcc_checking_assert (!DECL_NAME (name)); - return NULL_TREE; + if (!DECL_NAME (name)) + return NULL_TREE; + name = DECL_NAME (name); } gcc_checking_assert (TREE_CODE (name) == IDENTIFIER_NODE); return name; @@ -4120,6 +4120,60 @@ c_expr_countof_type (location_t loc, struct c_type_name *t) return ret; } +/* Return the result of maxof applied to T, a structure for the type + name passed to maxof (rather than the type itself). LOC is the + location of the original expression. */ + +struct c_expr +c_expr_maxof_type (location_t loc, struct c_type_name *t) +{ + tree type; + struct c_expr ret; + tree type_expr = NULL_TREE; + bool type_expr_const = true; + type = groktypename (t, &type_expr, &type_expr_const); + ret.value = c_maxof_type (loc, type); + c_last_sizeof_arg = type; + c_last_sizeof_loc = loc; + ret.original_code = MAXOF_EXPR; + ret.original_type = NULL; + ret.m_decimal = 0; + if (type == error_mark_node) + { + ret.value = error_mark_node; + ret.original_code = ERROR_MARK; + } + pop_maybe_used (type != error_mark_node); + return ret; +} + +/* Return the result of minof applied to T, a structure for the type + name passed to minof (rather than the type itself). LOC is the + location of the original expression. */ + +struct c_expr +c_expr_minof_type (location_t loc, struct c_type_name *t) +{ + tree type; + struct c_expr ret; + tree type_expr = NULL_TREE; + bool type_expr_const = true; + type = groktypename (t, &type_expr, &type_expr_const); + ret.value = c_minof_type (loc, type); + c_last_sizeof_arg = type; + c_last_sizeof_loc = loc; + ret.original_code = MINOF_EXPR; + ret.original_type = NULL; + ret.m_decimal = 0; + if (type == error_mark_node) + { + ret.value = error_mark_node; + ret.original_code = ERROR_MARK; + } + pop_maybe_used (type != error_mark_node); + return ret; +} + /* Build a function call to function FUNCTION with parameters PARAMS. The function call is at LOC. PARAMS is a list--a chain of TREE_LIST nodes--in which the diff --git a/gcc/cobol/ChangeLog b/gcc/cobol/ChangeLog index a7260f8ea508..00b49cc42e16 100644 --- a/gcc/cobol/ChangeLog +++ b/gcc/cobol/ChangeLog @@ -1,3 +1,7 @@ +2025-11-30 Andrew Pinski + + * lang.opt.urls: Regenerate. + 2025-11-17 James K. Lowden PR cobol/122702 diff --git a/gcc/cobol/lang.opt.urls b/gcc/cobol/lang.opt.urls index 9ceb6cff39a2..e628ae52505c 100644 --- a/gcc/cobol/lang.opt.urls +++ b/gcc/cobol/lang.opt.urls @@ -8,7 +8,7 @@ UrlSuffix(gcc/Preprocessor-Options.html#index-D-1) ; duplicate: 'gcc/Overall-Options.html#index-E' I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) M UrlSuffix(gcc/Preprocessor-Options.html#index-M) LangUrlSuffix_D(gdc/Code-Generation.html#index-M) diff --git a/gcc/common.opt b/gcc/common.opt index d44f713ae34f..0a3d65d4d4a8 100644 --- a/gcc/common.opt +++ b/gcc/common.opt @@ -3985,6 +3985,9 @@ Driver Joined static Driver +static-libga68 +Driver + static-libgcc Driver diff --git a/gcc/common.opt.urls b/gcc/common.opt.urls index d13af0a8e7c6..cade6079f578 100644 --- a/gcc/common.opt.urls +++ b/gcc/common.opt.urls @@ -1996,9 +1996,11 @@ UrlSuffix(gcc/Overall-Options.html#index-specs) specs= UrlSuffix(gcc/Overall-Options.html#index-specs) -; skipping UrlSuffix for 'static' due to multiple URLs: -; duplicate: 'gcc/Darwin-Options.html#index-static-1' -; duplicate: 'gcc/Link-Options.html#index-static' +static +UrlSuffix(gcc/Link-Options.html#index-static) + +static-libga68 +LangUrlSuffix_Algol68(ga68/Linking-options.html#index-static-libga68) static-libgcc UrlSuffix(gcc/Link-Options.html#index-static-libgcc) diff --git a/gcc/common/config/riscv/riscv-common.cc b/gcc/common/config/riscv/riscv-common.cc index adfd22019a92..efa2a45a6404 100644 --- a/gcc/common/config/riscv/riscv-common.cc +++ b/gcc/common/config/riscv/riscv-common.cc @@ -1404,47 +1404,6 @@ riscv_subset_list::parse (const char *arch, location_t *loc) return NULL; } -/* Get the profile that best matches the current architecture string, - where best is defined as the most expansive profile. */ - -const char * -riscv_subset_list::get_profile_name () const -{ - const char *best_profile = NULL; - int max_ext_count = -1; - - for (int i = 0; riscv_profiles_table[i].profile_name != nullptr; ++i) - { - riscv_subset_list *subset_list = riscv_subset_list::parse ( - riscv_profiles_table[i].profile_string, NULL); - if (!subset_list) - continue; - if (subset_list->xlen () == this->xlen ()) - { - int ext_count = 0; - bool all_found = true; - for (riscv_subset_t *p = subset_list->m_head; p != NULL; - p = p->next, ++ext_count) - { - if (!this->lookup (p->name.c_str (), - p->major_version, - p->minor_version)) - { - all_found = false; - break; - } - } - if (all_found && ext_count > max_ext_count) - { - max_ext_count = ext_count; - best_profile = riscv_profiles_table[i].profile_name; - } - } - delete subset_list; - } - return best_profile; -} - /* Clone whole subset list. */ riscv_subset_list * diff --git a/gcc/config.gcc b/gcc/config.gcc index b46cea869cbd..e17354b3e654 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -359,7 +359,7 @@ aarch64*-*-*) c_target_objs="aarch64-c.o" cxx_target_objs="aarch64-c.o" d_target_objs="aarch64-d.o" - extra_objs="aarch64-builtins.o aarch-common.o aarch64-elf-metadata.o aarch64-sve-builtins.o aarch64-sve-builtins-shapes.o aarch64-sve-builtins-base.o aarch64-sve-builtins-sve2.o aarch64-sve-builtins-sme.o cortex-a57-fma-steering.o aarch64-speculation.o aarch-bti-insert.o aarch64-early-ra.o aarch64-ldp-fusion.o aarch64-sched-dispatch.o" + extra_objs="aarch64-builtins.o aarch-common.o aarch64-elf-metadata.o aarch64-sve-builtins.o aarch64-sve-builtins-shapes.o aarch64-sve-builtins-base.o aarch64-sve-builtins-sve2.o aarch64-sve-builtins-sme.o cortex-a57-fma-steering.o aarch64-speculation.o aarch-bti-insert.o aarch64-early-ra.o aarch64-ldp-fusion.o aarch64-sched-dispatch.o aarch64-json-tunings-printer.o aarch64-json-tunings-parser.o" target_gtfiles="\$(srcdir)/config/aarch64/aarch64-protos.h \$(srcdir)/config/aarch64/aarch64-builtins.h \$(srcdir)/config/aarch64/aarch64-builtins.cc \$(srcdir)/config/aarch64/aarch64-sve-builtins.h \$(srcdir)/config/aarch64/aarch64-sve-builtins.cc" target_has_targetm_common=yes ;; @@ -4640,14 +4640,14 @@ case "${target}" in exit 1 fi done - [ "x$with_arch" = x ] && with_arch=gfx900 + [ "x$with_arch" = x ] && with_arch=gfx90a case "x${with_multilib_list}" in x | xno) TM_MULTILIB_CONFIG= ;; xdefault | xyes) - TM_MULTILIB_CONFIG=`echo "gfx900,gfx906,gfx908,gfx90a,gfx90c,gfx1030,gfx1036,gfx1100,gfx1103" | sed "s/${with_arch},\?//;s/,$//"` + TM_MULTILIB_CONFIG=`echo "gfx908,gfx90a,gfx9-generic,gfx9-4-generic,gfx10-3-generic,gfx11-generic" | sed "s/${with_arch},\?//;s/,$//"` ;; *) TM_MULTILIB_CONFIG="${with_multilib_list}" @@ -4753,7 +4753,7 @@ case "${target}" in ;; riscv*-*-*) - supported_defaults="abi arch tune riscv_attribute isa_spec tls cmodel" + supported_defaults="abi arch cpu tune riscv_attribute isa_spec tls cmodel" case "${target}" in riscv-* | riscv32*) xlen=32 ;; diff --git a/gcc/config/aarch64/aarch64-c.cc b/gcc/config/aarch64/aarch64-c.cc index c3957c762eff..de4444bacb79 100644 --- a/gcc/config/aarch64/aarch64-c.cc +++ b/gcc/config/aarch64/aarch64-c.cc @@ -65,6 +65,11 @@ aarch64_define_unconditional_macros (cpp_reader *pfile) builtin_define_with_int_value ("__ARM_ARCH_PROFILE", TARGET_V8R ? 'R' : 'A'); + +#if HAVE_AS_AEABI_BUILD_ATTRIBUTES + builtin_define_with_int_value ("__ARM_BUILDATTR64_FV", 'A'); +#endif + builtin_define ("__ARM_FEATURE_CLZ"); builtin_define ("__ARM_FEATURE_IDIV"); builtin_define ("__ARM_FEATURE_UNALIGNED"); diff --git a/gcc/config/aarch64/aarch64-generate-json-tuning-routines.py b/gcc/config/aarch64/aarch64-generate-json-tuning-routines.py new file mode 100755 index 000000000000..a4f9e4ece71a --- /dev/null +++ b/gcc/config/aarch64/aarch64-generate-json-tuning-routines.py @@ -0,0 +1,383 @@ +#!/usr/bin/env python3 + +# Script to autogenerate the parsing and serialization routines for the +# aarch64 JSON tuning parameters. +# +# Copyright The GNU Toolchain Authors. +# +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 3, or (at your option) any later +# version. +# +# GCC is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +DESCRIPTION = """ +Maintenance script to regenerate aarch64-json-tunings-*-generated.inc files +from the JSON schema in aarch64-json-schema.h. + +This script is run automatically whenever aarch64-json-schema.h is modified. + +Usage: + + python3 /aarch64-generate-json-tuning-routines.py [options] + +Options: + --generate-only Generate only parser or printer file. + If not specified, generates both. + +Note that the script can be called from any directory. + +Generates (in gcc/config/aarch64/): + aarch64-json-tunings-parser-generated.inc + aarch64-json-tunings-printer-generated.inc +""" + +import json +import re +import os +import argparse +from typing import Dict, Any, List, Tuple + +def extract_schema_from_header(file_path: str) -> str: + with open(file_path, "r") as f: + content = f.read() + + # Find the schema_json variable content between R"json( and )json" + pattern = r'static const char \*schema_json = R"json\((.*?)\)json";' + match = re.search(pattern, content, re.DOTALL) + + if not match: + raise ValueError("Could not find schema_json in header file") + + return match.group(1).strip() + +def get_macro(operation: str, field_type: str) -> str: + type_map = { + "int": "INTEGER", + "uint": "UNSIGNED_INTEGER", + "boolean": "BOOLEAN", + "string": "STRING", + "enum": "ENUM", + } + if field_type not in type_map: + raise ValueError(f"Unknown field type: {field_type}") + return f"{operation}_{type_map[field_type]}_FIELD" + +def generate_field_code( + operation: str, + key: str, + value: Any, + struct_name: str, + current_path: List[str], + function_map: Dict[str, str], + obj_name: str = "jo", + indent: str = " ", +) -> List[str]: + lines = [] + + if isinstance(value, str): + macro = get_macro(operation.upper(), value) + if value == "enum": + enum_mapping = f"{key}_mappings" + lines.append( + f'{indent}{macro} ({obj_name}, "{key}", {struct_name}.{key}, {enum_mapping});' + ) + else: + lines.append(f'{indent}{macro} ({obj_name}, "{key}", {struct_name}.{key});') + + elif isinstance(value, dict): + # Nested object - find function name based on current context + key + child_path = current_path + [key] + child_path_key = "_".join(child_path) + func_name = function_map.get(child_path_key, f"{operation.lower()}_{key}") + macro_name = f"{operation.upper()}_OBJECT" + lines.append( + f'{indent}{macro_name} ({obj_name}, "{key}", {struct_name}.{key}, {func_name});' + ) + + elif isinstance(value, list) and len(value) > 0: + if isinstance(value[0], dict): + element_key = f"{key}_element" + element_path = current_path + [element_key] + element_path_key = "_".join(element_path) + func_name = function_map.get( + element_path_key, f"{operation.lower()}_{element_key}" + ) + macro_name = f"{operation.upper()}_ARRAY_FIELD" + + if operation.lower() == "serialize": + lines.append( + f'{indent}{macro_name} ({obj_name}, "{key}", {struct_name}.{key}, ARRAY_SIZE ({struct_name}.{key}), {func_name});' + ) + else: + lines.append( + f'{indent}{macro_name} ({obj_name}, "{key}", {struct_name}.{key}, {func_name});' + ) + else: + raise ValueError(f"Arrays of non-object types are not yet supported: {key}") + else: + raise ValueError(f"Unhandled field type for key '{key}': {type(value)}") + + return lines + +def generate_field_parsing( + key: str, + value: Any, + struct_name: str, + current_path: List[str], + function_map: Dict[str, str], + indent: str = " ", +) -> List[str]: + return generate_field_code( + "parse", key, value, struct_name, current_path, function_map, "jo", indent + ) + +def generate_field_serialization( + key: str, + value: Any, + struct_name: str, + obj_name: str, + current_path: List[str], + function_map: Dict[str, str], + indent: str = " ", +) -> List[str]: + return generate_field_code( + "serialize", + key, + value, + struct_name, + current_path, + function_map, + obj_name, + indent, + ) + +def generate_function( + operation: str, + full_name: str, + local_name: str, + schema: Dict[str, Any], + current_path: List[str], + function_map: Dict[str, str], +) -> List[str]: + lines = [] + lines.append("template ") + + if operation.lower() == "parse": + lines.append("static void") + lines.append(f"parse_{full_name} (const json::object *jo, T &{local_name})") + lines.append("{") + + for key, value in schema.items(): + field_lines = generate_field_parsing( + key, value, local_name, current_path, function_map + ) + lines.extend(field_lines) + + elif operation.lower() == "serialize": + lines.append("static std::unique_ptr") + lines.append(f"serialize_{full_name} (const T &{local_name})") + lines.append("{") + lines.append(f" auto {local_name}_obj = std::make_unique ();") + lines.append("") + + for key, value in schema.items(): + field_lines = generate_field_serialization( + key, value, local_name, f"{local_name}_obj", current_path, function_map + ) + lines.extend(field_lines) + + lines.append("") + lines.append(f" return {local_name}_obj;") + + lines.append("}") + + return lines + +"""Collect all object schemas with their full paths. This is necessary for +generating names for the routines with the correct hierarchal path to ensure +that identical keys in different structures are not given the same name. +For example: +vec_costs.issue_info.sve maps to _vec_costs_issue_info_sve +vec_costs.sve maps to _vec_costs_sve. +""" +def collect_all_objects_with_paths( + schema: Dict[str, Any], path: List[str] = [] +) -> Dict[str, Tuple[List[str], Dict[str, Any]]]: + objects = {} + + for key, value in schema.items(): + current_path = path + [key] + + if isinstance(value, dict): + path_key = "_".join(current_path) + objects[path_key] = (current_path, value) + nested = collect_all_objects_with_paths(value, current_path) + objects.update(nested) + + elif isinstance(value, list) and len(value) > 0 and isinstance(value[0], dict): + element_key = key.rstrip("s") if key.endswith("s") else f"{key}_element" + element_path = current_path[:-1] + [element_key] + element_path_key = "_".join(element_path) + objects[element_path_key] = (element_path, value[0]) + nested = collect_all_objects_with_paths(value[0], element_path) + objects.update(nested) + + return objects + +"""Calculate dependency depth of an object schema. 0 indicates no +dependencies, ie. the object has only primitive types.""" +def get_dependency_depth(obj_schema: Dict[str, Any]) -> int: + max_depth = 0 + for value in obj_schema.values(): + if isinstance(value, dict): + max_depth = max(max_depth, 1 + get_dependency_depth(value)) + elif isinstance(value, list) and len(value) > 0 and isinstance(value[0], dict): + max_depth = max(max_depth, 1 + get_dependency_depth(value[0])) + return max_depth + +def generate_enum_mappings(operation: str) -> str: + mappings = f""" +static const enum_mapping + autoprefetcher_model_mappings[] = {{ +#define AARCH64_AUTOPREFETCH_MODE(NAME, ENUM_VALUE) {{NAME, tune_params::ENUM_VALUE}}, +#include "aarch64-tuning-enums.def" +}}; + +static const enum_mapping ldp_policy_model_mappings[] = {{ +#define AARCH64_LDP_STP_POLICY(NAME, ENUM_VALUE) {{NAME, ENUM_VALUE}}, +#include "aarch64-tuning-enums.def" +}}; + +static const enum_mapping stp_policy_model_mappings[] = {{ +#define AARCH64_LDP_STP_POLICY(NAME, ENUM_VALUE) {{NAME, ENUM_VALUE}}, +#include "aarch64-tuning-enums.def" +}}; +""" + return mappings + +def generate_all_functions(schema_file: str, operation: str) -> str: + schema_str = extract_schema_from_header(schema_file) + schema = json.loads(schema_str) + tune_params_schema = schema.get("tune_params", {}) + + all_objects_with_paths = collect_all_objects_with_paths(tune_params_schema) + + function_map = {} + for path_key, (path, obj_schema) in all_objects_with_paths.items(): + if path: + full_name = "_".join(path) + function_map[path_key] = f"{operation}_{full_name}" + else: + function_map[path_key] = f"{operation}_{path_key}" + + """ Structures can have nested structures that may not have been defined yet. + Therefore, we need to sort the objects by dependency depth and define + functions for the inner structures first.""" + sorted_objects = sorted( + all_objects_with_paths.items(), key=lambda x: get_dependency_depth(x[1][1]) + ) + + generated_functions = [] + generated_functions.append(generate_enum_mappings(operation)) + + for path_key, (path, obj_schema) in sorted_objects: + # Use the full path for function generation + if path: + full_name = "_".join(path) + local_name = path[-1] + else: + full_name = path_key + local_name = path_key + + function_str = generate_function( + operation, full_name, local_name, obj_schema, path, function_map + ) + generated_functions.append("\n".join(function_str)) + + main_function = generate_function( + operation, "tunings", "tunings", tune_params_schema, [], function_map + ) + generated_functions.append("\n".join(main_function)) + return "\n\n".join(generated_functions) + +def write_generated_include_file( + output_file_path: str, generated_code: str, operation: str +) -> None: + header_comment = f"""/* This file is auto-generated by aarch64-generate-json-tuning-routines.py. */ +/* Copyright The GNU Toolchain Authors. + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 3, or (at your option) any later + version. + + GCC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* This file contains the auto-generated {operation} functions for JSON tuning parameters. */ + +""" + + try: + with open(output_file_path, "w") as f: + f.write(header_comment) + f.write(generated_code) + print(f"Successfully generated {output_file_path}") + except Exception as e: + print(f"Error writing to {output_file_path}: {e}") + +def main(): + parser = argparse.ArgumentParser() + parser.add_argument('--generate-only', + choices=['parser', 'printer'], + help='Generate only parser or printer file. If not specified, generates both.') + args = parser.parse_args() + + try: + script_dir = os.path.dirname(os.path.abspath(__file__)) + + schema_file = os.path.join(script_dir, "aarch64-json-schema.h") + parser_inc_file = os.path.join( + script_dir, "aarch64-json-tunings-parser-generated.inc" + ) + printer_inc_file = os.path.join( + script_dir, "aarch64-json-tunings-printer-generated.inc" + ) + if args.generate_only is None or args.generate_only == 'parser': + parser_generated_code = generate_all_functions(schema_file, "parse") + write_generated_include_file(parser_inc_file, parser_generated_code, "parser") + + if args.generate_only is None or args.generate_only == 'printer': + serializer_generated_code = generate_all_functions(schema_file, "serialize") + write_generated_include_file( + printer_inc_file, serializer_generated_code, "serializer" + ) + + print(f"Generated files in: {script_dir}") + + except Exception as e: + print(f"Error: {e}") + return 1 + + return 0 + +if __name__ == "__main__": + exit(main()) diff --git a/gcc/config/aarch64/aarch64-json-schema.h b/gcc/config/aarch64/aarch64-json-schema.h new file mode 100644 index 000000000000..0c1863fad18a --- /dev/null +++ b/gcc/config/aarch64/aarch64-json-schema.h @@ -0,0 +1,264 @@ +/* Raw JSON schema for the AArch64 tuning parameters. + Copyright The GNU Toolchain Authors. + + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#ifndef AARCH64_JSON_SCHEMA_H +#define AARCH64_JSON_SCHEMA_H + +static const char *schema_json = R"json( +{ + "metadata": { + "gcc_version": "int" + }, + "tune_params": { + "insn_extra_cost": { + "alu": { + "arith": "int", + "logical": "int", + "shift": "int", + "shift_reg": "int", + "arith_shift": "int", + "arith_shift_reg": "int", + "log_shift": "int", + "log_shift_reg": "int", + "extend": "int", + "extend_arith": "int", + "bfi": "int", + "bfx": "int", + "clz": "int", + "rev": "int", + "non_exec": "int", + "non_exec_costs_exec": "boolean" + }, + "mult": [ + { + "simple": "int", + "flag_setting": "int", + "extend": "int", + "add": "int", + "extend_add": "int", + "idiv": "int" + }, + { + "simple": "int", + "flag_setting": "int", + "extend": "int", + "add": "int", + "extend_add": "int", + "idiv": "int" + } + ], + "ldst": { + "load": "int", + "load_sign_extend": "int", + "ldrd": "int", + "ldm_1st": "int", + "ldm_regs_per_insn_1st": "int", + "ldm_regs_per_insn_subsequent": "int", + "loadf": "int", + "loadd": "int", + "load_unaligned": "int", + "store": "int", + "strd": "int", + "stm_1st": "int", + "stm_regs_per_insn_1st": "int", + "stm_regs_per_insn_subsequent": "int", + "storef": "int", + "stored": "int", + "store_unaligned": "int", + "loadv": "int", + "storev": "int" + }, + "fp": [ + { + "div": "int", + "mult": "int", + "mult_addsub": "int", + "fma": "int", + "addsub": "int", + "fpconst": "int", + "neg": "int", + "compare": "int", + "widen": "int", + "narrow": "int", + "toint": "int", + "fromint": "int", + "roundint": "int" + }, + { + "div": "int", + "mult": "int", + "mult_addsub": "int", + "fma": "int", + "addsub": "int", + "fpconst": "int", + "neg": "int", + "compare": "int", + "widen": "int", + "narrow": "int", + "toint": "int", + "fromint": "int", + "roundint": "int" + } + ], + "vect": { + "alu": "int", + "mult": "int", + "movi": "int", + "dup": "int", + "extract": "int" + } + }, + "addr_cost": { + "addr_scale_costs": { + "hi": "int", + "si": "int", + "di": "int", + "ti": "int" + }, + "pre_modify": "int", + "post_modify": "int", + "post_modify_ld3_st3": "int", + "post_modify_ld4_st4": "int", + "register_offset": "int", + "register_sextend": "int", + "register_zextend": "int", + "imm_offset": "int" + }, + "regmove_cost": { + "GP2GP": "int", + "GP2FP": "int", + "FP2GP": "int", + "FP2FP": "int" + }, + "vec_costs": { + "scalar_int_stmt_cost": "int", + "scalar_fp_stmt_cost": "int", + "scalar_load_cost": "int", + "scalar_store_cost": "int", + "cond_taken_branch_cost": "int", + "cond_not_taken_branch_cost": "int", + "advsimd": { + "int_stmt_cost": "int", + "fp_stmt_cost": "int", + "ld2_st2_permute_cost": "int", + "ld3_st3_permute_cost": "int", + "ld4_st4_permute_cost": "int", + "permute_cost": "int", + "reduc_i8_cost": "int", + "reduc_i16_cost": "int", + "reduc_i32_cost": "int", + "reduc_i64_cost": "int", + "reduc_f16_cost": "int", + "reduc_f32_cost": "int", + "reduc_f64_cost": "int", + "store_elt_extra_cost": "int", + "vec_to_scalar_cost": "int", + "scalar_to_vec_cost": "int", + "align_load_cost": "int", + "unalign_load_cost": "int", + "unalign_store_cost": "int", + "store_cost": "int" + }, + "sve": { + "clast_cost": "int", + "fadda_f16_cost": "int", + "fadda_f32_cost": "int", + "fadda_f64_cost": "int", + "gather_load_x32_cost": "uint", + "gather_load_x64_cost": "uint", + "gather_load_x32_init_cost": "int", + "gather_load_x64_init_cost": "int", + "scatter_store_elt_cost": "int" + }, + "issue_info": { + "scalar": { + "loads_stores_per_cycle": "uint", + "stores_per_cycle": "uint", + "general_ops_per_cycle": "uint", + "fp_simd_load_general_ops": "uint", + "fp_simd_store_general_ops": "uint" + }, + "advsimd": { + "loads_stores_per_cycle": "uint", + "stores_per_cycle": "uint", + "general_ops_per_cycle": "uint", + "fp_simd_load_general_ops": "uint", + "fp_simd_store_general_ops": "uint", + "ld2_st2_general_ops": "uint", + "ld3_st3_general_ops": "uint", + "ld4_st4_general_ops": "uint" + }, + "sve": { + "loads_stores_per_cycle": "uint", + "stores_per_cycle": "uint", + "general_ops_per_cycle": "uint", + "fp_simd_load_general_ops": "uint", + "fp_simd_store_general_ops": "uint", + "ld2_st2_general_ops": "uint", + "ld3_st3_general_ops": "uint", + "ld4_st4_general_ops": "uint", + "pred_ops_per_cycle": "uint", + "while_pred_ops": "uint", + "int_cmp_pred_ops": "uint", + "fp_cmp_pred_ops": "uint", + "gather_scatter_pair_general_ops": "uint", + "gather_scatter_pair_pred_ops": "uint" + } + } + }, + "branch_costs": { "predictable": "int", "unpredictable": "int" }, + "approx_modes": { "division": "int", "sqrt": "int", "recip_sqrt": "int" }, + "sve_width": "uint", + "memmov_cost": { + "load_int": "int", + "store_int": "int", + "load_fp": "int", + "store_fp": "int", + "load_pred": "int", + "store_pred": "int" + }, + "issue_rate": "int", + "fusible_ops": "uint", + "function_align": "string", + "jump_align": "string", + "loop_align": "string", + "int_reassoc_width": "int", + "fp_reassoc_width": "int", + "fma_reassoc_width": "int", + "vec_reassoc_width": "int", + "min_div_recip_mul_sf": "int", + "min_div_recip_mul_df": "int", + "max_case_values": "uint", + "autoprefetcher_model": "enum", + "extra_tuning_flags": "uint", + "prefetch": { + "num_slots": "int", + "l1_cache_size": "int", + "l1_cache_line_size": "int", + "l2_cache_size": "int", + "prefetch_dynamic_strides": "boolean", + "minimum_stride": "int", + "default_opt_level": "int" + }, + "ldp_policy_model": "enum", + "stp_policy_model": "enum" + } +})json"; + +#endif \ No newline at end of file diff --git a/gcc/config/aarch64/aarch64-json-tunings-parser-generated.inc b/gcc/config/aarch64/aarch64-json-tunings-parser-generated.inc new file mode 100644 index 000000000000..cf31e539d3ba --- /dev/null +++ b/gcc/config/aarch64/aarch64-json-tunings-parser-generated.inc @@ -0,0 +1,355 @@ +/* This file is auto-generated by aarch64-generate-json-tuning-routines.py. */ +/* Copyright The GNU Toolchain Authors. + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 3, or (at your option) any later + version. + + GCC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* This file contains the auto-generated parser functions for JSON tuning parameters. */ + + +static const enum_mapping + autoprefetcher_model_mappings[] = { +#define AARCH64_AUTOPREFETCH_MODE(NAME, ENUM_VALUE) {NAME, tune_params::ENUM_VALUE}, +#include "aarch64-tuning-enums.def" +}; + +static const enum_mapping ldp_policy_model_mappings[] = { +#define AARCH64_LDP_STP_POLICY(NAME, ENUM_VALUE) {NAME, ENUM_VALUE}, +#include "aarch64-tuning-enums.def" +}; + +static const enum_mapping stp_policy_model_mappings[] = { +#define AARCH64_LDP_STP_POLICY(NAME, ENUM_VALUE) {NAME, ENUM_VALUE}, +#include "aarch64-tuning-enums.def" +}; + + +template +static void +parse_insn_extra_cost_alu (const json::object *jo, T &alu) +{ + PARSE_INTEGER_FIELD (jo, "arith", alu.arith); + PARSE_INTEGER_FIELD (jo, "logical", alu.logical); + PARSE_INTEGER_FIELD (jo, "shift", alu.shift); + PARSE_INTEGER_FIELD (jo, "shift_reg", alu.shift_reg); + PARSE_INTEGER_FIELD (jo, "arith_shift", alu.arith_shift); + PARSE_INTEGER_FIELD (jo, "arith_shift_reg", alu.arith_shift_reg); + PARSE_INTEGER_FIELD (jo, "log_shift", alu.log_shift); + PARSE_INTEGER_FIELD (jo, "log_shift_reg", alu.log_shift_reg); + PARSE_INTEGER_FIELD (jo, "extend", alu.extend); + PARSE_INTEGER_FIELD (jo, "extend_arith", alu.extend_arith); + PARSE_INTEGER_FIELD (jo, "bfi", alu.bfi); + PARSE_INTEGER_FIELD (jo, "bfx", alu.bfx); + PARSE_INTEGER_FIELD (jo, "clz", alu.clz); + PARSE_INTEGER_FIELD (jo, "rev", alu.rev); + PARSE_INTEGER_FIELD (jo, "non_exec", alu.non_exec); + PARSE_BOOLEAN_FIELD (jo, "non_exec_costs_exec", alu.non_exec_costs_exec); +} + +template +static void +parse_insn_extra_cost_mult_element (const json::object *jo, T &mult_element) +{ + PARSE_INTEGER_FIELD (jo, "simple", mult_element.simple); + PARSE_INTEGER_FIELD (jo, "flag_setting", mult_element.flag_setting); + PARSE_INTEGER_FIELD (jo, "extend", mult_element.extend); + PARSE_INTEGER_FIELD (jo, "add", mult_element.add); + PARSE_INTEGER_FIELD (jo, "extend_add", mult_element.extend_add); + PARSE_INTEGER_FIELD (jo, "idiv", mult_element.idiv); +} + +template +static void +parse_insn_extra_cost_ldst (const json::object *jo, T &ldst) +{ + PARSE_INTEGER_FIELD (jo, "load", ldst.load); + PARSE_INTEGER_FIELD (jo, "load_sign_extend", ldst.load_sign_extend); + PARSE_INTEGER_FIELD (jo, "ldrd", ldst.ldrd); + PARSE_INTEGER_FIELD (jo, "ldm_1st", ldst.ldm_1st); + PARSE_INTEGER_FIELD (jo, "ldm_regs_per_insn_1st", ldst.ldm_regs_per_insn_1st); + PARSE_INTEGER_FIELD (jo, "ldm_regs_per_insn_subsequent", ldst.ldm_regs_per_insn_subsequent); + PARSE_INTEGER_FIELD (jo, "loadf", ldst.loadf); + PARSE_INTEGER_FIELD (jo, "loadd", ldst.loadd); + PARSE_INTEGER_FIELD (jo, "load_unaligned", ldst.load_unaligned); + PARSE_INTEGER_FIELD (jo, "store", ldst.store); + PARSE_INTEGER_FIELD (jo, "strd", ldst.strd); + PARSE_INTEGER_FIELD (jo, "stm_1st", ldst.stm_1st); + PARSE_INTEGER_FIELD (jo, "stm_regs_per_insn_1st", ldst.stm_regs_per_insn_1st); + PARSE_INTEGER_FIELD (jo, "stm_regs_per_insn_subsequent", ldst.stm_regs_per_insn_subsequent); + PARSE_INTEGER_FIELD (jo, "storef", ldst.storef); + PARSE_INTEGER_FIELD (jo, "stored", ldst.stored); + PARSE_INTEGER_FIELD (jo, "store_unaligned", ldst.store_unaligned); + PARSE_INTEGER_FIELD (jo, "loadv", ldst.loadv); + PARSE_INTEGER_FIELD (jo, "storev", ldst.storev); +} + +template +static void +parse_insn_extra_cost_fp_element (const json::object *jo, T &fp_element) +{ + PARSE_INTEGER_FIELD (jo, "div", fp_element.div); + PARSE_INTEGER_FIELD (jo, "mult", fp_element.mult); + PARSE_INTEGER_FIELD (jo, "mult_addsub", fp_element.mult_addsub); + PARSE_INTEGER_FIELD (jo, "fma", fp_element.fma); + PARSE_INTEGER_FIELD (jo, "addsub", fp_element.addsub); + PARSE_INTEGER_FIELD (jo, "fpconst", fp_element.fpconst); + PARSE_INTEGER_FIELD (jo, "neg", fp_element.neg); + PARSE_INTEGER_FIELD (jo, "compare", fp_element.compare); + PARSE_INTEGER_FIELD (jo, "widen", fp_element.widen); + PARSE_INTEGER_FIELD (jo, "narrow", fp_element.narrow); + PARSE_INTEGER_FIELD (jo, "toint", fp_element.toint); + PARSE_INTEGER_FIELD (jo, "fromint", fp_element.fromint); + PARSE_INTEGER_FIELD (jo, "roundint", fp_element.roundint); +} + +template +static void +parse_insn_extra_cost_vect (const json::object *jo, T &vect) +{ + PARSE_INTEGER_FIELD (jo, "alu", vect.alu); + PARSE_INTEGER_FIELD (jo, "mult", vect.mult); + PARSE_INTEGER_FIELD (jo, "movi", vect.movi); + PARSE_INTEGER_FIELD (jo, "dup", vect.dup); + PARSE_INTEGER_FIELD (jo, "extract", vect.extract); +} + +template +static void +parse_addr_cost_addr_scale_costs (const json::object *jo, T &addr_scale_costs) +{ + PARSE_INTEGER_FIELD (jo, "hi", addr_scale_costs.hi); + PARSE_INTEGER_FIELD (jo, "si", addr_scale_costs.si); + PARSE_INTEGER_FIELD (jo, "di", addr_scale_costs.di); + PARSE_INTEGER_FIELD (jo, "ti", addr_scale_costs.ti); +} + +template +static void +parse_regmove_cost (const json::object *jo, T ®move_cost) +{ + PARSE_INTEGER_FIELD (jo, "GP2GP", regmove_cost.GP2GP); + PARSE_INTEGER_FIELD (jo, "GP2FP", regmove_cost.GP2FP); + PARSE_INTEGER_FIELD (jo, "FP2GP", regmove_cost.FP2GP); + PARSE_INTEGER_FIELD (jo, "FP2FP", regmove_cost.FP2FP); +} + +template +static void +parse_vec_costs_advsimd (const json::object *jo, T &advsimd) +{ + PARSE_INTEGER_FIELD (jo, "int_stmt_cost", advsimd.int_stmt_cost); + PARSE_INTEGER_FIELD (jo, "fp_stmt_cost", advsimd.fp_stmt_cost); + PARSE_INTEGER_FIELD (jo, "ld2_st2_permute_cost", advsimd.ld2_st2_permute_cost); + PARSE_INTEGER_FIELD (jo, "ld3_st3_permute_cost", advsimd.ld3_st3_permute_cost); + PARSE_INTEGER_FIELD (jo, "ld4_st4_permute_cost", advsimd.ld4_st4_permute_cost); + PARSE_INTEGER_FIELD (jo, "permute_cost", advsimd.permute_cost); + PARSE_INTEGER_FIELD (jo, "reduc_i8_cost", advsimd.reduc_i8_cost); + PARSE_INTEGER_FIELD (jo, "reduc_i16_cost", advsimd.reduc_i16_cost); + PARSE_INTEGER_FIELD (jo, "reduc_i32_cost", advsimd.reduc_i32_cost); + PARSE_INTEGER_FIELD (jo, "reduc_i64_cost", advsimd.reduc_i64_cost); + PARSE_INTEGER_FIELD (jo, "reduc_f16_cost", advsimd.reduc_f16_cost); + PARSE_INTEGER_FIELD (jo, "reduc_f32_cost", advsimd.reduc_f32_cost); + PARSE_INTEGER_FIELD (jo, "reduc_f64_cost", advsimd.reduc_f64_cost); + PARSE_INTEGER_FIELD (jo, "store_elt_extra_cost", advsimd.store_elt_extra_cost); + PARSE_INTEGER_FIELD (jo, "vec_to_scalar_cost", advsimd.vec_to_scalar_cost); + PARSE_INTEGER_FIELD (jo, "scalar_to_vec_cost", advsimd.scalar_to_vec_cost); + PARSE_INTEGER_FIELD (jo, "align_load_cost", advsimd.align_load_cost); + PARSE_INTEGER_FIELD (jo, "unalign_load_cost", advsimd.unalign_load_cost); + PARSE_INTEGER_FIELD (jo, "unalign_store_cost", advsimd.unalign_store_cost); + PARSE_INTEGER_FIELD (jo, "store_cost", advsimd.store_cost); +} + +template +static void +parse_vec_costs_sve (const json::object *jo, T &sve) +{ + PARSE_INTEGER_FIELD (jo, "clast_cost", sve.clast_cost); + PARSE_INTEGER_FIELD (jo, "fadda_f16_cost", sve.fadda_f16_cost); + PARSE_INTEGER_FIELD (jo, "fadda_f32_cost", sve.fadda_f32_cost); + PARSE_INTEGER_FIELD (jo, "fadda_f64_cost", sve.fadda_f64_cost); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "gather_load_x32_cost", sve.gather_load_x32_cost); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "gather_load_x64_cost", sve.gather_load_x64_cost); + PARSE_INTEGER_FIELD (jo, "gather_load_x32_init_cost", sve.gather_load_x32_init_cost); + PARSE_INTEGER_FIELD (jo, "gather_load_x64_init_cost", sve.gather_load_x64_init_cost); + PARSE_INTEGER_FIELD (jo, "scatter_store_elt_cost", sve.scatter_store_elt_cost); +} + +template +static void +parse_vec_costs_issue_info_scalar (const json::object *jo, T &scalar) +{ + PARSE_UNSIGNED_INTEGER_FIELD (jo, "loads_stores_per_cycle", scalar.loads_stores_per_cycle); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "stores_per_cycle", scalar.stores_per_cycle); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "general_ops_per_cycle", scalar.general_ops_per_cycle); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "fp_simd_load_general_ops", scalar.fp_simd_load_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "fp_simd_store_general_ops", scalar.fp_simd_store_general_ops); +} + +template +static void +parse_vec_costs_issue_info_advsimd (const json::object *jo, T &advsimd) +{ + PARSE_UNSIGNED_INTEGER_FIELD (jo, "loads_stores_per_cycle", advsimd.loads_stores_per_cycle); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "stores_per_cycle", advsimd.stores_per_cycle); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "general_ops_per_cycle", advsimd.general_ops_per_cycle); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "fp_simd_load_general_ops", advsimd.fp_simd_load_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "fp_simd_store_general_ops", advsimd.fp_simd_store_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "ld2_st2_general_ops", advsimd.ld2_st2_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "ld3_st3_general_ops", advsimd.ld3_st3_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "ld4_st4_general_ops", advsimd.ld4_st4_general_ops); +} + +template +static void +parse_vec_costs_issue_info_sve (const json::object *jo, T &sve) +{ + PARSE_UNSIGNED_INTEGER_FIELD (jo, "loads_stores_per_cycle", sve.loads_stores_per_cycle); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "stores_per_cycle", sve.stores_per_cycle); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "general_ops_per_cycle", sve.general_ops_per_cycle); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "fp_simd_load_general_ops", sve.fp_simd_load_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "fp_simd_store_general_ops", sve.fp_simd_store_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "ld2_st2_general_ops", sve.ld2_st2_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "ld3_st3_general_ops", sve.ld3_st3_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "ld4_st4_general_ops", sve.ld4_st4_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "pred_ops_per_cycle", sve.pred_ops_per_cycle); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "while_pred_ops", sve.while_pred_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "int_cmp_pred_ops", sve.int_cmp_pred_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "fp_cmp_pred_ops", sve.fp_cmp_pred_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "gather_scatter_pair_general_ops", sve.gather_scatter_pair_general_ops); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "gather_scatter_pair_pred_ops", sve.gather_scatter_pair_pred_ops); +} + +template +static void +parse_branch_costs (const json::object *jo, T &branch_costs) +{ + PARSE_INTEGER_FIELD (jo, "predictable", branch_costs.predictable); + PARSE_INTEGER_FIELD (jo, "unpredictable", branch_costs.unpredictable); +} + +template +static void +parse_approx_modes (const json::object *jo, T &approx_modes) +{ + PARSE_INTEGER_FIELD (jo, "division", approx_modes.division); + PARSE_INTEGER_FIELD (jo, "sqrt", approx_modes.sqrt); + PARSE_INTEGER_FIELD (jo, "recip_sqrt", approx_modes.recip_sqrt); +} + +template +static void +parse_memmov_cost (const json::object *jo, T &memmov_cost) +{ + PARSE_INTEGER_FIELD (jo, "load_int", memmov_cost.load_int); + PARSE_INTEGER_FIELD (jo, "store_int", memmov_cost.store_int); + PARSE_INTEGER_FIELD (jo, "load_fp", memmov_cost.load_fp); + PARSE_INTEGER_FIELD (jo, "store_fp", memmov_cost.store_fp); + PARSE_INTEGER_FIELD (jo, "load_pred", memmov_cost.load_pred); + PARSE_INTEGER_FIELD (jo, "store_pred", memmov_cost.store_pred); +} + +template +static void +parse_prefetch (const json::object *jo, T &prefetch) +{ + PARSE_INTEGER_FIELD (jo, "num_slots", prefetch.num_slots); + PARSE_INTEGER_FIELD (jo, "l1_cache_size", prefetch.l1_cache_size); + PARSE_INTEGER_FIELD (jo, "l1_cache_line_size", prefetch.l1_cache_line_size); + PARSE_INTEGER_FIELD (jo, "l2_cache_size", prefetch.l2_cache_size); + PARSE_BOOLEAN_FIELD (jo, "prefetch_dynamic_strides", prefetch.prefetch_dynamic_strides); + PARSE_INTEGER_FIELD (jo, "minimum_stride", prefetch.minimum_stride); + PARSE_INTEGER_FIELD (jo, "default_opt_level", prefetch.default_opt_level); +} + +template +static void +parse_insn_extra_cost (const json::object *jo, T &insn_extra_cost) +{ + PARSE_OBJECT (jo, "alu", insn_extra_cost.alu, parse_insn_extra_cost_alu); + PARSE_ARRAY_FIELD (jo, "mult", insn_extra_cost.mult, parse_insn_extra_cost_mult_element); + PARSE_OBJECT (jo, "ldst", insn_extra_cost.ldst, parse_insn_extra_cost_ldst); + PARSE_ARRAY_FIELD (jo, "fp", insn_extra_cost.fp, parse_insn_extra_cost_fp_element); + PARSE_OBJECT (jo, "vect", insn_extra_cost.vect, parse_insn_extra_cost_vect); +} + +template +static void +parse_addr_cost (const json::object *jo, T &addr_cost) +{ + PARSE_OBJECT (jo, "addr_scale_costs", addr_cost.addr_scale_costs, parse_addr_cost_addr_scale_costs); + PARSE_INTEGER_FIELD (jo, "pre_modify", addr_cost.pre_modify); + PARSE_INTEGER_FIELD (jo, "post_modify", addr_cost.post_modify); + PARSE_INTEGER_FIELD (jo, "post_modify_ld3_st3", addr_cost.post_modify_ld3_st3); + PARSE_INTEGER_FIELD (jo, "post_modify_ld4_st4", addr_cost.post_modify_ld4_st4); + PARSE_INTEGER_FIELD (jo, "register_offset", addr_cost.register_offset); + PARSE_INTEGER_FIELD (jo, "register_sextend", addr_cost.register_sextend); + PARSE_INTEGER_FIELD (jo, "register_zextend", addr_cost.register_zextend); + PARSE_INTEGER_FIELD (jo, "imm_offset", addr_cost.imm_offset); +} + +template +static void +parse_vec_costs_issue_info (const json::object *jo, T &issue_info) +{ + PARSE_OBJECT (jo, "scalar", issue_info.scalar, parse_vec_costs_issue_info_scalar); + PARSE_OBJECT (jo, "advsimd", issue_info.advsimd, parse_vec_costs_issue_info_advsimd); + PARSE_OBJECT (jo, "sve", issue_info.sve, parse_vec_costs_issue_info_sve); +} + +template +static void +parse_vec_costs (const json::object *jo, T &vec_costs) +{ + PARSE_INTEGER_FIELD (jo, "scalar_int_stmt_cost", vec_costs.scalar_int_stmt_cost); + PARSE_INTEGER_FIELD (jo, "scalar_fp_stmt_cost", vec_costs.scalar_fp_stmt_cost); + PARSE_INTEGER_FIELD (jo, "scalar_load_cost", vec_costs.scalar_load_cost); + PARSE_INTEGER_FIELD (jo, "scalar_store_cost", vec_costs.scalar_store_cost); + PARSE_INTEGER_FIELD (jo, "cond_taken_branch_cost", vec_costs.cond_taken_branch_cost); + PARSE_INTEGER_FIELD (jo, "cond_not_taken_branch_cost", vec_costs.cond_not_taken_branch_cost); + PARSE_OBJECT (jo, "advsimd", vec_costs.advsimd, parse_vec_costs_advsimd); + PARSE_OBJECT (jo, "sve", vec_costs.sve, parse_vec_costs_sve); + PARSE_OBJECT (jo, "issue_info", vec_costs.issue_info, parse_vec_costs_issue_info); +} + +template +static void +parse_tunings (const json::object *jo, T &tunings) +{ + PARSE_OBJECT (jo, "insn_extra_cost", tunings.insn_extra_cost, parse_insn_extra_cost); + PARSE_OBJECT (jo, "addr_cost", tunings.addr_cost, parse_addr_cost); + PARSE_OBJECT (jo, "regmove_cost", tunings.regmove_cost, parse_regmove_cost); + PARSE_OBJECT (jo, "vec_costs", tunings.vec_costs, parse_vec_costs); + PARSE_OBJECT (jo, "branch_costs", tunings.branch_costs, parse_branch_costs); + PARSE_OBJECT (jo, "approx_modes", tunings.approx_modes, parse_approx_modes); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "sve_width", tunings.sve_width); + PARSE_OBJECT (jo, "memmov_cost", tunings.memmov_cost, parse_memmov_cost); + PARSE_INTEGER_FIELD (jo, "issue_rate", tunings.issue_rate); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "fusible_ops", tunings.fusible_ops); + PARSE_STRING_FIELD (jo, "function_align", tunings.function_align); + PARSE_STRING_FIELD (jo, "jump_align", tunings.jump_align); + PARSE_STRING_FIELD (jo, "loop_align", tunings.loop_align); + PARSE_INTEGER_FIELD (jo, "int_reassoc_width", tunings.int_reassoc_width); + PARSE_INTEGER_FIELD (jo, "fp_reassoc_width", tunings.fp_reassoc_width); + PARSE_INTEGER_FIELD (jo, "fma_reassoc_width", tunings.fma_reassoc_width); + PARSE_INTEGER_FIELD (jo, "vec_reassoc_width", tunings.vec_reassoc_width); + PARSE_INTEGER_FIELD (jo, "min_div_recip_mul_sf", tunings.min_div_recip_mul_sf); + PARSE_INTEGER_FIELD (jo, "min_div_recip_mul_df", tunings.min_div_recip_mul_df); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "max_case_values", tunings.max_case_values); + PARSE_ENUM_FIELD (jo, "autoprefetcher_model", tunings.autoprefetcher_model, autoprefetcher_model_mappings); + PARSE_UNSIGNED_INTEGER_FIELD (jo, "extra_tuning_flags", tunings.extra_tuning_flags); + PARSE_OBJECT (jo, "prefetch", tunings.prefetch, parse_prefetch); + PARSE_ENUM_FIELD (jo, "ldp_policy_model", tunings.ldp_policy_model, ldp_policy_model_mappings); + PARSE_ENUM_FIELD (jo, "stp_policy_model", tunings.stp_policy_model, stp_policy_model_mappings); +} \ No newline at end of file diff --git a/gcc/config/aarch64/aarch64-json-tunings-parser.cc b/gcc/config/aarch64/aarch64-json-tunings-parser.cc new file mode 100644 index 000000000000..59c745e347ef --- /dev/null +++ b/gcc/config/aarch64/aarch64-json-tunings-parser.cc @@ -0,0 +1,630 @@ +/* Routines to parse the AArch64 tuning parameters from a JSON file. + Copyright The GNU Toolchain Authors. + + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_STRING +#define INCLUDE_VECTOR +#define INCLUDE_TYPE_TRAITS +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "diagnostic-core.h" +#include "json-parsing.h" +#include "aarch64-json-schema.h" +#include "aarch64-json-tunings-parser.h" +#include "aarch64-protos.h" +#include "config/arm/aarch-common-protos.h" +#include "selftest.h" +#include "version.h" + +#define PARSE_INTEGER_FIELD(obj, key, member) \ + { \ + const json::value *val = obj->get (key); \ + if (val) \ + member = extract_integer (val); \ + } + +#define PARSE_UNSIGNED_INTEGER_FIELD(obj, key, member) \ + { \ + const json::value *val = obj->get (key); \ + if (val) \ + member = extract_unsigned_integer (val); \ + } + +#define PARSE_BOOLEAN_FIELD(obj, key, member) \ + { \ + const json::value *val = obj->get (key); \ + if (val) \ + member = extract_boolean (val); \ + } + +#define PARSE_STRING_FIELD(obj, key, member) \ + { \ + const json::value *val = obj->get (key); \ + if (val) \ + member = extract_string (val); \ + } + +#define PARSE_OBJECT(obj, key, member, parse_func) \ + { \ + const json::value *field_value = obj->get (key); \ + if (field_value) \ + if (auto *field_obj = dyn_cast (field_value)) \ + parse_object_helper (field_obj, (member), (parse_func)); \ + } + +#define PARSE_ARRAY_FIELD(obj, key, member, parse_func) \ + { \ + const json::value *field_value = obj->get (key); \ + if (field_value) \ + if (auto *field_array = dyn_cast (field_value)) \ + for (size_t i = 0; i < field_array->size (); ++i) \ + { \ + const json::value *elem = field_array->get (i); \ + if (elem) \ + if (auto *array_obj = dyn_cast (elem)) \ + parse_func (array_obj, member[i]); \ + } \ + } + +#define PARSE_ENUM_FIELD(obj, key, member, mappings) \ + parse_enum_field (obj, key, member, mappings, \ + sizeof (mappings) / sizeof (mappings[0])) + +/* Type alias for parse function pointer. */ +template +using parse_func_type + = void (*) (const json::object *, + std::remove_const_t> &); + +/* Parse JSON object into non-pointer member type. */ +template +static std::enable_if_t::value> +parse_object_helper (const json::object *field_obj, T &member, + parse_func_type parse_func) +{ + parse_func (field_obj, member); +} + +/* Parse JSON object into a const pointer member by creating a temp copy. */ +template +static std::enable_if_t::value + && std::is_const>::value> +parse_object_helper (const json::object *field_obj, T &member, + parse_func_type parse_func) +{ + if (!member) + return; + + /* Use static storage for the non-const copy. + This works because tune_params does not have nested structures of the + same type, but has room for errors if we end up having pointers to the + same structure at some point. */ + static bool already_initialized = false; + if (already_initialized) + { + error ("static storage conflict - multiple pointer members of the " + "same type cannot be parsed"); + return; + } + already_initialized = true; + using NonConstType = std::remove_const_t>; + static NonConstType new_obj = *member; + parse_func (field_obj, new_obj); + member = &new_obj; +} + +/* Extract string value from JSON, returning allocated C string. */ +char * +extract_string (const json::value *val) +{ + if (auto *string_val = dyn_cast (val)) + return xstrdup (string_val->get_string ()); + warning (0, "expected a string but got something else or NULL"); + return nullptr; +} + +/* Extract signed integer value from JSON. */ +int +extract_integer (const json::value *val) +{ + if (auto *int_val = dyn_cast (val)) + { + long value = int_val->get (); + gcc_assert (value >= INT_MIN && value <= INT_MAX); + return static_cast (value); + } + warning (0, "expected an integer value but got something else or NULL"); + return 0; +} + +/* Extract unsigned integer value from JSON. */ +unsigned int +extract_unsigned_integer (const json::value *val) +{ + if (auto *int_val = dyn_cast (val)) + { + long value = int_val->get (); + gcc_assert (value >= 0 && value <= UINT_MAX); + return static_cast (value); + } + warning (0, + "expected an unsigned integer value but got something else or NULL"); + return 0; +} + +/* Extract boolean value from JSON literal. */ +bool +extract_boolean (const json::value *val) +{ + if (auto *literal_val = dyn_cast (val)) + { + json::kind kind = literal_val->get_kind (); + if (kind == json::JSON_TRUE || kind == json::JSON_FALSE) + return (kind == json::JSON_TRUE); + } + warning (0, "expected a boolean value but got something else or NULL"); + return false; +} + +template struct enum_mapping +{ + const char *name; + EnumType value; +}; + +/* Parse JSON string field into enum value using string-to-enum mappings. */ +template +static void +parse_enum_field (const json::object *jo, const std::string &key, + EnumType &enum_var, const enum_mapping *mappings, + size_t num_mappings) +{ + const json::value *field_value = jo->get (key.c_str ()); + if (!field_value) + return; + + auto *string_val = dyn_cast (field_value); + if (!string_val) + { + warning (0, "expected string for enum field %s", key.c_str ()); + enum_var = mappings[0].value; + return; + } + + const char *field_string = string_val->get_string (); + for (size_t i = 0; i < num_mappings; ++i) + { + if (strcmp (field_string, mappings[i].name) == 0) + { + enum_var = mappings[i].value; + return; + } + } + + warning (0, "%s not recognized, defaulting to %qs", key.c_str (), + mappings[0].name); + enum_var = mappings[0].value; +} + +/* Include auto-generated parsing routines. */ +#include "aarch64-json-tunings-parser-generated.inc" + +/* Validate the user provided JSON data against the present schema. + Checks for correct types, fields, and expected format. */ +static bool +validate_and_traverse (const json::object *json_obj, + const json::object *schema_obj, + const std::string &parent_key = "") +{ + for (const auto &json_entry : json_obj->get_map ()) + { + const std::string &key = json_entry.first; + const json::value *json_value = json_entry.second; + + std::string full_key = parent_key.empty () ? key : parent_key + "." + key; + + const json::value *schema_value = schema_obj->get (key.c_str ()); + if (!schema_value) + { + warning (0, "key %qs is not a tuning parameter, skipping", + full_key.c_str ()); + continue; + } + + if (auto *sub_schema_obj = dyn_cast (schema_value)) + { + if (auto *sub_json_obj = dyn_cast (json_value)) + { + if (!validate_and_traverse (sub_json_obj, sub_schema_obj, + full_key)) + return false; + } + else + { + error ("key %qs expected to be an object", full_key.c_str ()); + return false; + } + } + else if (schema_value->get_kind () == json::JSON_ARRAY) + { + if (json_value->get_kind () != json::JSON_ARRAY) + { + error ("key %qs expected to be an array", full_key.c_str ()); + return false; + } + } + else if (auto *schema_string + = dyn_cast (schema_value)) + { + const char *schema_type_str = schema_string->get_string (); + + if (strcmp (schema_type_str, "int") == 0) + { + if (json_value->get_kind () != json::JSON_INTEGER) + { + error ("key %qs expected to be an integer", + full_key.c_str ()); + return false; + } + // Check if the value is valid for signed integer + if (auto *int_val + = dyn_cast (json_value)) + { + long value = int_val->get (); + if (value > INT_MAX || value < INT_MIN) + { + error ("key %qs value %ld is out of range for % " + "type [%d, %d]", + full_key.c_str (), value, INT_MIN, INT_MAX); + return false; + } + } + } + else if (strcmp (schema_type_str, "uint") == 0) + { + if (json_value->get_kind () != json::JSON_INTEGER) + { + error ("key %qs expected to be an unsigned integer", + full_key.c_str ()); + return false; + } + // Check if the value is valid for unsigned integer + if (auto *int_val + = dyn_cast (json_value)) + { + long value = int_val->get (); + if (value < 0 || value > UINT_MAX) + { + error ("key %qs value %ld is out of range for % " + "type [0, %u]", + full_key.c_str (), value, UINT_MAX); + return false; + } + } + } + else if (strcmp (schema_type_str, "string") == 0) + { + if (json_value->get_kind () != json::JSON_STRING) + { + error ("key %qs expected to be a string", full_key.c_str ()); + return false; + } + } + else if (strcmp (schema_type_str, "boolean") == 0) + { + if (json_value->get_kind () != json::JSON_TRUE + && json_value->get_kind () != json::JSON_FALSE) + { + error ("key %qs expected to be a boolean (true/false)", + full_key.c_str ()); + return false; + } + } + else if (strcmp (schema_type_str, "enum") == 0) + { + if (json_value->get_kind () != json::JSON_STRING) + { + error ("key %qs expected to be an enum (string)", + full_key.c_str ()); + return false; + } + } + else + { + error ("key %qs has unsupported type", full_key.c_str ()); + return false; + } + } + else + { + error ("key %qs has unexpected format in schema", full_key.c_str ()); + return false; + } + } + return true; +} + +/* Helper routine for reading the provided JSON file. */ +static std::unique_ptr> +read_file (const char *path) +{ + FILE *f_in = fopen (path, "r"); + if (!f_in) + { + error ("could not open file %s", path); + return nullptr; + } + + auto result = std::make_unique> (); + char buf[4096]; + + while (size_t iter_sz_in = fread (buf, 1, sizeof (buf), f_in)) + result->insert (result->end (), buf, buf + iter_sz_in); + + if (!feof (f_in)) + { + error ("error reading file %s", path); + fclose (f_in); + return nullptr; + } + + fclose (f_in); + result->push_back ('\0'); + return result; +} + +static bool +check_version_compatibility (const json::object *root_obj) +{ + const json::value *metadata_value = root_obj->get ("metadata"); + int json_gcc_major_version = -1; + + if (metadata_value) + { + if (auto *metadata_obj = dyn_cast (metadata_value)) + { + const json::value *version_value = metadata_obj->get ("gcc_version"); + if (version_value) + { + if (auto *version_int_val + = dyn_cast (version_value)) + json_gcc_major_version = version_int_val->get (); + } + } + } + + if (json_gcc_major_version == -1) + { + warning (0, "JSON tuning file does not contain version information; " + "compatibility cannot be verified"); + return true; + } + + if (json_gcc_major_version != GCC_major_version) + { + error ("JSON tuning file was created with GCC version %d " + "but current GCC version is %d", + json_gcc_major_version, GCC_major_version); + inform (UNKNOWN_LOCATION, "JSON tuning files must be regenerated " + "when switching between major GCC versions"); + return false; + } + + return true; +} + +/* Main routine for setting up the parsing of JSON data. */ +static void +aarch64_load_tuning_params_from_json_string (const char *json_string, + const char *schema_string, + struct tune_params *tune) +{ + /* Try parsing the JSON string. */ + json::parser_result_t data_result + = json::parse_utf8_string (strlen (json_string), json_string, true, + nullptr); + + if (auto json_err = data_result.m_err.get ()) + { + error ("error parsing JSON data: %s", json_err->get_msg ()); + return; + } + + const std::unique_ptr &root = data_result.m_val; + if (!root) + { + error ("JSON parsing returned null data"); + return; + } + auto *root_obj = dyn_cast (root.get ()); + if (!root_obj) + { + warning (0, "no JSON object found in the provided data"); + return; + } + + /* Check version compatibility before proceeding. */ + if (!check_version_compatibility (root_obj)) + return; + + json::parser_result_t schema_result + = json::parse_utf8_string (strlen (schema_string), schema_string, true, + nullptr); + + gcc_assert (!schema_result.m_err.get ()); + gcc_assert (schema_result.m_val); + + auto *schema_obj + = dyn_cast (schema_result.m_val.get ()); + gcc_assert (schema_obj); + + const json::value *tune_params_value = root_obj->get ("tune_params"); + if (!tune_params_value) + { + warning (0, "key % not found in JSON data"); + return; + } + + auto *jo = dyn_cast (tune_params_value); + if (!jo) + { + error ("key % is not a JSON object"); + return; + } + + if (!validate_and_traverse (root_obj, schema_obj)) + { + error ("validation failed for the provided JSON data"); + return; + } + + parse_tunings (jo, *tune); + return; +} + +/* Wrapper for calling aarch64_load_tuning_params_from_json_string. */ +void +aarch64_load_tuning_params_from_json (const char *data_filename, + struct tune_params *tune) +{ + std::unique_ptr> json_data = read_file (data_filename); + if (!json_data || !json_data->data ()) + { + error ("cannot read JSON data in %s", data_filename); + return; + } + aarch64_load_tuning_params_from_json_string ( + (const char *) json_data->data (), schema_json, tune); +} + +#if CHECKING_P +namespace selftest { + +#define STR_(X) #X +#define STR(X) STR_(X) + +void +test_json_integers () +{ + const char *test_json = R"json({ + "metadata": { + "gcc_version": )json" STR (GCC_major_version) R"json( + }, + "tune_params": { + "sve_width": 256, + "issue_rate": 4 + } + })json"; + + tune_params params; + + aarch64_load_tuning_params_from_json_string (test_json, schema_json, ¶ms); + + ASSERT_EQ (params.sve_width, 256); + ASSERT_EQ (params.issue_rate, 4); +} + +void +test_json_boolean () +{ + const char *test_json = R"json({ + "metadata": { + "gcc_version": )json" STR (GCC_major_version) R"json( + }, + "tune_params": { + "insn_extra_cost": { + "alu": { + "non_exec_costs_exec": false + } + } + } + })json"; + + static const cpu_cost_table default_cost_table = {}; + + tune_params params; + params.insn_extra_cost = &default_cost_table; + + aarch64_load_tuning_params_from_json_string (test_json, schema_json, ¶ms); + + ASSERT_EQ (params.insn_extra_cost->alu.non_exec_costs_exec, false); +} + +void +test_json_strings () +{ + const char *test_json = R"json({ + "metadata": { + "gcc_version": )json" STR (GCC_major_version) R"json( + }, + "tune_params": { + "function_align": "16", + "jump_align": "2", + "loop_align": "8" + } + })json"; + + tune_params params; + + aarch64_load_tuning_params_from_json_string (test_json, schema_json, ¶ms); + + ASSERT_STREQ (params.function_align, "16"); + ASSERT_STREQ (params.jump_align, "2"); + ASSERT_STREQ (params.loop_align, "8"); +} + +void +test_json_enums () +{ + const char *test_json = R"json({ + "metadata": { + "gcc_version": )json" STR (GCC_major_version) R"json( + }, + "tune_params": { + "autoprefetcher_model": "AUTOPREFETCHER_OFF", + "ldp_policy_model": "AARCH64_LDP_STP_POLICY_NEVER", + "stp_policy_model": "AARCH64_LDP_STP_POLICY_DEFAULT" + } + })json"; + + tune_params params; + + aarch64_load_tuning_params_from_json_string (test_json, schema_json, ¶ms); + + ASSERT_EQ (params.autoprefetcher_model, tune_params::AUTOPREFETCHER_OFF); + ASSERT_EQ (params.ldp_policy_model, AARCH64_LDP_STP_POLICY_NEVER); + ASSERT_EQ (params.stp_policy_model, AARCH64_LDP_STP_POLICY_DEFAULT); +} + +void +aarch64_json_tunings_tests () +{ + test_json_integers (); + test_json_boolean (); + test_json_strings (); + test_json_enums (); +} + +} // namespace selftest + +#undef STR +#undef STR_ + +#endif /* CHECKING_P */ \ No newline at end of file diff --git a/gcc/config/aarch64/aarch64-json-tunings-parser.h b/gcc/config/aarch64/aarch64-json-tunings-parser.h new file mode 100644 index 000000000000..3c5cd4c3c20b --- /dev/null +++ b/gcc/config/aarch64/aarch64-json-tunings-parser.h @@ -0,0 +1,29 @@ +/* Routines to parse the AArch64 tuning parameters from a JSON file. + Copyright The GNU Toolchain Authors. + + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#ifndef AARCH64_JSON_TUNINGS_PARSER_H +#define AARCH64_JSON_TUNINGS_PARSER_H + +#include "aarch64-protos.h" + +void +aarch64_load_tuning_params_from_json (const char *data_filename, + struct tune_params *tune); + +#endif \ No newline at end of file diff --git a/gcc/config/aarch64/aarch64-json-tunings-printer-generated.inc b/gcc/config/aarch64/aarch64-json-tunings-printer-generated.inc new file mode 100644 index 000000000000..6ffc4427a8bd --- /dev/null +++ b/gcc/config/aarch64/aarch64-json-tunings-printer-generated.inc @@ -0,0 +1,439 @@ +/* This file is auto-generated by aarch64-generate-json-tuning-routines.py. */ +/* Copyright The GNU Toolchain Authors. + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it under + the terms of the GNU General Public License as published by the Free + Software Foundation; either version 3, or (at your option) any later + version. + + GCC is distributed in the hope that it will be useful, but WITHOUT ANY + WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* This file contains the auto-generated serializer functions for JSON tuning parameters. */ + + +static const enum_mapping + autoprefetcher_model_mappings[] = { +#define AARCH64_AUTOPREFETCH_MODE(NAME, ENUM_VALUE) {NAME, tune_params::ENUM_VALUE}, +#include "aarch64-tuning-enums.def" +}; + +static const enum_mapping ldp_policy_model_mappings[] = { +#define AARCH64_LDP_STP_POLICY(NAME, ENUM_VALUE) {NAME, ENUM_VALUE}, +#include "aarch64-tuning-enums.def" +}; + +static const enum_mapping stp_policy_model_mappings[] = { +#define AARCH64_LDP_STP_POLICY(NAME, ENUM_VALUE) {NAME, ENUM_VALUE}, +#include "aarch64-tuning-enums.def" +}; + + +template +static std::unique_ptr +serialize_insn_extra_cost_alu (const T &alu) +{ + auto alu_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (alu_obj, "arith", alu.arith); + SERIALIZE_INTEGER_FIELD (alu_obj, "logical", alu.logical); + SERIALIZE_INTEGER_FIELD (alu_obj, "shift", alu.shift); + SERIALIZE_INTEGER_FIELD (alu_obj, "shift_reg", alu.shift_reg); + SERIALIZE_INTEGER_FIELD (alu_obj, "arith_shift", alu.arith_shift); + SERIALIZE_INTEGER_FIELD (alu_obj, "arith_shift_reg", alu.arith_shift_reg); + SERIALIZE_INTEGER_FIELD (alu_obj, "log_shift", alu.log_shift); + SERIALIZE_INTEGER_FIELD (alu_obj, "log_shift_reg", alu.log_shift_reg); + SERIALIZE_INTEGER_FIELD (alu_obj, "extend", alu.extend); + SERIALIZE_INTEGER_FIELD (alu_obj, "extend_arith", alu.extend_arith); + SERIALIZE_INTEGER_FIELD (alu_obj, "bfi", alu.bfi); + SERIALIZE_INTEGER_FIELD (alu_obj, "bfx", alu.bfx); + SERIALIZE_INTEGER_FIELD (alu_obj, "clz", alu.clz); + SERIALIZE_INTEGER_FIELD (alu_obj, "rev", alu.rev); + SERIALIZE_INTEGER_FIELD (alu_obj, "non_exec", alu.non_exec); + SERIALIZE_BOOLEAN_FIELD (alu_obj, "non_exec_costs_exec", alu.non_exec_costs_exec); + + return alu_obj; +} + +template +static std::unique_ptr +serialize_insn_extra_cost_mult_element (const T &mult_element) +{ + auto mult_element_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (mult_element_obj, "simple", mult_element.simple); + SERIALIZE_INTEGER_FIELD (mult_element_obj, "flag_setting", mult_element.flag_setting); + SERIALIZE_INTEGER_FIELD (mult_element_obj, "extend", mult_element.extend); + SERIALIZE_INTEGER_FIELD (mult_element_obj, "add", mult_element.add); + SERIALIZE_INTEGER_FIELD (mult_element_obj, "extend_add", mult_element.extend_add); + SERIALIZE_INTEGER_FIELD (mult_element_obj, "idiv", mult_element.idiv); + + return mult_element_obj; +} + +template +static std::unique_ptr +serialize_insn_extra_cost_ldst (const T &ldst) +{ + auto ldst_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (ldst_obj, "load", ldst.load); + SERIALIZE_INTEGER_FIELD (ldst_obj, "load_sign_extend", ldst.load_sign_extend); + SERIALIZE_INTEGER_FIELD (ldst_obj, "ldrd", ldst.ldrd); + SERIALIZE_INTEGER_FIELD (ldst_obj, "ldm_1st", ldst.ldm_1st); + SERIALIZE_INTEGER_FIELD (ldst_obj, "ldm_regs_per_insn_1st", ldst.ldm_regs_per_insn_1st); + SERIALIZE_INTEGER_FIELD (ldst_obj, "ldm_regs_per_insn_subsequent", ldst.ldm_regs_per_insn_subsequent); + SERIALIZE_INTEGER_FIELD (ldst_obj, "loadf", ldst.loadf); + SERIALIZE_INTEGER_FIELD (ldst_obj, "loadd", ldst.loadd); + SERIALIZE_INTEGER_FIELD (ldst_obj, "load_unaligned", ldst.load_unaligned); + SERIALIZE_INTEGER_FIELD (ldst_obj, "store", ldst.store); + SERIALIZE_INTEGER_FIELD (ldst_obj, "strd", ldst.strd); + SERIALIZE_INTEGER_FIELD (ldst_obj, "stm_1st", ldst.stm_1st); + SERIALIZE_INTEGER_FIELD (ldst_obj, "stm_regs_per_insn_1st", ldst.stm_regs_per_insn_1st); + SERIALIZE_INTEGER_FIELD (ldst_obj, "stm_regs_per_insn_subsequent", ldst.stm_regs_per_insn_subsequent); + SERIALIZE_INTEGER_FIELD (ldst_obj, "storef", ldst.storef); + SERIALIZE_INTEGER_FIELD (ldst_obj, "stored", ldst.stored); + SERIALIZE_INTEGER_FIELD (ldst_obj, "store_unaligned", ldst.store_unaligned); + SERIALIZE_INTEGER_FIELD (ldst_obj, "loadv", ldst.loadv); + SERIALIZE_INTEGER_FIELD (ldst_obj, "storev", ldst.storev); + + return ldst_obj; +} + +template +static std::unique_ptr +serialize_insn_extra_cost_fp_element (const T &fp_element) +{ + auto fp_element_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (fp_element_obj, "div", fp_element.div); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "mult", fp_element.mult); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "mult_addsub", fp_element.mult_addsub); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "fma", fp_element.fma); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "addsub", fp_element.addsub); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "fpconst", fp_element.fpconst); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "neg", fp_element.neg); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "compare", fp_element.compare); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "widen", fp_element.widen); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "narrow", fp_element.narrow); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "toint", fp_element.toint); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "fromint", fp_element.fromint); + SERIALIZE_INTEGER_FIELD (fp_element_obj, "roundint", fp_element.roundint); + + return fp_element_obj; +} + +template +static std::unique_ptr +serialize_insn_extra_cost_vect (const T &vect) +{ + auto vect_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (vect_obj, "alu", vect.alu); + SERIALIZE_INTEGER_FIELD (vect_obj, "mult", vect.mult); + SERIALIZE_INTEGER_FIELD (vect_obj, "movi", vect.movi); + SERIALIZE_INTEGER_FIELD (vect_obj, "dup", vect.dup); + SERIALIZE_INTEGER_FIELD (vect_obj, "extract", vect.extract); + + return vect_obj; +} + +template +static std::unique_ptr +serialize_addr_cost_addr_scale_costs (const T &addr_scale_costs) +{ + auto addr_scale_costs_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (addr_scale_costs_obj, "hi", addr_scale_costs.hi); + SERIALIZE_INTEGER_FIELD (addr_scale_costs_obj, "si", addr_scale_costs.si); + SERIALIZE_INTEGER_FIELD (addr_scale_costs_obj, "di", addr_scale_costs.di); + SERIALIZE_INTEGER_FIELD (addr_scale_costs_obj, "ti", addr_scale_costs.ti); + + return addr_scale_costs_obj; +} + +template +static std::unique_ptr +serialize_regmove_cost (const T ®move_cost) +{ + auto regmove_cost_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (regmove_cost_obj, "GP2GP", regmove_cost.GP2GP); + SERIALIZE_INTEGER_FIELD (regmove_cost_obj, "GP2FP", regmove_cost.GP2FP); + SERIALIZE_INTEGER_FIELD (regmove_cost_obj, "FP2GP", regmove_cost.FP2GP); + SERIALIZE_INTEGER_FIELD (regmove_cost_obj, "FP2FP", regmove_cost.FP2FP); + + return regmove_cost_obj; +} + +template +static std::unique_ptr +serialize_vec_costs_advsimd (const T &advsimd) +{ + auto advsimd_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (advsimd_obj, "int_stmt_cost", advsimd.int_stmt_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "fp_stmt_cost", advsimd.fp_stmt_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "ld2_st2_permute_cost", advsimd.ld2_st2_permute_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "ld3_st3_permute_cost", advsimd.ld3_st3_permute_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "ld4_st4_permute_cost", advsimd.ld4_st4_permute_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "permute_cost", advsimd.permute_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "reduc_i8_cost", advsimd.reduc_i8_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "reduc_i16_cost", advsimd.reduc_i16_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "reduc_i32_cost", advsimd.reduc_i32_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "reduc_i64_cost", advsimd.reduc_i64_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "reduc_f16_cost", advsimd.reduc_f16_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "reduc_f32_cost", advsimd.reduc_f32_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "reduc_f64_cost", advsimd.reduc_f64_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "store_elt_extra_cost", advsimd.store_elt_extra_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "vec_to_scalar_cost", advsimd.vec_to_scalar_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "scalar_to_vec_cost", advsimd.scalar_to_vec_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "align_load_cost", advsimd.align_load_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "unalign_load_cost", advsimd.unalign_load_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "unalign_store_cost", advsimd.unalign_store_cost); + SERIALIZE_INTEGER_FIELD (advsimd_obj, "store_cost", advsimd.store_cost); + + return advsimd_obj; +} + +template +static std::unique_ptr +serialize_vec_costs_sve (const T &sve) +{ + auto sve_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (sve_obj, "clast_cost", sve.clast_cost); + SERIALIZE_INTEGER_FIELD (sve_obj, "fadda_f16_cost", sve.fadda_f16_cost); + SERIALIZE_INTEGER_FIELD (sve_obj, "fadda_f32_cost", sve.fadda_f32_cost); + SERIALIZE_INTEGER_FIELD (sve_obj, "fadda_f64_cost", sve.fadda_f64_cost); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "gather_load_x32_cost", sve.gather_load_x32_cost); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "gather_load_x64_cost", sve.gather_load_x64_cost); + SERIALIZE_INTEGER_FIELD (sve_obj, "gather_load_x32_init_cost", sve.gather_load_x32_init_cost); + SERIALIZE_INTEGER_FIELD (sve_obj, "gather_load_x64_init_cost", sve.gather_load_x64_init_cost); + SERIALIZE_INTEGER_FIELD (sve_obj, "scatter_store_elt_cost", sve.scatter_store_elt_cost); + + return sve_obj; +} + +template +static std::unique_ptr +serialize_vec_costs_issue_info_scalar (const T &scalar) +{ + auto scalar_obj = std::make_unique (); + + SERIALIZE_UNSIGNED_INTEGER_FIELD (scalar_obj, "loads_stores_per_cycle", scalar.loads_stores_per_cycle); + SERIALIZE_UNSIGNED_INTEGER_FIELD (scalar_obj, "stores_per_cycle", scalar.stores_per_cycle); + SERIALIZE_UNSIGNED_INTEGER_FIELD (scalar_obj, "general_ops_per_cycle", scalar.general_ops_per_cycle); + SERIALIZE_UNSIGNED_INTEGER_FIELD (scalar_obj, "fp_simd_load_general_ops", scalar.fp_simd_load_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (scalar_obj, "fp_simd_store_general_ops", scalar.fp_simd_store_general_ops); + + return scalar_obj; +} + +template +static std::unique_ptr +serialize_vec_costs_issue_info_advsimd (const T &advsimd) +{ + auto advsimd_obj = std::make_unique (); + + SERIALIZE_UNSIGNED_INTEGER_FIELD (advsimd_obj, "loads_stores_per_cycle", advsimd.loads_stores_per_cycle); + SERIALIZE_UNSIGNED_INTEGER_FIELD (advsimd_obj, "stores_per_cycle", advsimd.stores_per_cycle); + SERIALIZE_UNSIGNED_INTEGER_FIELD (advsimd_obj, "general_ops_per_cycle", advsimd.general_ops_per_cycle); + SERIALIZE_UNSIGNED_INTEGER_FIELD (advsimd_obj, "fp_simd_load_general_ops", advsimd.fp_simd_load_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (advsimd_obj, "fp_simd_store_general_ops", advsimd.fp_simd_store_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (advsimd_obj, "ld2_st2_general_ops", advsimd.ld2_st2_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (advsimd_obj, "ld3_st3_general_ops", advsimd.ld3_st3_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (advsimd_obj, "ld4_st4_general_ops", advsimd.ld4_st4_general_ops); + + return advsimd_obj; +} + +template +static std::unique_ptr +serialize_vec_costs_issue_info_sve (const T &sve) +{ + auto sve_obj = std::make_unique (); + + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "loads_stores_per_cycle", sve.loads_stores_per_cycle); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "stores_per_cycle", sve.stores_per_cycle); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "general_ops_per_cycle", sve.general_ops_per_cycle); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "fp_simd_load_general_ops", sve.fp_simd_load_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "fp_simd_store_general_ops", sve.fp_simd_store_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "ld2_st2_general_ops", sve.ld2_st2_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "ld3_st3_general_ops", sve.ld3_st3_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "ld4_st4_general_ops", sve.ld4_st4_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "pred_ops_per_cycle", sve.pred_ops_per_cycle); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "while_pred_ops", sve.while_pred_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "int_cmp_pred_ops", sve.int_cmp_pred_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "fp_cmp_pred_ops", sve.fp_cmp_pred_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "gather_scatter_pair_general_ops", sve.gather_scatter_pair_general_ops); + SERIALIZE_UNSIGNED_INTEGER_FIELD (sve_obj, "gather_scatter_pair_pred_ops", sve.gather_scatter_pair_pred_ops); + + return sve_obj; +} + +template +static std::unique_ptr +serialize_branch_costs (const T &branch_costs) +{ + auto branch_costs_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (branch_costs_obj, "predictable", branch_costs.predictable); + SERIALIZE_INTEGER_FIELD (branch_costs_obj, "unpredictable", branch_costs.unpredictable); + + return branch_costs_obj; +} + +template +static std::unique_ptr +serialize_approx_modes (const T &approx_modes) +{ + auto approx_modes_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (approx_modes_obj, "division", approx_modes.division); + SERIALIZE_INTEGER_FIELD (approx_modes_obj, "sqrt", approx_modes.sqrt); + SERIALIZE_INTEGER_FIELD (approx_modes_obj, "recip_sqrt", approx_modes.recip_sqrt); + + return approx_modes_obj; +} + +template +static std::unique_ptr +serialize_memmov_cost (const T &memmov_cost) +{ + auto memmov_cost_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (memmov_cost_obj, "load_int", memmov_cost.load_int); + SERIALIZE_INTEGER_FIELD (memmov_cost_obj, "store_int", memmov_cost.store_int); + SERIALIZE_INTEGER_FIELD (memmov_cost_obj, "load_fp", memmov_cost.load_fp); + SERIALIZE_INTEGER_FIELD (memmov_cost_obj, "store_fp", memmov_cost.store_fp); + SERIALIZE_INTEGER_FIELD (memmov_cost_obj, "load_pred", memmov_cost.load_pred); + SERIALIZE_INTEGER_FIELD (memmov_cost_obj, "store_pred", memmov_cost.store_pred); + + return memmov_cost_obj; +} + +template +static std::unique_ptr +serialize_prefetch (const T &prefetch) +{ + auto prefetch_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (prefetch_obj, "num_slots", prefetch.num_slots); + SERIALIZE_INTEGER_FIELD (prefetch_obj, "l1_cache_size", prefetch.l1_cache_size); + SERIALIZE_INTEGER_FIELD (prefetch_obj, "l1_cache_line_size", prefetch.l1_cache_line_size); + SERIALIZE_INTEGER_FIELD (prefetch_obj, "l2_cache_size", prefetch.l2_cache_size); + SERIALIZE_BOOLEAN_FIELD (prefetch_obj, "prefetch_dynamic_strides", prefetch.prefetch_dynamic_strides); + SERIALIZE_INTEGER_FIELD (prefetch_obj, "minimum_stride", prefetch.minimum_stride); + SERIALIZE_INTEGER_FIELD (prefetch_obj, "default_opt_level", prefetch.default_opt_level); + + return prefetch_obj; +} + +template +static std::unique_ptr +serialize_insn_extra_cost (const T &insn_extra_cost) +{ + auto insn_extra_cost_obj = std::make_unique (); + + SERIALIZE_OBJECT (insn_extra_cost_obj, "alu", insn_extra_cost.alu, serialize_insn_extra_cost_alu); + SERIALIZE_ARRAY_FIELD (insn_extra_cost_obj, "mult", insn_extra_cost.mult, ARRAY_SIZE (insn_extra_cost.mult), serialize_insn_extra_cost_mult_element); + SERIALIZE_OBJECT (insn_extra_cost_obj, "ldst", insn_extra_cost.ldst, serialize_insn_extra_cost_ldst); + SERIALIZE_ARRAY_FIELD (insn_extra_cost_obj, "fp", insn_extra_cost.fp, ARRAY_SIZE (insn_extra_cost.fp), serialize_insn_extra_cost_fp_element); + SERIALIZE_OBJECT (insn_extra_cost_obj, "vect", insn_extra_cost.vect, serialize_insn_extra_cost_vect); + + return insn_extra_cost_obj; +} + +template +static std::unique_ptr +serialize_addr_cost (const T &addr_cost) +{ + auto addr_cost_obj = std::make_unique (); + + SERIALIZE_OBJECT (addr_cost_obj, "addr_scale_costs", addr_cost.addr_scale_costs, serialize_addr_cost_addr_scale_costs); + SERIALIZE_INTEGER_FIELD (addr_cost_obj, "pre_modify", addr_cost.pre_modify); + SERIALIZE_INTEGER_FIELD (addr_cost_obj, "post_modify", addr_cost.post_modify); + SERIALIZE_INTEGER_FIELD (addr_cost_obj, "post_modify_ld3_st3", addr_cost.post_modify_ld3_st3); + SERIALIZE_INTEGER_FIELD (addr_cost_obj, "post_modify_ld4_st4", addr_cost.post_modify_ld4_st4); + SERIALIZE_INTEGER_FIELD (addr_cost_obj, "register_offset", addr_cost.register_offset); + SERIALIZE_INTEGER_FIELD (addr_cost_obj, "register_sextend", addr_cost.register_sextend); + SERIALIZE_INTEGER_FIELD (addr_cost_obj, "register_zextend", addr_cost.register_zextend); + SERIALIZE_INTEGER_FIELD (addr_cost_obj, "imm_offset", addr_cost.imm_offset); + + return addr_cost_obj; +} + +template +static std::unique_ptr +serialize_vec_costs_issue_info (const T &issue_info) +{ + auto issue_info_obj = std::make_unique (); + + SERIALIZE_OBJECT (issue_info_obj, "scalar", issue_info.scalar, serialize_vec_costs_issue_info_scalar); + SERIALIZE_OBJECT (issue_info_obj, "advsimd", issue_info.advsimd, serialize_vec_costs_issue_info_advsimd); + SERIALIZE_OBJECT (issue_info_obj, "sve", issue_info.sve, serialize_vec_costs_issue_info_sve); + + return issue_info_obj; +} + +template +static std::unique_ptr +serialize_vec_costs (const T &vec_costs) +{ + auto vec_costs_obj = std::make_unique (); + + SERIALIZE_INTEGER_FIELD (vec_costs_obj, "scalar_int_stmt_cost", vec_costs.scalar_int_stmt_cost); + SERIALIZE_INTEGER_FIELD (vec_costs_obj, "scalar_fp_stmt_cost", vec_costs.scalar_fp_stmt_cost); + SERIALIZE_INTEGER_FIELD (vec_costs_obj, "scalar_load_cost", vec_costs.scalar_load_cost); + SERIALIZE_INTEGER_FIELD (vec_costs_obj, "scalar_store_cost", vec_costs.scalar_store_cost); + SERIALIZE_INTEGER_FIELD (vec_costs_obj, "cond_taken_branch_cost", vec_costs.cond_taken_branch_cost); + SERIALIZE_INTEGER_FIELD (vec_costs_obj, "cond_not_taken_branch_cost", vec_costs.cond_not_taken_branch_cost); + SERIALIZE_OBJECT (vec_costs_obj, "advsimd", vec_costs.advsimd, serialize_vec_costs_advsimd); + SERIALIZE_OBJECT (vec_costs_obj, "sve", vec_costs.sve, serialize_vec_costs_sve); + SERIALIZE_OBJECT (vec_costs_obj, "issue_info", vec_costs.issue_info, serialize_vec_costs_issue_info); + + return vec_costs_obj; +} + +template +static std::unique_ptr +serialize_tunings (const T &tunings) +{ + auto tunings_obj = std::make_unique (); + + SERIALIZE_OBJECT (tunings_obj, "insn_extra_cost", tunings.insn_extra_cost, serialize_insn_extra_cost); + SERIALIZE_OBJECT (tunings_obj, "addr_cost", tunings.addr_cost, serialize_addr_cost); + SERIALIZE_OBJECT (tunings_obj, "regmove_cost", tunings.regmove_cost, serialize_regmove_cost); + SERIALIZE_OBJECT (tunings_obj, "vec_costs", tunings.vec_costs, serialize_vec_costs); + SERIALIZE_OBJECT (tunings_obj, "branch_costs", tunings.branch_costs, serialize_branch_costs); + SERIALIZE_OBJECT (tunings_obj, "approx_modes", tunings.approx_modes, serialize_approx_modes); + SERIALIZE_UNSIGNED_INTEGER_FIELD (tunings_obj, "sve_width", tunings.sve_width); + SERIALIZE_OBJECT (tunings_obj, "memmov_cost", tunings.memmov_cost, serialize_memmov_cost); + SERIALIZE_INTEGER_FIELD (tunings_obj, "issue_rate", tunings.issue_rate); + SERIALIZE_UNSIGNED_INTEGER_FIELD (tunings_obj, "fusible_ops", tunings.fusible_ops); + SERIALIZE_STRING_FIELD (tunings_obj, "function_align", tunings.function_align); + SERIALIZE_STRING_FIELD (tunings_obj, "jump_align", tunings.jump_align); + SERIALIZE_STRING_FIELD (tunings_obj, "loop_align", tunings.loop_align); + SERIALIZE_INTEGER_FIELD (tunings_obj, "int_reassoc_width", tunings.int_reassoc_width); + SERIALIZE_INTEGER_FIELD (tunings_obj, "fp_reassoc_width", tunings.fp_reassoc_width); + SERIALIZE_INTEGER_FIELD (tunings_obj, "fma_reassoc_width", tunings.fma_reassoc_width); + SERIALIZE_INTEGER_FIELD (tunings_obj, "vec_reassoc_width", tunings.vec_reassoc_width); + SERIALIZE_INTEGER_FIELD (tunings_obj, "min_div_recip_mul_sf", tunings.min_div_recip_mul_sf); + SERIALIZE_INTEGER_FIELD (tunings_obj, "min_div_recip_mul_df", tunings.min_div_recip_mul_df); + SERIALIZE_UNSIGNED_INTEGER_FIELD (tunings_obj, "max_case_values", tunings.max_case_values); + SERIALIZE_ENUM_FIELD (tunings_obj, "autoprefetcher_model", tunings.autoprefetcher_model, autoprefetcher_model_mappings); + SERIALIZE_UNSIGNED_INTEGER_FIELD (tunings_obj, "extra_tuning_flags", tunings.extra_tuning_flags); + SERIALIZE_OBJECT (tunings_obj, "prefetch", tunings.prefetch, serialize_prefetch); + SERIALIZE_ENUM_FIELD (tunings_obj, "ldp_policy_model", tunings.ldp_policy_model, ldp_policy_model_mappings); + SERIALIZE_ENUM_FIELD (tunings_obj, "stp_policy_model", tunings.stp_policy_model, stp_policy_model_mappings); + + return tunings_obj; +} \ No newline at end of file diff --git a/gcc/config/aarch64/aarch64-json-tunings-printer.cc b/gcc/config/aarch64/aarch64-json-tunings-printer.cc new file mode 100644 index 000000000000..7f28dde9bbed --- /dev/null +++ b/gcc/config/aarch64/aarch64-json-tunings-printer.cc @@ -0,0 +1,146 @@ +/* Routines to print the AArch64 tuning parameters to a JSON file. + Copyright The GNU Toolchain Authors. + + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#define INCLUDE_TYPE_TRAITS +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "pretty-print.h" +#include "tm.h" +#include "diagnostic-core.h" +#include "aarch64-json-tunings-printer.h" +#include "aarch64-protos.h" +#include "config/arm/aarch-common-protos.h" +#include "json.h" +#include "version.h" + +#define SERIALIZE_INTEGER_FIELD(obj, key, member) \ + (obj)->set_integer ((key), (member)) + +#define SERIALIZE_UNSIGNED_INTEGER_FIELD(obj, key, member) \ + (obj)->set_integer ((key), (member)) + +#define SERIALIZE_BOOLEAN_FIELD(obj, key, member) \ + (obj)->set_bool ((key), (member)) + +#define SERIALIZE_STRING_FIELD(obj, key, member) \ + (obj)->set_string ((key), (member)) + +#define SERIALIZE_OBJECT(obj, key, member, serialize_func) \ + { \ + auto field_obj = serialize_object_helper ((member), (serialize_func)); \ + if (field_obj) \ + (obj)->set ((key), std::move (field_obj)); \ + } + +#define SERIALIZE_ARRAY_FIELD(obj, key, member, size, serialize_func) \ + { \ + auto field_array = std::make_unique (); \ + for (size_t i = 0; i < (size); ++i) \ + { \ + auto element_obj = serialize_func ((member)[i]); \ + if (element_obj) \ + field_array->append (std::move (element_obj)); \ + } \ + (obj)->set ((key), std::move (field_array)); \ + } + +#define SERIALIZE_ENUM_FIELD(obj, key, member, mappings) \ + (obj)->set_string ((key), serialize_enum ((member), (mappings), \ + sizeof (mappings) \ + / sizeof (mappings[0]))) + +/* Type alias for serialize function pointer. */ +template +using serialize_func_type = std::unique_ptr (*) ( + const typename std::remove_pointer::type &); + +/* Serialize JSON object from non-pointer members. */ +template +static typename std::enable_if::value, + std::unique_ptr>::type +serialize_object_helper (const T &member, serialize_func_type serialize_func) +{ + return serialize_func (member); +} + +/* Serialize JSON object from pointer members. */ +template +static typename std::enable_if::value, + std::unique_ptr>::type +serialize_object_helper (const T &member, serialize_func_type serialize_func) +{ + if (member) + return serialize_func (*member); + return std::make_unique (); +} + +/* Mapping structure for enum-to-string conversion. */ +template struct enum_mapping +{ + const char *name; + EnumType value; +}; + +/* Convert enum value to string using enum-to-string mappings. */ +template +static const char * +serialize_enum (EnumType enum_value, const enum_mapping *mappings, + size_t num_mappings) +{ + for (size_t i = 0; i < num_mappings; ++i) + if (enum_value == mappings[i].value) + return mappings[i].name; + return mappings[0].name; +} + +/* Include auto-generated printing routines. */ +#include "aarch64-json-tunings-printer-generated.inc" + +/* Print tune_params structure to JSON file. */ +void +aarch64_print_tune_params (const tune_params ¶ms, const char *filename) +{ + /* Use default filename if none provided or empty string given. */ + const char *output_filename = filename; + if (!output_filename || *output_filename == '\0') + output_filename = "aarch64-tuning.json"; + + auto aarch64_tune_params_json = std::make_unique (); + + auto metadata = std::make_unique (); + metadata->set_integer ("gcc_version", GCC_major_version); + aarch64_tune_params_json->set ("metadata", std::move (metadata)); + + aarch64_tune_params_json->set ("tune_params", serialize_tunings (params)); + + pretty_printer pp; + aarch64_tune_params_json->print (&pp, true); + + FILE *outputFile = fopen (output_filename, "w"); + if (!outputFile) + { + error ("Error opening file %s", output_filename); + return; + } + + fprintf (outputFile, "%s", pp_formatted_text (&pp)); + fclose (outputFile); + return; +} \ No newline at end of file diff --git a/gcc/config/aarch64/aarch64-json-tunings-printer.h b/gcc/config/aarch64/aarch64-json-tunings-printer.h new file mode 100644 index 000000000000..a65c005d9fe0 --- /dev/null +++ b/gcc/config/aarch64/aarch64-json-tunings-printer.h @@ -0,0 +1,28 @@ +/* Routine to print the AArch64 tuning parameters to a JSON file. + Copyright The GNU Toolchain Authors. + + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +#ifndef AARCH64_JSON_TUNINGS_PRINTER_H +#define AARCH64_JSON_TUNINGS_PRINTER_H + +#include "aarch64-protos.h" + +void +aarch64_print_tune_params (const tune_params ¶ms, const char *filename); + +#endif \ No newline at end of file diff --git a/gcc/config/aarch64/aarch64-opts.h b/gcc/config/aarch64/aarch64-opts.h index a6ca5cf016b0..a25b2170c2df 100644 --- a/gcc/config/aarch64/aarch64-opts.h +++ b/gcc/config/aarch64/aarch64-opts.h @@ -142,10 +142,8 @@ enum aarch64_autovec_preference_enum { - LDP_STP_POLICY_ALWAYS: Emit ldp/stp regardless of alignment. - LDP_STP_POLICY_NEVER: Do not emit ldp/stp. */ enum aarch64_ldp_stp_policy { - AARCH64_LDP_STP_POLICY_DEFAULT, - AARCH64_LDP_STP_POLICY_ALIGNED, - AARCH64_LDP_STP_POLICY_ALWAYS, - AARCH64_LDP_STP_POLICY_NEVER +#define AARCH64_LDP_STP_POLICY(NAME, ENUM_VALUE) ENUM_VALUE, +#include "aarch64-tuning-enums.def" }; /* An enum specifying when the early-ra pass should be run: diff --git a/gcc/config/aarch64/aarch64-protos.h b/gcc/config/aarch64/aarch64-protos.h index 68f28bdcae89..11c2938558d4 100644 --- a/gcc/config/aarch64/aarch64-protos.h +++ b/gcc/config/aarch64/aarch64-protos.h @@ -166,88 +166,88 @@ enum aarch64_salt_type { struct scale_addr_mode_cost { - const int hi; - const int si; - const int di; - const int ti; + int hi; + int si; + int di; + int ti; }; /* Additional cost for addresses. */ struct cpu_addrcost_table { - const struct scale_addr_mode_cost addr_scale_costs; - const int pre_modify; - const int post_modify; - const int post_modify_ld3_st3; - const int post_modify_ld4_st4; - const int register_offset; - const int register_sextend; - const int register_zextend; - const int imm_offset; + struct scale_addr_mode_cost addr_scale_costs; + int pre_modify; + int post_modify; + int post_modify_ld3_st3; + int post_modify_ld4_st4; + int register_offset; + int register_sextend; + int register_zextend; + int imm_offset; }; /* Additional costs for register copies. Cost is for one register. */ struct cpu_regmove_cost { - const int GP2GP; - const int GP2FP; - const int FP2GP; - const int FP2FP; + int GP2GP; + int GP2FP; + int FP2GP; + int FP2FP; }; struct simd_vec_cost { /* Cost of any integer vector operation, excluding the ones handled specially below. */ - const int int_stmt_cost; + int int_stmt_cost; /* Cost of any fp vector operation, excluding the ones handled specially below. */ - const int fp_stmt_cost; + int fp_stmt_cost; /* Per-vector cost of permuting vectors after an LD2, LD3 or LD4, as well as the per-vector cost of permuting vectors before an ST2, ST3 or ST4. */ - const int ld2_st2_permute_cost; - const int ld3_st3_permute_cost; - const int ld4_st4_permute_cost; + int ld2_st2_permute_cost; + int ld3_st3_permute_cost; + int ld4_st4_permute_cost; /* Cost of a permute operation. */ - const int permute_cost; + int permute_cost; /* Cost of reductions for various vector types: iN is for N-bit integer elements and fN is for N-bit floating-point elements. We need to single out the element type because it affects the depth of the reduction. */ - const int reduc_i8_cost; - const int reduc_i16_cost; - const int reduc_i32_cost; - const int reduc_i64_cost; - const int reduc_f16_cost; - const int reduc_f32_cost; - const int reduc_f64_cost; + int reduc_i8_cost; + int reduc_i16_cost; + int reduc_i32_cost; + int reduc_i64_cost; + int reduc_f16_cost; + int reduc_f32_cost; + int reduc_f64_cost; /* Additional cost of storing a single vector element, on top of the normal cost of a scalar store. */ - const int store_elt_extra_cost; + int store_elt_extra_cost; /* Cost of a vector-to-scalar operation. */ - const int vec_to_scalar_cost; + int vec_to_scalar_cost; /* Cost of a scalar-to-vector operation. */ - const int scalar_to_vec_cost; + int scalar_to_vec_cost; /* Cost of an aligned vector load. */ - const int align_load_cost; + int align_load_cost; /* Cost of an unaligned vector load. */ - const int unalign_load_cost; + int unalign_load_cost; /* Cost of an unaligned vector store. */ - const int unalign_store_cost; + int unalign_store_cost; /* Cost of a vector store. */ - const int store_cost; + int store_cost; }; typedef struct simd_vec_cost advsimd_vec_cost; @@ -280,27 +280,27 @@ struct sve_vec_cost : simd_vec_cost /* The cost of a vector-to-scalar CLASTA or CLASTB instruction, with the scalar being stored in FP registers. This cost is assumed to be a cycle latency. */ - const int clast_cost; + int clast_cost; /* The costs of FADDA for the three data types that it supports. These costs are assumed to be cycle latencies. */ - const int fadda_f16_cost; - const int fadda_f32_cost; - const int fadda_f64_cost; + int fadda_f16_cost; + int fadda_f32_cost; + int fadda_f64_cost; /* The cost of a gather load instruction. The x32 value is for loads of 32-bit elements and the x64 value is for loads of 64-bit elements. */ - const unsigned int gather_load_x32_cost; - const unsigned int gather_load_x64_cost; + unsigned int gather_load_x32_cost; + unsigned int gather_load_x64_cost; /* Additional loop initialization cost of using a gather load instruction. The x32 value is for loads of 32-bit elements and the x64 value is for loads of 64-bit elements. */ - const int gather_load_x32_init_cost; - const int gather_load_x64_init_cost; + int gather_load_x32_init_cost; + int gather_load_x64_init_cost; /* The per-element cost of a scatter store. */ - const int scatter_store_elt_cost; + int scatter_store_elt_cost; }; /* Base information about how the CPU issues code, containing @@ -319,10 +319,10 @@ struct sve_vec_cost : simd_vec_cost struct aarch64_base_vec_issue_info { /* How many loads and stores can be issued per cycle. */ - const unsigned int loads_stores_per_cycle; + unsigned int loads_stores_per_cycle; /* How many stores can be issued per cycle. */ - const unsigned int stores_per_cycle; + unsigned int stores_per_cycle; /* How many integer or FP/SIMD operations can be issued per cycle. @@ -338,7 +338,7 @@ struct aarch64_base_vec_issue_info This is not very precise, but it's only meant to be a heuristic. We could certainly try to do better in future if there's an example of something that would benefit. */ - const unsigned int general_ops_per_cycle; + unsigned int general_ops_per_cycle; /* How many FP/SIMD operations to count for a floating-point or vector load operation. @@ -347,7 +347,7 @@ struct aarch64_base_vec_issue_info been loaded from memory, these values apply to each individual load. When using an SVE gather load, the values apply to each element of the gather. */ - const unsigned int fp_simd_load_general_ops; + unsigned int fp_simd_load_general_ops; /* How many FP/SIMD operations to count for a floating-point or vector store operation. @@ -355,7 +355,7 @@ struct aarch64_base_vec_issue_info When storing individual elements of an Advanced SIMD vector out to memory, these values apply to each individual store. When using an SVE scatter store, these values apply to each element of the scatter. */ - const unsigned int fp_simd_store_general_ops; + unsigned int fp_simd_store_general_ops; }; using aarch64_scalar_vec_issue_info = aarch64_base_vec_issue_info; @@ -382,9 +382,9 @@ struct aarch64_simd_vec_issue_info : aarch64_base_vec_issue_info load ops: 3 general ops: 3 * (fp_simd_load_general_ops + ld3_st3_general_ops). */ - const unsigned int ld2_st2_general_ops; - const unsigned int ld3_st3_general_ops; - const unsigned int ld4_st4_general_ops; + unsigned int ld2_st2_general_ops; + unsigned int ld3_st3_general_ops; + unsigned int ld4_st4_general_ops; }; using aarch64_advsimd_vec_issue_info = aarch64_simd_vec_issue_info; @@ -411,19 +411,19 @@ struct aarch64_sve_vec_issue_info : aarch64_simd_vec_issue_info {} /* How many predicate operations can be issued per cycle. */ - const unsigned int pred_ops_per_cycle; + unsigned int pred_ops_per_cycle; /* How many predicate operations are generated by a WHILExx instruction. */ - const unsigned int while_pred_ops; + unsigned int while_pred_ops; /* How many predicate operations are generated by an integer comparison instruction. */ - const unsigned int int_cmp_pred_ops; + unsigned int int_cmp_pred_ops; /* How many predicate operations are generated by a floating-point comparison instruction. */ - const unsigned int fp_cmp_pred_ops; + unsigned int fp_cmp_pred_ops; /* How many general and predicate operations are generated by each pair of elements in a gather load or scatter store. These values apply @@ -433,38 +433,38 @@ struct aarch64_sve_vec_issue_info : aarch64_simd_vec_issue_info The reason for using pairs is that that is the largest possible granule size for 128-bit SVE, which can load and store 2 64-bit elements or 4 32-bit elements. */ - const unsigned int gather_scatter_pair_general_ops; - const unsigned int gather_scatter_pair_pred_ops; + unsigned int gather_scatter_pair_general_ops; + unsigned int gather_scatter_pair_pred_ops; }; /* Information related to instruction issue for a particular CPU. */ struct aarch64_vec_issue_info { - const aarch64_base_vec_issue_info *const scalar; - const aarch64_simd_vec_issue_info *const advsimd; - const aarch64_sve_vec_issue_info *const sve; + const aarch64_base_vec_issue_info *scalar; + const aarch64_simd_vec_issue_info *advsimd; + const aarch64_sve_vec_issue_info *sve; }; /* Cost for vector insn classes. */ struct cpu_vector_cost { /* Cost of any integer scalar operation, excluding load and store. */ - const int scalar_int_stmt_cost; + int scalar_int_stmt_cost; /* Cost of any fp scalar operation, excluding load and store. */ - const int scalar_fp_stmt_cost; + int scalar_fp_stmt_cost; /* Cost of a scalar load. */ - const int scalar_load_cost; + int scalar_load_cost; /* Cost of a scalar store. */ - const int scalar_store_cost; + int scalar_store_cost; /* Cost of a taken branch. */ - const int cond_taken_branch_cost; + int cond_taken_branch_cost; /* Cost of a not-taken branch. */ - const int cond_not_taken_branch_cost; + int cond_not_taken_branch_cost; /* Cost of an Advanced SIMD operations. */ const advsimd_vec_cost *advsimd; @@ -473,14 +473,14 @@ struct cpu_vector_cost const sve_vec_cost *sve; /* Issue information, or null if none is provided. */ - const aarch64_vec_issue_info *const issue_info; + const aarch64_vec_issue_info *issue_info; }; /* Branch costs. */ struct cpu_branch_cost { - const int predictable; /* Predictable branch or optimizing for size. */ - const int unpredictable; /* Unpredictable branch or optimizing for speed. */ + int predictable; /* Predictable branch or optimizing for size. */ + int unpredictable; /* Unpredictable branch or optimizing for speed. */ }; /* Control approximate alternatives to certain FP operators. */ @@ -497,25 +497,25 @@ struct cpu_branch_cost /* Allowed modes for approximations. */ struct cpu_approx_modes { - const uint64_t division; /* Division. */ - const uint64_t sqrt; /* Square root. */ - const uint64_t recip_sqrt; /* Reciprocal square root. */ + uint64_t division; /* Division. */ + uint64_t sqrt; /* Square root. */ + uint64_t recip_sqrt; /* Reciprocal square root. */ }; /* Cache prefetch settings for prefetch-loop-arrays. */ struct cpu_prefetch_tune { - const int num_slots; - const int l1_cache_size; - const int l1_cache_line_size; - const int l2_cache_size; + int num_slots; + int l1_cache_size; + int l1_cache_line_size; + int l2_cache_size; /* Whether software prefetch hints should be issued for non-constant strides. */ - const bool prefetch_dynamic_strides; + bool prefetch_dynamic_strides; /* The minimum constant stride beyond which we should use prefetch hints for. */ - const int minimum_stride; - const int default_opt_level; + int minimum_stride; + int default_opt_level; }; /* Model the costs for loads/stores for the register allocators so that it can @@ -568,9 +568,8 @@ struct tune_params enum aarch64_autoprefetch_model { - AUTOPREFETCHER_OFF, - AUTOPREFETCHER_WEAK, - AUTOPREFETCHER_STRONG +#define AARCH64_AUTOPREFETCH_MODE(NAME, ENUM_VALUE) ENUM_VALUE, +#include "aarch64-tuning-enums.def" } autoprefetcher_model; unsigned int extra_tuning_flags; diff --git a/gcc/config/aarch64/aarch64-tuning-enums.def b/gcc/config/aarch64/aarch64-tuning-enums.def new file mode 100644 index 000000000000..701b64fe8b5f --- /dev/null +++ b/gcc/config/aarch64/aarch64-tuning-enums.def @@ -0,0 +1,37 @@ +/* AArch64 tuning parameter enum definitions. + Copyright The GNU Toolchain Authors. + + This file is part of GCC. + + GCC is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + GCC is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with GCC; see the file COPYING3. If not see + . */ + +/* This file contains the enum definitions for AArch64 tuning parameters + that are used in both the JSON parser/printer and the tuning structures. */ + +#ifdef AARCH64_AUTOPREFETCH_MODE +AARCH64_AUTOPREFETCH_MODE("AUTOPREFETCHER_OFF", AUTOPREFETCHER_OFF) +AARCH64_AUTOPREFETCH_MODE("AUTOPREFETCHER_WEAK", AUTOPREFETCHER_WEAK) +AARCH64_AUTOPREFETCH_MODE("AUTOPREFETCHER_STRONG", AUTOPREFETCHER_STRONG) +#endif + +#ifdef AARCH64_LDP_STP_POLICY +AARCH64_LDP_STP_POLICY("AARCH64_LDP_STP_POLICY_DEFAULT", AARCH64_LDP_STP_POLICY_DEFAULT) +AARCH64_LDP_STP_POLICY("AARCH64_LDP_STP_POLICY_ALIGNED", AARCH64_LDP_STP_POLICY_ALIGNED) +AARCH64_LDP_STP_POLICY("AARCH64_LDP_STP_POLICY_ALWAYS", AARCH64_LDP_STP_POLICY_ALWAYS) +AARCH64_LDP_STP_POLICY("AARCH64_LDP_STP_POLICY_NEVER", AARCH64_LDP_STP_POLICY_NEVER) +#endif + +#undef AARCH64_AUTOPREFETCH_MODE +#undef AARCH64_LDP_STP_POLICY diff --git a/gcc/config/aarch64/aarch64.cc b/gcc/config/aarch64/aarch64.cc index 89097e237728..d8c99d8e3c27 100644 --- a/gcc/config/aarch64/aarch64.cc +++ b/gcc/config/aarch64/aarch64.cc @@ -99,6 +99,8 @@ #include "ipa-fnsummary.h" #include "hash-map.h" #include "aarch64-sched-dispatch.h" +#include "aarch64-json-tunings-printer.h" +#include "aarch64-json-tunings-parser.h" /* This file should be included last. */ #include "target-def.h" @@ -19169,12 +19171,30 @@ aarch64_override_options_internal (struct gcc_options *opts) aarch64_parse_override_string (opts->x_aarch64_override_tune_string, &aarch64_tune_params); + /* We need to parse the JSON file only once per program execution. */ + if (opts->x_muser_provided_CPU) + { + static bool json_parsed = false; + static struct tune_params aarch64_json_params; + if (!json_parsed) + { + aarch64_json_params = *(tune->tune); + aarch64_load_tuning_params_from_json (opts->x_muser_provided_CPU, + &aarch64_json_params); + json_parsed = true; + } + aarch64_tune_params = aarch64_json_params; + } + if (opts->x_aarch64_ldp_policy_param) aarch64_tune_params.ldp_policy_model = opts->x_aarch64_ldp_policy_param; if (opts->x_aarch64_stp_policy_param) aarch64_tune_params.stp_policy_model = opts->x_aarch64_stp_policy_param; + if (opts->x_fdump_tuning_model) + aarch64_print_tune_params (aarch64_tune_params, opts->x_fdump_tuning_model); + /* This target defaults to strict volatile bitfields. */ if (opts->x_flag_strict_volatile_bitfields < 0 && abi_version_at_least (2)) opts->x_flag_strict_volatile_bitfields = 1; @@ -32421,6 +32441,8 @@ aarch64_test_sve_folding () } } +extern void aarch64_json_tunings_tests (); + /* Run all target-specific selftests. */ static void @@ -32430,6 +32452,7 @@ aarch64_run_selftests (void) aarch64_test_fractional_cost (); aarch64_test_sysreg_encoding_clashes (); aarch64_test_sve_folding (); + aarch64_json_tunings_tests (); } } // namespace selftest diff --git a/gcc/config/aarch64/aarch64.md b/gcc/config/aarch64/aarch64.md index de6b1d0ed06b..fde4fabb7ef4 100644 --- a/gcc/config/aarch64/aarch64.md +++ b/gcc/config/aarch64/aarch64.md @@ -479,7 +479,7 @@ ;; Q registers and is equivalent to "simd". (define_enum "arches" [any rcpc8_4 fp fp_q base_simd nobase_simd - simd nosimd sve fp16 sme]) + simd nosimd sve fp16 sme cssc]) (define_enum_attr "arch" "arches" (const_string "any")) @@ -551,6 +551,9 @@ (and (eq_attr "arch" "fp16") (match_test "TARGET_FP_F16INST")) + (and (eq_attr "arch" "cssc") + (match_test "TARGET_CSSC")) + (and (eq_attr "arch" "sve") (match_test "TARGET_SVE")) @@ -4482,6 +4485,66 @@ [(set_attr "type" "div")] ) +;; umax (a, add (a, b)) => [sum, ovf] = adds (a, b); !ovf ? sum : a +;; umin (a, add (a, b)) => [sum, ovf] = adds (a, b); !ovf ? a : sum +;; ... and the commutated versions: +;; umax (a, add (b, a)) => [sum, ovf] = adds (b, a); !ovf ? sum : a +;; umin (a, add (b, a)) => [sum, ovf] = adds (b, a); !ovf ? a : sum +(define_insn_and_split "*aarch64_plus_within_3_" + [(set (match_operand:GPI 0 "register_operand" "=r") + (UMAXMIN:GPI + (plus:GPI (match_operand:GPI 1 "register_operand" "r") + (match_operand:GPI 2 "register_operand" "r")) + (match_dup ovf_commutate))) + (clobber (match_scratch:GPI 3 "=r"))] + "!TARGET_CSSC" + "#" + "&& 1" + [(parallel + [(set (reg:CC_C CC_REGNUM) + (compare:CC_C (plus:GPI (match_dup ovf_commutate) + (match_dup )) + (match_dup ovf_commutate))) + (set (match_dup 3) (plus:GPI (match_dup ovf_commutate) + (match_dup )))]) + (set (match_dup 0) + (if_then_else:GPI ( (reg:CC_C CC_REGNUM) + (const_int 0)) + (match_dup 3) + (match_dup ovf_commutate)))] + { + if (GET_CODE (operands[3]) == SCRATCH) + operands[3] = gen_reg_rtx (mode); + } +) + +;; umax (a, sub (a, b)) => [diff, udf] = subs (a, b); udf ? diff : a +;; umin (a, sub (a, b)) => [diff, udf] = subs (a, b); udf ? a : diff +(define_insn_and_split "*aarch64_minus_within_3" + [(set (match_operand:GPI 0 "register_operand" "=r") + (UMAXMIN:GPI + (minus:GPI (match_operand:GPI 1 "register_operand" "r") + (match_operand:GPI 2 "register_operand" "r")) + (match_dup 1))) + (clobber (match_scratch:GPI 3 "=r"))] + "!TARGET_CSSC" + "#" + "&& 1" + [(parallel + [(set (reg:CC CC_REGNUM) + (compare:CC (match_dup 1) (match_dup 2))) + (set (match_dup 3) (minus:GPI (match_dup 1) (match_dup 2)))]) + (set (match_dup 0) + (if_then_else:GPI ( (reg:CC CC_REGNUM) + (const_int 0)) + (match_dup 3) + (match_dup 1)))] + { + if (GET_CODE (operands[3]) == SCRATCH) + operands[3] = gen_reg_rtx (mode); + } +) + ;; ------------------------------------------------------------------- ;; Comparison insns ;; ------------------------------------------------------------------- @@ -5637,6 +5700,8 @@ [(set_attr "type" "logics_shift_imm")] ) +;; CLZ, CTZ, CLS, RBIT instructions. + (define_insn "clz2" [(set (match_operand:GPI 0 "register_operand" "=r") (clz:GPI (match_operand:GPI 1 "register_operand" "r")))] @@ -5645,6 +5710,35 @@ [(set_attr "type" "clz")] ) +;; Model ctz as a target instruction. +;; If TARGET_CSSC is not available, emit rbit and clz. + +(define_insn "ctz2" + [(set (match_operand:GPI 0 "register_operand") + (ctz:GPI (match_operand:GPI 1 "register_operand")))] + "" + {@ [ cons: =0, 1; attrs: type, arch, length ] + [ r , r; clz, cssc, 4 ] ctz\\t%0, %1 + [ r , r; clz, * , 8 ] rbit\\t%0, %1\;clz\\t%0, %0 + } +) + +(define_insn "clrsb2" + [(set (match_operand:GPI 0 "register_operand" "=r") + (clrsb:GPI (match_operand:GPI 1 "register_operand" "r")))] + "" + "cls\\t%0, %1" + [(set_attr "type" "clz")] +) + +(define_insn "@aarch64_rbit" + [(set (match_operand:GPI 0 "register_operand" "=r") + (bitreverse:GPI (match_operand:GPI 1 "register_operand" "r")))] + "" + "rbit\\t%0, %1" + [(set_attr "type" "rbit")] +) + (define_expand "ffs2" [(match_operand:GPI 0 "register_operand") (match_operand:GPI 1 "register_operand")] @@ -5652,9 +5746,7 @@ { rtx ccreg = aarch64_gen_compare_reg (EQ, operands[1], const0_rtx); rtx x = gen_rtx_NE (VOIDmode, ccreg, const0_rtx); - - emit_insn (gen_aarch64_rbit (mode, operands[0], operands[1])); - emit_insn (gen_clz2 (operands[0], operands[0])); + emit_insn (gen_ctz2 (operands[0], operands[1])); emit_insn (gen_csinc3_insn (operands[0], x, operands[0], const0_rtx)); DONE; } @@ -5749,40 +5841,6 @@ DONE; }) -(define_insn "clrsb2" - [(set (match_operand:GPI 0 "register_operand" "=r") - (clrsb:GPI (match_operand:GPI 1 "register_operand" "r")))] - "" - "cls\\t%0, %1" - [(set_attr "type" "clz")] -) - -(define_insn "@aarch64_rbit" - [(set (match_operand:GPI 0 "register_operand" "=r") - (bitreverse:GPI (match_operand:GPI 1 "register_operand" "r")))] - "" - "rbit\\t%0, %1" - [(set_attr "type" "rbit")] -) - -;; Split after reload into RBIT + CLZ. Since RBIT is represented as an UNSPEC -;; it is unlikely to fold with any other operation, so keep this as a CTZ -;; expression and split after reload to enable scheduling them apart if -;; needed. For TARGET_CSSC we have a single CTZ instruction that can do this. - -(define_insn_and_split "ctz2" - [(set (match_operand:GPI 0 "register_operand" "=r") - (ctz:GPI (match_operand:GPI 1 "register_operand" "r")))] - "" - { return TARGET_CSSC ? "ctz\\t%0, %1" : "#"; } - "reload_completed && !TARGET_CSSC" - [(const_int 0)] - " - emit_insn (gen_aarch64_rbit (mode, operands[0], operands[1])); - emit_insn (gen_clz2 (operands[0], operands[0])); - DONE; -") - (define_insn "*and_compare0" [(set (reg:CC_Z CC_REGNUM) (compare:CC_Z diff --git a/gcc/config/aarch64/aarch64.opt b/gcc/config/aarch64/aarch64.opt index fc3f632d93b1..6c0cbc7b64dd 100644 --- a/gcc/config/aarch64/aarch64.opt +++ b/gcc/config/aarch64/aarch64.opt @@ -193,6 +193,14 @@ mabi= Target RejectNegative Joined Enum(aarch64_abi) Var(aarch64_abi) Init(AARCH64_ABI_DEFAULT) Generate code that conforms to the specified ABI. +fdump-tuning-model= +Target Undocumented RejectNegative Negative(fdump-tuning-model=) Joined Var(fdump_tuning_model) +-fdump-tuning-model= Dump current tuning model to a JSON file. + +muser-provided-CPU= +Target Undocumented RejectNegative Negative(muser-provided-CPU=) Joined Var(muser_provided_CPU) +-muser-provided-CPU= User specific CPU tunings. + moverride= Target RejectNegative ToLower Joined Var(aarch64_override_tune_string) Save -moverride= Power users only! Override CPU optimization parameters. @@ -449,5 +457,5 @@ also try to opportunistically form writeback opportunities by folding in trailing destructive updates of the base register used by a pair. Wexperimental-fmv-target -Target Var(warn_experimental_fmv) Warning Init(1) +Target Var(warn_experimental_fmv) Warning Init(1) Undocumented This option is deprecated. diff --git a/gcc/config/aarch64/aarch64.opt.urls b/gcc/config/aarch64/aarch64.opt.urls index 993e0fc9c4d7..f0087b280f7a 100644 --- a/gcc/config/aarch64/aarch64.opt.urls +++ b/gcc/config/aarch64/aarch64.opt.urls @@ -77,8 +77,14 @@ UrlSuffix(gcc/AArch64-Options.html#index-mearly-ra) msve-vector-bits= UrlSuffix(gcc/AArch64-Options.html#index-msve-vector-bits) -mverbose-cost-dump -UrlSuffix(gcc/AArch64-Options.html#index-mverbose-cost-dump) +mautovec-preference= +UrlSuffix(gcc/AArch64-Options.html#index-mautovec-preference) + +mmax-vectorization +UrlSuffix(gcc/AArch64-Options.html#index-mmax-vectorization) + +mtrack-speculation +UrlSuffix(gcc/AArch64-Options.html#index-mtrack-speculation) mearly-ldp-fusion UrlSuffix(gcc/AArch64-Options.html#index-mearly-ldp-fusion) @@ -95,6 +101,6 @@ UrlSuffix(gcc/AArch64-Options.html#index-mstack-protector-guard-reg) mstack-protector-guard-offset= UrlSuffix(gcc/AArch64-Options.html#index-mstack-protector-guard-offset) -Wexperimental-fmv-target -UrlSuffix(gcc/AArch64-Options.html#index-Wexperimental-fmv-target) +moutline-atomics +UrlSuffix(gcc/AArch64-Options.html#index-moutline-atomics) diff --git a/gcc/config/aarch64/atomics.md b/gcc/config/aarch64/atomics.md index ea4a9367fc88..d4b4afb5815d 100644 --- a/gcc/config/aarch64/atomics.md +++ b/gcc/config/aarch64/atomics.md @@ -870,7 +870,13 @@ enum memmodel model = memmodel_from_int (INTVAL (operands[1])); if (is_mm_acquire (model)) return "dmb\\tishld"; + else if (is_mm_release (model)) + return "dmb\\tishld\;dmb\\tishst"; else return "dmb\\tish"; } + [(set (attr "length") + (if_then_else + (match_test "is_mm_release (memmodel_from_int (INTVAL (operands[1])))") + (const_int 8) (const_int 4)))] ) diff --git a/gcc/config/aarch64/iterators.md b/gcc/config/aarch64/iterators.md index 82579b05ff7a..ff5688529d38 100644 --- a/gcc/config/aarch64/iterators.md +++ b/gcc/config/aarch64/iterators.md @@ -2853,6 +2853,8 @@ (define_code_iterator FMAXMIN [smax smin]) +(define_code_iterator UMAXMIN [umax umin]) + ;; Signed and unsigned max operations. (define_code_iterator USMAX [smax umax]) @@ -3141,6 +3143,9 @@ (define_code_attr maxminand [(smax "bic") (smin "and")]) +(define_code_attr ovf_add_cmp [(umax "geu") (umin "ltu")]) +(define_code_attr udf_sub_cmp [(umax "ltu") (umin "geu")]) + ;; MLA/MLS attributes. (define_code_attr as [(ss_plus "a") (ss_minus "s")]) @@ -5164,3 +5169,7 @@ (UNSPEC_F2CVT "f2cvt") (UNSPEC_F1CVTLT "f1cvtlt") (UNSPEC_F2CVTLT "f2cvtlt")]) + +;; Operand numbers for commutative operations +(define_int_iterator ovf_commutate [1 2]) +(define_int_attr ovf_comm_opp [(1 "2") (2 "1")]) diff --git a/gcc/config/aarch64/t-aarch64 b/gcc/config/aarch64/t-aarch64 index 71242f05b091..6f63a9f55126 100644 --- a/gcc/config/aarch64/t-aarch64 +++ b/gcc/config/aarch64/t-aarch64 @@ -47,6 +47,12 @@ else endif $(STAMP) s-aarch64-tune-md +# Regenerate the JSON tuning files if the schema has changed +$(srcdir)/config/aarch64/aarch64-json-tunings-%-generated.inc: \ +$(srcdir)/config/aarch64/aarch64-json-schema.h \ +$(srcdir)/config/aarch64/aarch64-generate-json-tuning-routines.py + $(PYTHON) $(srcdir)/config/aarch64/aarch64-generate-json-tuning-routines.py --generate-only $* + s-mddeps: s-aarch64-tune-md aarch64-builtins.o: $(srcdir)/config/aarch64/aarch64-builtins.cc $(CONFIG_H) \ @@ -210,6 +216,27 @@ aarch64-sched-dispatch.o: $(srcdir)/config/aarch64/aarch64-sched-dispatch.cc \ $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ $(srcdir)/config/aarch64/aarch64-sched-dispatch.cc +aarch64-json-tunings-printer.o: $(srcdir)/config/aarch64/aarch64-json-tunings-printer.cc \ + $(CONFIG_H) $(SYSTEM_H) $(CORETYPES_H) $(TM_H) $(DIAGNOSTIC_CORE_H) \ + $(PRETTY_PRINT_H) json.h \ + $(srcdir)/config/aarch64/aarch64-json-tunings-printer.h \ + $(srcdir)/config/aarch64/aarch64-json-tunings-printer-generated.inc \ + $(srcdir)/config/aarch64/aarch64-protos.h \ + $(srcdir)/config/arm/aarch-common-protos.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ + $(srcdir)/config/aarch64/aarch64-json-tunings-printer.cc + +aarch64-json-tunings-parser.o: $(srcdir)/config/aarch64/aarch64-json-tunings-parser.cc \ + $(CONFIG_H) $(SYSTEM_H) $(CORETYPES_H) $(TM_H) $(DIAGNOSTIC_CORE_H) \ + json-parsing.h \ + $(srcdir)/config/aarch64/aarch64-json-schema.h \ + $(srcdir)/config/aarch64/aarch64-json-tunings-parser.h \ + $(srcdir)/config/aarch64/aarch64-json-tunings-parser-generated.inc \ + $(srcdir)/config/aarch64/aarch64-protos.h \ + $(srcdir)/config/arm/aarch-common-protos.h + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ + $(srcdir)/config/aarch64/aarch64-json-tunings-parser.cc + comma=, MULTILIB_OPTIONS = $(subst $(comma),/, $(patsubst %, mabi=%, $(subst $(comma),$(comma)mabi=,$(TM_MULTILIB_CONFIG)))) MULTILIB_DIRNAMES = $(subst $(comma), ,$(TM_MULTILIB_CONFIG)) diff --git a/gcc/config/alpha/alpha.opt b/gcc/config/alpha/alpha.opt index 3c1320b5112d..31f4cb5ed61b 100644 --- a/gcc/config/alpha/alpha.opt +++ b/gcc/config/alpha/alpha.opt @@ -27,7 +27,7 @@ Target Mask(FPREGS) Use fp registers. mgas -Target Ignore +Target Ignore Undocumented Does nothing. Preserved for backward compatibility. mieee-conformant diff --git a/gcc/config/alpha/alpha.opt.urls b/gcc/config/alpha/alpha.opt.urls index 93615877ee3e..df814cd11c9c 100644 --- a/gcc/config/alpha/alpha.opt.urls +++ b/gcc/config/alpha/alpha.opt.urls @@ -1,7 +1,7 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/config/alpha/alpha.opt and generated HTML msoft-float -UrlSuffix(gcc/DEC-Alpha-Options.html#index-msoft-float-2) +UrlSuffix(gcc/DEC-Alpha-Options.html#index-msoft-float-1) ; skipping UrlSuffix for 'mgas' due to finding no URLs @@ -56,9 +56,14 @@ UrlSuffix(gcc/DEC-Alpha-Options.html#index-msmall-text) mlarge-text UrlSuffix(gcc/DEC-Alpha-Options.html#index-mlarge-text) -; skipping UrlSuffix for 'mlong-double-128' due to finding no URLs +mtls-kernel +UrlSuffix(gcc/DEC-Alpha-Options.html#index-mtls-kernel) -; skipping UrlSuffix for 'mlong-double-64' due to finding no URLs +mlong-double-128 +UrlSuffix(gcc/DEC-Alpha-Options.html#index-mlong-double-128) + +mlong-double-64 +UrlSuffix(gcc/DEC-Alpha-Options.html#index-mlong-double-64) mcpu= UrlSuffix(gcc/DEC-Alpha-Options.html#index-mcpu-4) @@ -78,5 +83,6 @@ UrlSuffix(gcc/DEC-Alpha-Options.html#index-mtrap-precision) mmemory-latency= UrlSuffix(gcc/DEC-Alpha-Options.html#index-mmemory-latency) -; skipping UrlSuffix for 'mtls-size=' due to finding no URLs +mtls-size= +UrlSuffix(gcc/DEC-Alpha-Options.html#index-mtls-size-1) diff --git a/gcc/config/arm/aarch-common-protos.h b/gcc/config/arm/aarch-common-protos.h index 077387b9f902..1bafdbaa72f7 100644 --- a/gcc/config/arm/aarch-common-protos.h +++ b/gcc/config/arm/aarch-common-protos.h @@ -57,33 +57,33 @@ extern bool aarch_fun_is_indirect_return (rtx_insn *); Costs may not have a negative value. */ struct alu_cost_table { - const int arith; /* ADD/SUB. */ - const int logical; /* AND/ORR/EOR/BIC, etc. */ - const int shift; /* Simple shift. */ - const int shift_reg; /* Simple shift by reg. */ - const int arith_shift; /* Additional when arith also shifts... */ - const int arith_shift_reg; /* ... and when the shift is by a reg. */ - const int log_shift; /* Additional when logic also shifts... */ - const int log_shift_reg; /* ... and when the shift is by a reg. */ - const int extend; /* Zero/sign extension. */ - const int extend_arith; /* Extend and arith. */ - const int bfi; /* Bit-field insert. */ - const int bfx; /* Bit-field extraction. */ - const int clz; /* Count Leading Zeros. */ - const int rev; /* Reverse bits/bytes. */ - const int non_exec; /* Extra cost when not executing insn. */ - const bool non_exec_costs_exec; /* True if non-execution must add the exec + int arith; /* ADD/SUB. */ + int logical; /* AND/ORR/EOR/BIC, etc. */ + int shift; /* Simple shift. */ + int shift_reg; /* Simple shift by reg. */ + int arith_shift; /* Additional when arith also shifts... */ + int arith_shift_reg; /* ... and when the shift is by a reg. */ + int log_shift; /* Additional when logic also shifts... */ + int log_shift_reg; /* ... and when the shift is by a reg. */ + int extend; /* Zero/sign extension. */ + int extend_arith; /* Extend and arith. */ + int bfi; /* Bit-field insert. */ + int bfx; /* Bit-field extraction. */ + int clz; /* Count Leading Zeros. */ + int rev; /* Reverse bits/bytes. */ + int non_exec; /* Extra cost when not executing insn. */ + bool non_exec_costs_exec; /* True if non-execution must add the exec cost. */ }; struct mult_cost_table { - const int simple; - const int flag_setting; /* Additional cost if multiply sets flags. */ - const int extend; - const int add; - const int extend_add; - const int idiv; + int simple; + int flag_setting; /* Additional cost if multiply sets flags. */ + int extend; + int add; + int extend_add; + int idiv; }; /* Calculations of LDM costs are complex. We assume an initial cost @@ -98,60 +98,60 @@ struct mult_cost_table */ struct mem_cost_table { - const int load; - const int load_sign_extend; /* Additional to load cost. */ - const int ldrd; /* Cost of LDRD. */ - const int ldm_1st; - const int ldm_regs_per_insn_1st; - const int ldm_regs_per_insn_subsequent; - const int loadf; /* SFmode. */ - const int loadd; /* DFmode. */ - const int load_unaligned; /* Extra for unaligned loads. */ - const int store; - const int strd; - const int stm_1st; - const int stm_regs_per_insn_1st; - const int stm_regs_per_insn_subsequent; - const int storef; /* SFmode. */ - const int stored; /* DFmode. */ - const int store_unaligned; /* Extra for unaligned stores. */ - const int loadv; /* Vector load. */ - const int storev; /* Vector store. */ + int load; + int load_sign_extend; /* Additional to load cost. */ + int ldrd; /* Cost of LDRD. */ + int ldm_1st; + int ldm_regs_per_insn_1st; + int ldm_regs_per_insn_subsequent; + int loadf; /* SFmode. */ + int loadd; /* DFmode. */ + int load_unaligned; /* Extra for unaligned loads. */ + int store; + int strd; + int stm_1st; + int stm_regs_per_insn_1st; + int stm_regs_per_insn_subsequent; + int storef; /* SFmode. */ + int stored; /* DFmode. */ + int store_unaligned; /* Extra for unaligned stores. */ + int loadv; /* Vector load. */ + int storev; /* Vector store. */ }; struct fp_cost_table { - const int div; - const int mult; - const int mult_addsub; /* Non-fused. */ - const int fma; /* Fused. */ - const int addsub; - const int fpconst; /* Immediate. */ - const int neg; /* NEG and ABS. */ - const int compare; - const int widen; /* Widen to this size. */ - const int narrow; /* Narrow from this size. */ - const int toint; - const int fromint; - const int roundint; /* V8 round to integral, remains FP format. */ + int div; + int mult; + int mult_addsub; /* Non-fused. */ + int fma; /* Fused. */ + int addsub; + int fpconst; /* Immediate. */ + int neg; /* NEG and ABS. */ + int compare; + int widen; /* Widen to this size. */ + int narrow; /* Narrow from this size. */ + int toint; + int fromint; + int roundint; /* V8 round to integral, remains FP format. */ }; struct vector_cost_table { - const int alu; - const int mult; - const int movi; - const int dup; - const int extract; + int alu; + int mult; + int movi; + int dup; + int extract; }; struct cpu_cost_table { - const struct alu_cost_table alu; - const struct mult_cost_table mult[2]; /* SImode and DImode. */ - const struct mem_cost_table ldst; - const struct fp_cost_table fp[2]; /* SFmode and DFmode. */ - const struct vector_cost_table vect; + struct alu_cost_table alu; + struct mult_cost_table mult[2]; /* SImode and DImode. */ + struct mem_cost_table ldst; + struct fp_cost_table fp[2]; /* SFmode and DFmode. */ + struct vector_cost_table vect; }; rtx_insn *arm_md_asm_adjust (vec &outputs, vec & /*inputs*/, diff --git a/gcc/config/arm/arm-builtins.cc b/gcc/config/arm/arm-builtins.cc index b0bbb32644c5..b421cac51cfe 100644 --- a/gcc/config/arm/arm-builtins.cc +++ b/gcc/config/arm/arm-builtins.cc @@ -1449,7 +1449,7 @@ arm_init_cde_builtins (void) static void arm_init_mve_builtins (void) { - volatile unsigned int i, fcode = ARM_BUILTIN_MVE_PATTERN_START; + unsigned int i, fcode = ARM_BUILTIN_MVE_PATTERN_START; arm_init_simd_builtin_scalar_types (); arm_init_simd_builtin_types (); diff --git a/gcc/config/arm/arm.cc b/gcc/config/arm/arm.cc index 07d24d1f67ed..20d3f1f4578b 100644 --- a/gcc/config/arm/arm.cc +++ b/gcc/config/arm/arm.cc @@ -24064,7 +24064,7 @@ arm_print_condition (FILE *stream) /* Globally reserved letters: acln - Puncutation letters currently used: @_|?().!# + Puncutation letters currently used: @_-|?().!# Lower case letters currently used: bcdefhimpqtvwxyz Upper case letters currently used: ABCDEFGHIJKLMOPQRSTUV Letters previously used, but now deprecated/obsolete: sNWXYZ. @@ -24097,6 +24097,11 @@ arm_print_operand (FILE *stream, rtx x, int code) case '_': fputs (user_label_prefix, stream); return; + case '-': +#ifdef LOCAL_LABEL_PREFIX + fputs (LOCAL_LABEL_PREFIX, stream); +#endif + return; case '|': fputs (REGISTER_PREFIX, stream); @@ -24913,9 +24918,9 @@ arm_print_operand_punct_valid_p (unsigned char code) { return (code == '@' || code == '|' || code == '.' || code == '(' || code == ')' || code == '#' + || code == '-' || code == '_' || (TARGET_32BIT && (code == '?')) - || (TARGET_THUMB2 && (code == '!')) - || (TARGET_THUMB && (code == '_'))); + || (TARGET_THUMB2 && (code == '!'))); } /* Target hook for assembling integer objects. The ARM version needs to diff --git a/gcc/config/arm/arm.opt b/gcc/config/arm/arm.opt index caa08d120cef..f340feeb510e 100644 --- a/gcc/config/arm/arm.opt +++ b/gcc/config/arm/arm.opt @@ -72,11 +72,12 @@ Target Mask(APCS_FRAME) Generate APCS conformant stack frames. mapcs-reentrant -Target Mask(APCS_REENT) -Generate re-entrant, PIC code. +Target Mask(APCS_REENT) Undocumented +Unimplemented option to generate re-entrant, PIC code. mapcs-stack-check Target Mask(APCS_STACK) Undocumented +Unimplemented option to generate stack checking code on function entry. march= Target Save RejectNegative Negative(march=) ToLower Joined Var(arm_arch_string) @@ -248,7 +249,7 @@ Target Save RejectNegative Negative(mtune=) ToLower Joined Var(arm_tune_string) Tune code for the given processor. mprint-tune-info -Target RejectNegative Var(print_tune_info) Init(0) +Target RejectNegative Var(print_tune_info) Init(0) Undocumented Print CPU tuning information as comment in assembler file. This is an option used only for regression testing of the compiler and not intended for ordinary use in compiling code. @@ -302,7 +303,7 @@ Target Var(unaligned_access) Init(2) Save Enable unaligned word and halfword accesses to packed data. mneon-for-64bits -Target WarnRemoved +Target WarnRemoved Undocumented This option is deprecated and has no effect. mslow-flash-data diff --git a/gcc/config/arm/arm.opt.urls b/gcc/config/arm/arm.opt.urls index b3696f78bc73..93c6fce197c3 100644 --- a/gcc/config/arm/arm.opt.urls +++ b/gcc/config/arm/arm.opt.urls @@ -36,9 +36,6 @@ UrlSuffix(gcc/ARM-Options.html#index-mfloat-abi) mcmse UrlSuffix(gcc/ARM-Options.html#index-mcmse) -mflip-thumb -UrlSuffix(gcc/ARM-Options.html#index-mflip-thumb) - mfp16-format= UrlSuffix(gcc/ARM-Options.html#index-mfp16-format) @@ -94,12 +91,6 @@ UrlSuffix(gcc/ARM-Options.html#index-mtpcs-leaf-frame) mtune= UrlSuffix(gcc/ARM-Options.html#index-mtune-4) -mprint-tune-info -UrlSuffix(gcc/ARM-Options.html#index-mprint-tune-info) - -mverbose-cost-dump -UrlSuffix(gcc/ARM-Options.html#index-mverbose-cost-dump-1) - mword-relocations UrlSuffix(gcc/ARM-Options.html#index-mword-relocations) @@ -115,9 +106,6 @@ UrlSuffix(gcc/ARM-Options.html#index-mfix-cmse-cve-2021-35465) munaligned-access UrlSuffix(gcc/ARM-Options.html#index-munaligned-access) -mneon-for-64bits -UrlSuffix(gcc/ARM-Options.html#index-mneon-for-64bits) - mslow-flash-data UrlSuffix(gcc/ARM-Options.html#index-mslow-flash-data) diff --git a/gcc/config/arm/thumb2.md b/gcc/config/arm/thumb2.md index 40c0e052946c..c3539958f8a3 100644 --- a/gcc/config/arm/thumb2.md +++ b/gcc/config/arm/thumb2.md @@ -1464,19 +1464,24 @@ (pc))) (clobber (reg:CC CC_REGNUM))] "TARGET_THUMB2" - "* - if (get_attr_length (insn) == 2) - return \"cbz\\t%0, %l1\"; - else - return \"cmp\\t%0, #0\;beq\\t%l1\"; - " + { + int offset = (INSN_ADDRESSES (INSN_UID (operands[1])) + - INSN_ADDRESSES (INSN_UID (insn))); + if (get_attr_length (insn) == 2) + return "cbz\t%0, %l1"; + else if (offset >= -1048564 && offset <= 1048576) + return "cmp\t%0, #0\;beq\t%l1"; + else if (which_alternative == 0) + return "cbnz\t%0, %-LCB%=\;b\t%l1\n%-LCB%=:"; + return "cmp\t%0, #0\;bne\t%-LCB%=\;b\t%l1\n%-LCB%=:"; + } [(set (attr "length") (if_then_else (and (ge (minus (match_dup 1) (pc)) (const_int 2)) (le (minus (match_dup 1) (pc)) (const_int 128)) (not (match_test "which_alternative"))) (const_int 2) - (const_int 8))) + (const_int 10))) (set_attr "type" "branch,multiple")] ) @@ -1488,19 +1493,24 @@ (pc))) (clobber (reg:CC CC_REGNUM))] "TARGET_THUMB2" - "* - if (get_attr_length (insn) == 2) - return \"cbnz\\t%0, %l1\"; - else - return \"cmp\\t%0, #0\;bne\\t%l1\"; - " + { + int offset = (INSN_ADDRESSES (INSN_UID (operands[1])) + - INSN_ADDRESSES (INSN_UID (insn))); + if (get_attr_length (insn) == 2) + return "cbnz\t%0, %l1"; + else if (offset >= -1048564 && offset <= 1048576) + return "cmp\t%0, #0\;bne\t%l1"; + else if (which_alternative == 0) + return "cbz\t%0, %-LCB%=\;b\t%l1\n%-LCB%=:"; + return "cmp\t%0, #0\;beq\t%-LCB%=\;b\t%l1\n%-LCB%=:"; + } [(set (attr "length") (if_then_else (and (ge (minus (match_dup 1) (pc)) (const_int 2)) (le (minus (match_dup 1) (pc)) (const_int 128)) (not (match_test "which_alternative"))) (const_int 2) - (const_int 8))) + (const_int 10))) (set_attr "type" "branch,multiple")] ) diff --git a/gcc/config/avr/avr-mcus.def b/gcc/config/avr/avr-mcus.def index 896623d039e3..8b05af545070 100644 --- a/gcc/config/avr/avr-mcus.def +++ b/gcc/config/avr/avr-mcus.def @@ -421,6 +421,14 @@ AVR_MCU ("avr16ea48", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR AVR_MCU ("avr32ea28", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR32EA28__", 0x7000, 0x0, 0x8000, 0x8000) AVR_MCU ("avr32ea32", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR32EA32__", 0x7000, 0x0, 0x8000, 0x8000) AVR_MCU ("avr32ea48", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR32EA48__", 0x7000, 0x0, 0x8000, 0x8000) +AVR_MCU ("avr16la14", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR16LA14__", 0x7800, 0x0, 0x4000, 0x8000) +AVR_MCU ("avr16la20", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR16LA20__", 0x7800, 0x0, 0x4000, 0x8000) +AVR_MCU ("avr16la28", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR16LA28__", 0x7800, 0x0, 0x4000, 0x8000) +AVR_MCU ("avr16la32", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR16LA32__", 0x7800, 0x0, 0x4000, 0x8000) +AVR_MCU ("avr32la14", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR32LA14__", 0x7800, 0x0, 0x8000, 0x8000) +AVR_MCU ("avr32la20", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR32LA20__", 0x7800, 0x0, 0x8000, 0x8000) +AVR_MCU ("avr32la28", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR32LA28__", 0x7800, 0x0, 0x8000, 0x8000) +AVR_MCU ("avr32la32", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR32LA32__", 0x7800, 0x0, 0x8000, 0x8000) AVR_MCU ("avr32sd20", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR32SD20__", 0x7000, 0x0, 0x8000, 0x8000) AVR_MCU ("avr32sd28", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR32SD28__", 0x7000, 0x0, 0x8000, 0x8000) AVR_MCU ("avr32sd32", ARCH_AVRXMEGA3, AVR_CVT, "__AVR_AVR32SD32__", 0x7000, 0x0, 0x8000, 0x8000) diff --git a/gcc/config/avr/avr.opt.urls b/gcc/config/avr/avr.opt.urls index fa560bc2a5a7..b46c9be9681f 100644 --- a/gcc/config/avr/avr.opt.urls +++ b/gcc/config/avr/avr.opt.urls @@ -28,7 +28,7 @@ muse-nonzero-bits UrlSuffix(gcc/AVR-Options.html#index-muse-nonzero-bits) mshort-calls -UrlSuffix(gcc/AVR-Options.html#index-mshort-calls) +UrlSuffix(gcc/AVR-Options.html#index-mshort-calls-1) mint8 UrlSuffix(gcc/AVR-Options.html#index-mint8) diff --git a/gcc/config/bpf/bpf.opt.urls b/gcc/config/bpf/bpf.opt.urls index 1e8873a899fd..afa5f6c69397 100644 --- a/gcc/config/bpf/bpf.opt.urls +++ b/gcc/config/bpf/bpf.opt.urls @@ -1,5 +1,8 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/config/bpf/bpf.opt and generated HTML +mxbpf +UrlSuffix(gcc/eBPF-Options.html#index-mxbpf) + mbig-endian UrlSuffix(gcc/eBPF-Options.html#index-mbig-endian-5) diff --git a/gcc/config/c6x/c6x.opt.urls b/gcc/config/c6x/c6x.opt.urls index 5b1c103b43f2..7813a8024d91 100644 --- a/gcc/config/c6x/c6x.opt.urls +++ b/gcc/config/c6x/c6x.opt.urls @@ -11,7 +11,11 @@ UrlSuffix(gcc/C6X-Options.html#index-msim-1) ; skipping UrlSuffix for 'msdata=' due to finding no URLs -; skipping UrlSuffix for 'mlong-calls' due to finding no URLs +mdsbt +UrlSuffix(gcc/C6X-Options.html#index-mdsbt) + +mlong-calls +UrlSuffix(gcc/C6X-Options.html#index-mlong-calls-4) march= UrlSuffix(gcc/C6X-Options.html#index-march-3) diff --git a/gcc/config/cris/cris.opt b/gcc/config/cris/cris.opt index 9fa9cbfe38c0..55b03ee1f79c 100644 --- a/gcc/config/cris/cris.opt +++ b/gcc/config/cris/cris.opt @@ -108,28 +108,32 @@ Do not tune code and read-only data alignment. ; See cris_handle_option. m32-bit -Target RejectNegative Undocumented +Target RejectNegative +Align code and data to 32 bits. ; See cris_handle_option. m32bit -Target RejectNegative +Target RejectNegative Undocumented Align code and data to 32 bits. ; See cris_handle_option. m16-bit -Target RejectNegative Undocumented +Target RejectNegative +Align code and data to 16 bits. ; See cris_handle_option. m16bit Target RejectNegative Undocumented +Align code and data to 16 bits. ; See cris_handle_option. m8-bit -Target RejectNegative Undocumented +Target RejectNegative +Don't align items in code or data. ; See cris_handle_option. m8bit -Target RejectNegative +Target RejectNegative Undocumented Don't align items in code or data. ; TARGET_PROLOGUE_EPILOGUE: Whether or not to omit function diff --git a/gcc/config/cris/cris.opt.urls b/gcc/config/cris/cris.opt.urls index 56eeaa25da1c..20b31b3a5e1c 100644 --- a/gcc/config/cris/cris.opt.urls +++ b/gcc/config/cris/cris.opt.urls @@ -9,6 +9,9 @@ UrlSuffix(gcc/CRIS-Options.html#index-metrax4) metrax100 UrlSuffix(gcc/CRIS-Options.html#index-metrax100) +mno-etrax100 +UrlSuffix(gcc/CRIS-Options.html#index-mno-etrax100) + mpdebug UrlSuffix(gcc/CRIS-Options.html#index-mpdebug) @@ -54,6 +57,12 @@ UrlSuffix(gcc/CRIS-Options.html#index-mprologue-epilogue) mno-prologue-epilogue UrlSuffix(gcc/CRIS-Options.html#index-mno-prologue-epilogue) +mbest-lib-options +UrlSuffix(gcc/CRIS-Options.html#index-mbest-lib-options) + +moverride-best-lib-options +UrlSuffix(gcc/CRIS-Options.html#index-moverride-best-lib-options) + mcpu= UrlSuffix(gcc/CRIS-Options.html#index-mcpu-3) @@ -63,3 +72,12 @@ UrlSuffix(gcc/CRIS-Options.html#index-march-4) mtune= UrlSuffix(gcc/CRIS-Options.html#index-mtune-5) +mtrap-using-break8 +UrlSuffix(gcc/CRIS-Options.html#index-mtrap-using-break8) + +mtrap-unaligned-atomic +UrlSuffix(gcc/CRIS-Options.html#index-mtrap-unaligned-atomic) + +munaligned-atomic-may-use-library +UrlSuffix(gcc/CRIS-Options.html#index-munaligned-atomic-may-use-library) + diff --git a/gcc/config/cris/elf.opt.urls b/gcc/config/cris/elf.opt.urls index bdfa01e97a49..f7969fbd4e09 100644 --- a/gcc/config/cris/elf.opt.urls +++ b/gcc/config/cris/elf.opt.urls @@ -1,7 +1,6 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/config/cris/elf.opt and generated HTML -melf -UrlSuffix(gcc/CRIS-Options.html#index-melf) +; skipping UrlSuffix for 'melf' due to finding no URLs sim UrlSuffix(gcc/CRIS-Options.html#index-sim) diff --git a/gcc/config/csky/csky.opt.urls b/gcc/config/csky/csky.opt.urls index 96b0b174f7c9..50f7b87f0374 100644 --- a/gcc/config/csky/csky.opt.urls +++ b/gcc/config/csky/csky.opt.urls @@ -9,20 +9,16 @@ UrlSuffix(gcc/C-SKY-Options.html#index-mcpu_003d-1) mbig-endian UrlSuffix(gcc/C-SKY-Options.html#index-mbig-endian-4) -EB -UrlSuffix(gcc/C-SKY-Options.html#index-EB-1) +; skipping UrlSuffix for 'EB' due to finding no URLs mlittle-endian UrlSuffix(gcc/C-SKY-Options.html#index-mlittle-endian-4) -EL -UrlSuffix(gcc/C-SKY-Options.html#index-EL-1) +; skipping UrlSuffix for 'EL' due to finding no URLs -mhard-float -UrlSuffix(gcc/C-SKY-Options.html#index-mhard-float) +; skipping UrlSuffix for 'mhard-float' due to finding no URLs -msoft-float -UrlSuffix(gcc/C-SKY-Options.html#index-msoft-float-1) +; skipping UrlSuffix for 'msoft-float' due to finding no URLs mfloat-abi= UrlSuffix(gcc/C-SKY-Options.html#index-mfloat-abi-1) @@ -88,7 +84,7 @@ mconstpool UrlSuffix(gcc/C-SKY-Options.html#index-mconstpool) mstack-size -UrlSuffix(gcc/C-SKY-Options.html#index-mstack-size-1) +UrlSuffix(gcc/C-SKY-Options.html#index-mstack-size) mccrt UrlSuffix(gcc/C-SKY-Options.html#index-mccrt) diff --git a/gcc/config/darwin.h b/gcc/config/darwin.h index e23414c00b6d..ef356ad1419f 100644 --- a/gcc/config/darwin.h +++ b/gcc/config/darwin.h @@ -523,6 +523,7 @@ extern GTY(()) int darwin_ms_struct; %{static|static-libgcc|static-libgcobol:%:replace-outfile(-lgcobol libgcobol.a%s)}\ %{static|static-libgcc|static-libstdc++|static-libgfortran:%:replace-outfile(-lgomp libgomp.a%s)}\ %{static|static-libgcc|static-libstdc++:%:replace-outfile(-lstdc++ libstdc++.a%s)}\ + %{static|static-libga68:%:replace-outfile(-lga68 libga68.a%s)}\ %{static|static-libgm2:%:replace-outfile(-lm2pim libm2pim.a%s)}\ %{static|static-libgm2:%:replace-outfile(-lm2iso libm2iso.a%s)}\ %{static|static-libgm2:%:replace-outfile(-lm2min libm2min.a%s)}\ @@ -1301,4 +1302,8 @@ extern void darwin_driver_init (unsigned int *,struct cl_decoded_option **); #undef BTF_INFO_SECTION_NAME #define BTF_INFO_SECTION_NAME "__CTF_BTF,__btf,regular,debug" +/* Algol68 */ +#undef A68_EXPORT_SECTION_NAME +#define A68_EXPORT_SECTION_NAME "__a68_exports" + #endif /* CONFIG_DARWIN_H */ diff --git a/gcc/config/darwin.opt b/gcc/config/darwin.opt index e275d846cd19..d6e6271f9cf2 100644 --- a/gcc/config/darwin.opt +++ b/gcc/config/darwin.opt @@ -169,8 +169,9 @@ filelist Driver RejectNegative Separate Supply a list of objects to be linked from a file, rather than the command line. +; specs turn this into fapple-kext. findirect-virtual-calls -Driver RejectNegative +Driver RejectNegative Undocumented Used for generating code for some older kernel revisions. flat_namespace @@ -189,8 +190,9 @@ framework Driver RejectNegative Separate -framework The linker should search for the framework in the framework search path. +; specs turn this into fapple-kext. fterminated-vtables -Driver RejectNegative +Driver RejectNegative Undocumented Used for generating code for some older kernel revisions. gfull @@ -222,19 +224,19 @@ Driver RejectNegative Usually \"private extern\" (hidden) symbols are made local when linking, this command suppresses that such that they remain exported. multi_module -Driver RejectNegative +Driver RejectNegative Undocumented (Obsolete after 10.4) Multi modules are ignored at runtime since macOS 10.4. multiply_defined -Driver RejectNegative Separate +Driver RejectNegative Separate Undocumented (Obsolete after 10.4) -multiply_defined Provided a mechanism for warning about symbols defined in multiple dylibs. multiply_defined_unused -Driver RejectNegative Separate +Driver RejectNegative Separate Undocumented (Obsolete after 10.4) -multiply_defined_unused Provided a mechanism for warning about symbols defined in the current executable also being defined in linked dylibs. no_dead_strip_inits_and_terms -Driver RejectNegative +Driver RejectNegative Undocumented (Obsolete) Current linkers never dead-strip these items, so the option is not needed. nodefaultexport @@ -246,40 +248,45 @@ Driver RejectNegative Do not add default run paths (for the compiler library directories) to executables, modules or dynamic libraries. nofixprebinding -Driver RejectNegative +Driver RejectNegative Undocumented (Obsolete after 10.3.9) Set MH_NOPREFIXBINDING, in an executable. nomultidefs -Driver RejectNegative +Driver RejectNegative Undocumented (Obsolete after 10.4) Set MH_NOMULTIDEFS in an umbrella framework. noprebind -Driver RejectNegative Negative(prebind) +Driver RejectNegative Negative(prebind) Undocumented (Obsolete) LD_PREBIND is no longer supported. noseglinkedit -Driver RejectNegative Negative(seglinkedit) +Driver RejectNegative Negative(seglinkedit) Undocumented (Obsolete) This is the default. ObjC Driver RejectNegative +Equivalent to -xobjective-c. ObjC++ Driver RejectNegative +Equivalent to -xobjective-c++. +; This option is only used in STARTFILE_SPEC and has never been +; documented since it was added in 2002, so it appears to be +; intentionally undocumented. object -Driver RejectNegative +Driver RejectNegative Undocumented pagezero_size Driver RejectNegative Separate -pagezero_size Allows setting the page 0 size to 4kb when required. prebind -Driver RejectNegative Negative(noprebind) +Driver RejectNegative Negative(noprebind) Undocumented (Obsolete) LD_PREBIND is no longer supported. prebind_all_twolevel_modules -Driver RejectNegative +Driver RejectNegative Undocumented (Obsolete) LD_PREBIND is no longer supported. preload @@ -287,7 +294,7 @@ Driver RejectNegative Produces a Mach-O file suitable for embedded/ROM use. private_bundle -Driver RejectNegative +Driver RejectNegative Undocumented (Obsolete) Allowed linking to proceed with \"-flat_namespace\" when a linked bundle contained a symbol also exported from the main executable. pthread @@ -310,11 +317,11 @@ Driver RejectNegative Separate Args(3) -sectcreate Create section in segment from the contents of . sectobjectsymbols -Driver RejectNegative Separate Args(2) +Driver RejectNegative Separate Args(2) Undocumented (Obsolete) -sectobjectsymbols Setting a local symbol at the start of a section is no longer supported. sectorder -Driver RejectNegative Separate Args(3) +Driver RejectNegative Separate Args(3) Undocumented (Obsolete) -sectorder Replaced by a more general option \"-order_file\". seg_addr_table @@ -323,7 +330,7 @@ Driver RejectNegative Separate ; This is only usable by the ld_classic linker. seg_addr_table_filename -Driver RejectNegative Separate +Driver RejectNegative Separate Undocumented (Obsolete, ld_classic only) -seg_addr_table_filename . seg1addr @@ -336,11 +343,11 @@ Driver RejectNegative Separate Args(2) ; This is only usable by the ld_classic linker. segcreate -Driver RejectNegative Separate Args(3) +Driver RejectNegative Separate Args(3) Undocumented (Obsolete, ld_classic only) -sectcreate Allowed creation of a section from a file. seglinkedit -Driver RejectNegative Negative(noseglinkedit) +Driver RejectNegative Negative(noseglinkedit) Undocumented (Obsolete) Object files with LINKEDIT sections are no longer supported. segprot @@ -356,7 +363,7 @@ Driver RejectNegative Separate -segs_read_write_addr
Specify that
is the base address address of the read-write segments of a dylib. single_module -Driver RejectNegative +Driver RejectNegative Undocumented (Obsolete) This is the default. sub_library @@ -405,12 +412,12 @@ Logs which symbol(s) caused an object to be loaded. ;(Obsolete, ignored) Strip symbols starting with "L", this is the default. X -Driver RejectNegative +Driver RejectNegative Undocumented y -Driver RejectNegative Joined +Driver RejectNegative Joined Undocumented (Obsolete, ignored) Old support similar to \"-whyload\". Mach -Driver RejectNegative +Driver RejectNegative Undocumented (Obsolete and unhandled by ld64, ignored) ld should produce an executable (only handled by ld_classic). diff --git a/gcc/config/darwin.opt.urls b/gcc/config/darwin.opt.urls index e83d183ac161..a3da8d2cbc4e 100644 --- a/gcc/config/darwin.opt.urls +++ b/gcc/config/darwin.opt.urls @@ -3,6 +3,9 @@ dependency-file UrlSuffix(gcc/Darwin-Options.html#index-dependency-file) +fapple-kext +UrlSuffix(gcc/Darwin-Options.html#index-fapple-kext) + fconstant-cfstrings UrlSuffix(gcc/Darwin-Options.html#index-fconstant-cfstrings) @@ -12,7 +15,14 @@ UrlSuffix(gcc/Darwin-Options.html#index-iframework) mconstant-cfstrings UrlSuffix(gcc/Darwin-Options.html#index-mconstant-cfstrings) -; skipping UrlSuffix for 'mdynamic-no-pic' due to finding no URLs +Wnonportable-cfstrings +UrlSuffix(gcc/Darwin-Options.html#index-Wno-nonportable-cfstrings) + +matt-stubs +UrlSuffix(gcc/Darwin-Options.html#index-matt-stubs) + +mdynamic-no-pic +UrlSuffix(gcc/Darwin-Options.html#index-mdynamic-no-pic) mfix-and-continue UrlSuffix(gcc/Darwin-Options.html#index-mfix-and-continue) @@ -26,15 +36,30 @@ UrlSuffix(gcc/Darwin-Options.html#index-mmacosx-version-min) mone-byte-bool UrlSuffix(gcc/Darwin-Options.html#index-mone-byte-bool) +msymbol-stubs +UrlSuffix(gcc/Darwin-Options.html#index-msymbol-stubs) + +mtarget-linker= +UrlSuffix(gcc/Darwin-Options.html#index-mtarget-linker) + +mtarget-linker +UrlSuffix(gcc/Darwin-Options.html#index-mtarget-linker) + all_load UrlSuffix(gcc/Darwin-Options.html#index-all_005fload) allowable_client UrlSuffix(gcc/Darwin-Options.html#index-allowable_005fclient) +arch +UrlSuffix(gcc/Darwin-Options.html#index-arch) + arch_errors_fatal UrlSuffix(gcc/Darwin-Options.html#index-arch_005ferrors_005ffatal) +asm_macosx_version_min= +UrlSuffix(gcc/Darwin-Options.html#index-asm_005fmacosx_005fversion_005fmin) + bind_at_load UrlSuffix(gcc/Darwin-Options.html#index-bind_005fat_005fload) @@ -59,6 +84,9 @@ UrlSuffix(gcc/Darwin-Options.html#index-dead_005fstrip) dylib_file UrlSuffix(gcc/Darwin-Options.html#index-dylib_005ffile) +dylinker +UrlSuffix(gcc/Darwin-Options.html#index-dylinker) + dylinker_install_name UrlSuffix(gcc/Darwin-Options.html#index-dylinker_005finstall_005fname) @@ -83,6 +111,9 @@ UrlSuffix(gcc/Darwin-Options.html#index-force_005fcpusubtype_005fALL) force_flat_namespace UrlSuffix(gcc/Darwin-Options.html#index-force_005fflat_005fnamespace) +framework +UrlSuffix(gcc/Darwin-Options.html#index-framework) + gfull UrlSuffix(gcc/Darwin-Options.html#index-gfull) @@ -104,45 +135,21 @@ UrlSuffix(gcc/Darwin-Options.html#index-install_005fname) keep_private_externs UrlSuffix(gcc/Darwin-Options.html#index-keep_005fprivate_005fexterns) -multi_module -UrlSuffix(gcc/Darwin-Options.html#index-multi_005fmodule) - -multiply_defined -UrlSuffix(gcc/Darwin-Options.html#index-multiply_005fdefined) - -multiply_defined_unused -UrlSuffix(gcc/Darwin-Options.html#index-multiply_005fdefined_005funused) - -no_dead_strip_inits_and_terms -UrlSuffix(gcc/Darwin-Options.html#index-no_005fdead_005fstrip_005finits_005fand_005fterms) +nodefaultexport +UrlSuffix(gcc/Darwin-Options.html#index-nodefaultexport) nodefaultrpaths UrlSuffix(gcc/Darwin-Options.html#index-nodefaultrpaths) -nofixprebinding -UrlSuffix(gcc/Darwin-Options.html#index-nofixprebinding) +ObjC +UrlSuffix(gcc/Darwin-Options.html#index-ObjC) -nomultidefs -UrlSuffix(gcc/Darwin-Options.html#index-nomultidefs) - -noprebind -UrlSuffix(gcc/Darwin-Options.html#index-noprebind) - -noseglinkedit -UrlSuffix(gcc/Darwin-Options.html#index-noseglinkedit) +ObjC++ +UrlSuffix(gcc/Darwin-Options.html#index-ObjC_002b_002b) pagezero_size UrlSuffix(gcc/Darwin-Options.html#index-pagezero_005fsize) -prebind -UrlSuffix(gcc/Darwin-Options.html#index-prebind) - -prebind_all_twolevel_modules -UrlSuffix(gcc/Darwin-Options.html#index-prebind_005fall_005ftwolevel_005fmodules) - -private_bundle -UrlSuffix(gcc/Darwin-Options.html#index-private_005fbundle) - ; skipping UrlSuffix for 'pthread' due to multiple URLs: ; duplicate: 'gcc/Link-Options.html#index-pthread-1' ; duplicate: 'gcc/Preprocessor-Options.html#index-pthread' @@ -159,27 +166,15 @@ UrlSuffix(gcc/Darwin-Options.html#index-sectalign) sectcreate UrlSuffix(gcc/Darwin-Options.html#index-sectcreate) -sectobjectsymbols -UrlSuffix(gcc/Darwin-Options.html#index-sectobjectsymbols) - -sectorder -UrlSuffix(gcc/Darwin-Options.html#index-sectorder) - seg_addr_table UrlSuffix(gcc/Darwin-Options.html#index-seg_005faddr_005ftable) -seg_addr_table_filename -UrlSuffix(gcc/Darwin-Options.html#index-seg_005faddr_005ftable_005ffilename) - seg1addr UrlSuffix(gcc/Darwin-Options.html#index-seg1addr) segaddr UrlSuffix(gcc/Darwin-Options.html#index-segaddr) -seglinkedit -UrlSuffix(gcc/Darwin-Options.html#index-seglinkedit) - segprot UrlSuffix(gcc/Darwin-Options.html#index-segprot) @@ -189,9 +184,6 @@ UrlSuffix(gcc/Darwin-Options.html#index-segs_005fread_005fonly_005faddr) segs_read_write_addr UrlSuffix(gcc/Darwin-Options.html#index-segs_005fread_005fwrite_005faddr) -single_module -UrlSuffix(gcc/Darwin-Options.html#index-single_005fmodule) - sub_library UrlSuffix(gcc/Darwin-Options.html#index-sub_005flibrary) @@ -201,6 +193,9 @@ UrlSuffix(gcc/Darwin-Options.html#index-sub_005fumbrella) twolevel_namespace UrlSuffix(gcc/Darwin-Options.html#index-twolevel_005fnamespace) +twolevel_namespace_hints +UrlSuffix(gcc/Darwin-Options.html#index-twolevel_005fnamespace_005fhints) + umbrella UrlSuffix(gcc/Darwin-Options.html#index-umbrella) @@ -210,6 +205,9 @@ UrlSuffix(gcc/Darwin-Options.html#index-undefined) unexported_symbols_list UrlSuffix(gcc/Darwin-Options.html#index-unexported_005fsymbols_005flist) +weak_framework +UrlSuffix(gcc/Darwin-Options.html#index-weak_005fframework) + weak_reference_mismatches UrlSuffix(gcc/Darwin-Options.html#index-weak_005freference_005fmismatches) diff --git a/gcc/config/epiphany/epiphany.opt b/gcc/config/epiphany/epiphany.opt index 9cd93db836a9..4b897540c350 100644 --- a/gcc/config/epiphany/epiphany.opt +++ b/gcc/config/epiphany/epiphany.opt @@ -72,7 +72,7 @@ target Mask(ROUND_NEAREST) Assume round to nearest is selected for purposes of scheduling. mlong-calls -Target Mask(LONG_CALLS) +Target InverseMask(SHORT_CALLS) Generate call insns as indirect calls. mshort-calls @@ -103,7 +103,12 @@ Enum(attr_fp_mode) String(truncate) Value(FP_MODE_ROUND_TRUNC) EnumValue Enum(attr_fp_mode) String(int) Value(FP_MODE_INT) +; This option has never been documented under this name, but it's +; been around since 2012. may-round-for-trunc +Target RejectNegative Undocumented Alias(mmay-round-for-trunc) + +mmay-round-for-trunc Target Mask(MAY_ROUND_FOR_TRUNC) A floating point to integer truncation may be replaced with rounding to save mode switching. @@ -129,7 +134,7 @@ Split unaligned 8 byte vector moves before post-modify address generation. mfp-iarith Target Mask(FP_IARITH) -Use the floating point unit for integer add/subtract. +Use the floating-point unit for integer add/subtract. m1reg- Target RejectNegative Joined Var(epiphany_m1reg) Enum(m1reg) Init(-1) diff --git a/gcc/config/epiphany/epiphany.opt.urls b/gcc/config/epiphany/epiphany.opt.urls index a8e28c46d210..0037dd7b6545 100644 --- a/gcc/config/epiphany/epiphany.opt.urls +++ b/gcc/config/epiphany/epiphany.opt.urls @@ -21,6 +21,12 @@ UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-msoft-cmpsf) msplit-lohi UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-msplit-lohi) +mpost-inc +UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-mpost-inc) + +mpost-modify +UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-mpost-modify) + mstack-offset= UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-mstack-offset) @@ -30,7 +36,8 @@ UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-mround-nearest) mlong-calls UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-mlong-calls) -; skipping UrlSuffix for 'mshort-calls' due to finding no URLs +mshort-calls +UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-mshort-calls) msmall16 UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-msmall16) @@ -38,6 +45,9 @@ UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-msmall16) mfp-mode= UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-mfp-mode) +mmay-round-for-trunc +UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-mmay-round-for-trunc) + mvect-double UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-mvect-double) @@ -47,6 +57,9 @@ UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-max-vect-align) msplit-vecmove-early UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-msplit-vecmove-early) +mfp-iarith +UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-mfp-iarith) + m1reg- UrlSuffix(gcc/Adapteva-Epiphany-Options.html#index-m1reg-) diff --git a/gcc/config/frv/frv.opt b/gcc/config/frv/frv.opt index 1890f91e3336..19f41862d296 100644 --- a/gcc/config/frv/frv.opt +++ b/gcc/config/frv/frv.opt @@ -45,7 +45,7 @@ Dynamically allocate cc registers. ; generating SCC instructions and or/and-ing them together, and then doing the ; branch on the result, which collectively generate much worse code. mbranch-cost= -Target RejectNegative Joined UInteger Var(frv_branch_cost_int) Init(1) +Target RejectNegative Joined UInteger Var(frv_branch_cost_int) Init(1) Undocumented Set the cost of branches. mcond-exec @@ -53,11 +53,11 @@ Target Mask(COND_EXEC) Enable conditional execution other than moves/scc. mcond-exec-insns= -Target RejectNegative Joined UInteger Var(frv_condexec_insns) Init(8) +Target RejectNegative Joined UInteger Var(frv_condexec_insns) Init(8) Undocumented Change the maximum length of conditionally-executed sequences. mcond-exec-temps= -Target RejectNegative Joined UInteger Var(frv_condexec_temps) Init(4) +Target RejectNegative Joined UInteger Var(frv_condexec_temps) Init(4) Undocumented Change the number of temporary registers that are available to conditionally-executed sequences. mcond-move diff --git a/gcc/config/frv/frv.opt.urls b/gcc/config/frv/frv.opt.urls index d3d3757bb289..f8e56cdd5fbf 100644 --- a/gcc/config/frv/frv.opt.urls +++ b/gcc/config/frv/frv.opt.urls @@ -53,7 +53,7 @@ mgprel-ro UrlSuffix(gcc/FRV-Options.html#index-mgprel-ro) mhard-float -UrlSuffix(gcc/FRV-Options.html#index-mhard-float-1) +UrlSuffix(gcc/FRV-Options.html#index-mhard-float) minline-plt UrlSuffix(gcc/FRV-Options.html#index-minline-plt-1) @@ -65,7 +65,7 @@ mlinked-fp UrlSuffix(gcc/FRV-Options.html#index-mlinked-fp) mlong-calls -UrlSuffix(gcc/FRV-Options.html#index-mlong-calls-4) +UrlSuffix(gcc/FRV-Options.html#index-mlong-calls-5) mmedia UrlSuffix(gcc/FRV-Options.html#index-mmedia) @@ -92,7 +92,7 @@ mscc UrlSuffix(gcc/FRV-Options.html#index-mscc) msoft-float -UrlSuffix(gcc/FRV-Options.html#index-msoft-float-3) +UrlSuffix(gcc/FRV-Options.html#index-msoft-float-2) mTLS UrlSuffix(gcc/FRV-Options.html#index-mTLS) diff --git a/gcc/config/ft32/ft32.opt b/gcc/config/ft32/ft32.opt index 039ca29db3a7..def410d2af11 100644 --- a/gcc/config/ft32/ft32.opt +++ b/gcc/config/ft32/ft32.opt @@ -23,7 +23,7 @@ Target Mask(SIM) Target the software simulator. mlra -Target RejectNegative Ignore +Target RejectNegative Ignore Undocumented Ignored, but preserved for backward compatibility. mnodiv diff --git a/gcc/config/ft32/ft32.opt.urls b/gcc/config/ft32/ft32.opt.urls index 707cb83010f0..27857da1fef4 100644 --- a/gcc/config/ft32/ft32.opt.urls +++ b/gcc/config/ft32/ft32.opt.urls @@ -3,8 +3,7 @@ msim UrlSuffix(gcc/FT32-Options.html#index-msim-3) -mlra -UrlSuffix(gcc/FT32-Options.html#index-mlra-1) +; skipping UrlSuffix for 'mlra' due to finding no URLs mnodiv UrlSuffix(gcc/FT32-Options.html#index-mnodiv) diff --git a/gcc/config/gcn/gcn.cc b/gcc/config/gcn/gcn.cc index 1e04074d78b7..a729ea4de36b 100644 --- a/gcc/config/gcn/gcn.cc +++ b/gcc/config/gcn/gcn.cc @@ -2940,6 +2940,16 @@ gcn_init_cumulative_args (CUMULATIVE_ARGS *cum /* Argument info to init */ , if (!caller && cfun->machine->normal_function) gcn_detect_incoming_pointer_arg (fndecl); + if ((omp_requires_mask & (OMP_REQUIRES_UNIFIED_SHARED_MEMORY + | OMP_REQUIRES_SELF_MAPS)) + && gcn_devices[gcn_arch].xnack_default != HSACO_ATTR_UNSUPPORTED + && flag_xnack == HSACO_ATTR_OFF) + { + warning_at (UNKNOWN_LOCATION, 0, + "Unified Shared Memory is enabled, but XNACK is disabled"); + inform (UNKNOWN_LOCATION, "Try -foffload-options=-mxnack=any"); + } + reinit_regs (); } diff --git a/gcc/config/gcn/gcn.opt b/gcc/config/gcn/gcn.opt index 99d6aeb2b30f..e877912fadc0 100644 --- a/gcc/config/gcn/gcn.opt +++ b/gcc/config/gcn/gcn.opt @@ -22,36 +22,46 @@ HeaderInclude config/gcn/gcn-opts.h march= -Target RejectNegative Negative(march=) Joined ToLower Enum(gpu_type) Var(gcn_arch) Init(PROCESSOR_GFX900) +Target RejectNegative Negative(march=) Joined ToLower Enum(gpu_type) Var(gcn_arch) Init(PROCESSOR_GFX90A) Specify the name of the target GPU. mtune= -Target RejectNegative Negative(mtune=) Joined ToLower Enum(gpu_type) Var(gcn_tune) Init(PROCESSOR_GFX900) +Target RejectNegative Negative(mtune=) Joined ToLower Enum(gpu_type) Var(gcn_tune) Init(PROCESSOR_GFX90A) Specify the name of the target GPU. +; mkoffload passes -m32, -m64, and -mgomp to the offload compiler, but +; nothing in the offload compiler actually uses any of these flags. +; Maybe they're there for compatibility with other offload backends, +; or maybe we can just delete these. In any case, there's no point in +; documenting them for users. m32 -Target RejectNegative InverseMask(ABI64) +Target RejectNegative InverseMask(ABI64) Undocumented Generate code for a 32-bit ABI. m64 -Target RejectNegative Mask(ABI64) +Target RejectNegative Mask(ABI64) Undocumented Generate code for a 64-bit ABI. mgomp -Target RejectNegative +Target RejectNegative Undocumented Enable OpenMP GPU offloading. +; This option seems not to ever have done anything useful, or to have +; been documented. +Variable bool flag_bypass_init_error = false mbypass-init-error -Target RejectNegative Var(flag_bypass_init_error) +Target RejectNegative Var(flag_bypass_init_error) Undocumented +Variable int stack_size_opt = -1 mstack-size= -Target RejectNegative Joined UInteger Var(stack_size_opt) Init(-1) +Target RejectNegative Joined UInteger Var(stack_size_opt) Init(-1) Undocumented Obsolete; use GCN_STACK_SIZE at runtime. +Variable int gang_private_size_opt = -1 mgang-private-size= diff --git a/gcc/config/gcn/gcn.opt.urls b/gcc/config/gcn/gcn.opt.urls index bfa6deab7b74..2f9ce48d1b12 100644 --- a/gcc/config/gcn/gcn.opt.urls +++ b/gcc/config/gcn/gcn.opt.urls @@ -12,8 +12,10 @@ UrlSuffix(gcc/AMD-GCN-Options.html#index-mtune-1) ; skipping UrlSuffix for 'mgomp' due to finding no URLs -mstack-size= -UrlSuffix(gcc/AMD-GCN-Options.html#index-mstack-size) +; skipping UrlSuffix for 'mstack-size=' due to finding no URLs + +mgang-private-size= +UrlSuffix(gcc/AMD-GCN-Options.html#index-mgang-private-size) Wopenacc-dims UrlSuffix(gcc/AMD-GCN-Options.html#index-Wno-openacc-dims) diff --git a/gcc/config/gcn/mkoffload.cc b/gcc/config/gcn/mkoffload.cc index 222adb2cd41d..d9d89c64f950 100644 --- a/gcc/config/gcn/mkoffload.cc +++ b/gcc/config/gcn/mkoffload.cc @@ -38,6 +38,9 @@ #include "configargs.h" /* For configure_default_options. */ #include "multilib.h" /* For multilib_options. */ +#include "tree.h" /* Dependency of omp-general.h. */ +#include "omp-general.h" /* For enum omp_requires. */ + /* These probably won't (all) be in elf.h for a while. */ #undef EM_AMDGPU #define EM_AMDGPU 0xe0; @@ -441,10 +444,12 @@ copy_early_debug_info (const char *infile, const char *outfile) encoded as structured data. */ static void -process_asm (FILE *in, FILE *out, FILE *cfile) +process_asm (FILE *in, FILE *out, FILE *cfile, uint32_t omp_requires) { int fn_count = 0, var_count = 0, ind_fn_count = 0; int dims_count = 0, regcount_count = 0; + bool xnack_required = (omp_requires & (OMP_REQUIRES_UNIFIED_SHARED_MEMORY + | OMP_REQUIRES_SELF_MAPS)); struct obstack fns_os, dims_os, regcounts_os; obstack_init (&fns_os); obstack_init (&dims_os); @@ -469,6 +474,7 @@ process_asm (FILE *in, FILE *out, FILE *cfile) fn_count += 2; char buf[1000]; + char dummy; enum { IN_CODE, IN_METADATA, @@ -549,7 +555,6 @@ process_asm (FILE *in, FILE *out, FILE *cfile) } } - char dummy; if (sscanf (buf, " .section .gnu.offload_vars%c", &dummy) > 0) { state = IN_VARS; @@ -615,11 +620,24 @@ process_asm (FILE *in, FILE *out, FILE *cfile) struct oaccdims *dims = XOBFINISH (&dims_os, struct oaccdims *); struct regcount *regcounts = XOBFINISH (®counts_os, struct regcount *); + /* If the -mxnack setting has a definite value (not "any" or undefined), or + the program "requires unified_shared_memory" (in which case -mxnack might + be "any"), then we emit code to check the mode at runtime. */ + bool check_xnack = (TEST_XNACK_OFF (elf_flags) + || TEST_XNACK_ON (elf_flags) + || xnack_required); + if (TEST_XNACK_OFF (elf_flags) && xnack_required) + fatal_error (input_location, + "conflicting settings; XNACK is forced off but Unified " + "Shared Memory is on"); + + /* Start generating the C code. */ if (gcn_stack_size) - { - fprintf (cfile, "#include \n"); - fprintf (cfile, "#include \n\n"); - } + fprintf (cfile, "#include \n"); + if (check_xnack) + fprintf (cfile, "#include \n"); + if (gcn_stack_size || check_xnack) + fprintf (cfile, "#include \n\n"); fprintf (cfile, "static const int gcn_num_vars = %d;\n\n", var_count); fprintf (cfile, "static const int gcn_num_ind_funcs = %d;\n\n", ind_fn_count); @@ -677,6 +695,25 @@ process_asm (FILE *in, FILE *out, FILE *cfile) " setenv (\"GCN_STACK_SIZE\", \"%d\", true);\n", gcn_stack_size); + /* Emit a constructor function to set the HSA_XNACK environment variable. + This must be done before the ROCr runtime library is loaded. + We never override a user value (except empty string), but we do emit a + useful diagnostic in the wrong mode (the ROCr message is not good. */ + if (check_xnack) + fprintf (cfile, + "\n" + " const char *xn_var = getenv (\"HSA_XNACK\");\n" + " if (!xn_var || xn_var[0] == '\\0')\n" + " setenv (\"HSA_XNACK\", \"%d\", true);\n" + " else if (%s)\n" + " fprintf (stderr, \"warning: HSA_XNACK=%%s is incompatible; " + "the GPU kernel may revert to host fallback\\n\", " + "xn_var);\n", + xnack_required || TEST_XNACK_ON (elf_flags), + (xnack_required || TEST_XNACK_ON (elf_flags) + ? "xn_var[0] != '1' || xn_var[1] != '\\0'" + : "xn_var[0] != '0' || xn_var[1] != '\\0'")); + /* End of mkoffload_setup function. */ fprintf (cfile, "}\n\n"); @@ -1116,7 +1153,8 @@ main (int argc, char **argv) #define GCN_DEVICE(name, NAME, ELF, ISA, XNACK, SRAM, ...) \ case ELF: XNACK; break; #define HSACO_ATTR_UNSUPPORTED SET_XNACK_UNSET (elf_flags) -#define HSACO_ATTR_OFF SET_XNACK_OFF (elf_flags) +#define HSACO_ATTR_OFF \ + if (TEST_XNACK_UNSET (elf_flags)) SET_XNACK_OFF (elf_flags) #define HSACO_ATTR_ANY \ if (TEST_XNACK_UNSET (elf_flags)) SET_XNACK_ANY (elf_flags) #include "gcn-devices.def" @@ -1348,7 +1386,7 @@ main (int argc, char **argv) if (!out) fatal_error (input_location, "cannot open %qs", gcn_s2_name); - process_asm (in, out, cfile); + process_asm (in, out, cfile, omp_requires); fclose (in); fclose (out); diff --git a/gcc/config/i386/i386-features.cc b/gcc/config/i386/i386-features.cc index f1f118d5b755..ce6f40b922c6 100644 --- a/gcc/config/i386/i386-features.cc +++ b/gcc/config/i386/i386-features.cc @@ -3947,11 +3947,19 @@ ix86_emit_tls_call (rtx tls_set, x86_cse_kind kind, basic_block bb, (note 2 3 5 2 NOTE_INSN_FUNCTION_BEG) (debug_insn 5 2 16 2 (debug_marker) "x.c":6:3 -1 (nil)) + or a basic block with only deleted instructions: + + (code_label 348 23 349 45 3 (nil) [0 uses]) + (note 349 348 436 45 [bb 45] NOTE_INSN_BASIC_BLOCK) + (note 436 349 362 45 NOTE_INSN_DELETED) + */ gcc_assert (DEBUG_INSN_P (insn) || (NOTE_P (insn) && ((NOTE_KIND (insn) == NOTE_INSN_FUNCTION_BEG) + || (NOTE_KIND (insn) + == NOTE_INSN_DELETED) || (NOTE_KIND (insn) == NOTE_INSN_BASIC_BLOCK)))); insn = NULL; diff --git a/gcc/config/i386/i386-options.cc b/gcc/config/i386/i386-options.cc index ba598a817f30..35064d83a007 100644 --- a/gcc/config/i386/i386-options.cc +++ b/gcc/config/i386/i386-options.cc @@ -1837,6 +1837,21 @@ set_ix86_tune_features (struct gcc_options *opts, } parse_mtune_ctrl_str (opts, dump); + + /* mgather/mscatter option would overwrite -mtune-crtl option. */ + if (OPTION_SET_P (ix86_use_gather)) + { + ix86_tune_features[X86_TUNE_USE_GATHER_2PARTS] = ix86_use_gather; + ix86_tune_features[X86_TUNE_USE_GATHER_4PARTS] = ix86_use_gather; + ix86_tune_features[X86_TUNE_USE_GATHER_8PARTS] = ix86_use_gather; + } + + if (OPTION_SET_P (ix86_use_scatter)) + { + ix86_tune_features[X86_TUNE_USE_SCATTER_2PARTS] = ix86_use_scatter; + ix86_tune_features[X86_TUNE_USE_SCATTER_4PARTS] = ix86_use_scatter; + ix86_tune_features[X86_TUNE_USE_SCATTER_8PARTS] = ix86_use_scatter; + } } diff --git a/gcc/config/i386/i386.opt b/gcc/config/i386/i386.opt index 844945023451..c0093ef12436 100644 --- a/gcc/config/i386/i386.opt +++ b/gcc/config/i386/i386.opt @@ -1290,11 +1290,11 @@ Support MMX, SSE, SSE2, SSE3, SSSE3, SSE4.1, SSE4.2, AVX and SM4 built-in functions and code generation. mgather -Target Alias(mtune-ctrl=, use_gather, ^use_gather) +Target Var(ix86_use_gather) Init(0) Optimization. Enable vectorization for gather instruction. mscatter -Target Alias(mtune-ctrl=, use_scatter, ^use_scatter) +Target Var(ix86_use_scatter) Init(0) Optimization Enable vectorization for scatter instruction. mapxf diff --git a/gcc/config/i386/i386.opt.urls b/gcc/config/i386/i386.opt.urls index a89329b48449..129d91f0c287 100644 --- a/gcc/config/i386/i386.opt.urls +++ b/gcc/config/i386/i386.opt.urls @@ -13,10 +13,10 @@ mlong-double-80 UrlSuffix(gcc/x86-Options.html#index-mlong-double-80) mlong-double-64 -UrlSuffix(gcc/x86-Options.html#index-mlong-double-64-1) +UrlSuffix(gcc/x86-Options.html#index-mlong-double-64-2) mlong-double-128 -UrlSuffix(gcc/x86-Options.html#index-mlong-double-128-1) +UrlSuffix(gcc/x86-Options.html#index-mlong-double-128-2) maccumulate-outgoing-args UrlSuffix(gcc/x86-Options.html#index-maccumulate-outgoing-args-1) @@ -57,7 +57,7 @@ UrlSuffix(gcc/x86-Options.html#index-mfp-ret-in-387) ; duplicate: 'gcc/x86-Options.html#index-mfpmath-1' mhard-float -UrlSuffix(gcc/x86-Options.html#index-mhard-float-11) +UrlSuffix(gcc/x86-Options.html#index-mhard-float-10) mieee-fp UrlSuffix(gcc/x86-Options.html#index-mieee-fp) @@ -120,7 +120,7 @@ mrtd UrlSuffix(gcc/x86-Options.html#index-mrtd-1) msoft-float -UrlSuffix(gcc/x86-Options.html#index-msoft-float-16) +UrlSuffix(gcc/x86-Options.html#index-msoft-float-15) msseregparm UrlSuffix(gcc/x86-Options.html#index-msseregparm) diff --git a/gcc/config/ia64/ia64.opt.urls b/gcc/config/ia64/ia64.opt.urls index 1e1d0631550a..cc228d751ea5 100644 --- a/gcc/config/ia64/ia64.opt.urls +++ b/gcc/config/ia64/ia64.opt.urls @@ -70,7 +70,7 @@ mfixed-range= UrlSuffix(gcc/IA-64-Options.html#index-mfixed-range-1) mtls-size= -UrlSuffix(gcc/IA-64-Options.html#index-mtls-size-1) +UrlSuffix(gcc/IA-64-Options.html#index-mtls-size-2) mtune= UrlSuffix(gcc/IA-64-Options.html#index-mtune-7) diff --git a/gcc/config/loongarch/loongarch.cc b/gcc/config/loongarch/loongarch.cc index c1a53e3e7ca0..053f77cb994a 100644 --- a/gcc/config/loongarch/loongarch.cc +++ b/gcc/config/loongarch/loongarch.cc @@ -3003,7 +3003,7 @@ loongarch_unspec_address_offset (rtx base, rtx offset, enum loongarch_symbol_type symbol_type) { base = gen_rtx_UNSPEC (Pmode, gen_rtvec (1, base), - UNSPEC_ADDRESS_FIRST + symbol_type); + UNSPEC_ADDRESS_FIRST + (int) symbol_type); if (offset != const0_rtx) base = gen_rtx_PLUS (Pmode, base, offset); return gen_rtx_CONST (Pmode, base); @@ -3223,7 +3223,7 @@ loongarch_call_tls_get_addr (rtx sym, enum loongarch_symbol_type type, rtx v0) rtx sum = gen_rtx_UNSPEC ( Pmode, gen_rtvec (1, loongarch_tls_symbol), UNSPEC_ADDRESS_FIRST - + loongarch_classify_symbol (loongarch_tls_symbol)); + + (int) loongarch_classify_symbol (loongarch_tls_symbol)); set_unique_reg_note (get_last_insn (), REG_EQUAL, sum); } else diff --git a/gcc/config/loongarch/loongarch.opt.urls b/gcc/config/loongarch/loongarch.opt.urls index c93f04683e1c..a72075d458fe 100644 --- a/gcc/config/loongarch/loongarch.opt.urls +++ b/gcc/config/loongarch/loongarch.opt.urls @@ -4,7 +4,7 @@ mfpu= UrlSuffix(gcc/LoongArch-Options.html#index-mfpu-2) msoft-float -UrlSuffix(gcc/LoongArch-Options.html#index-msoft-float-5) +UrlSuffix(gcc/LoongArch-Options.html#index-msoft-float-4) msingle-float UrlSuffix(gcc/LoongArch-Options.html#index-msingle-float) diff --git a/gcc/config/m68k/m68k.opt.urls b/gcc/config/m68k/m68k.opt.urls index 1f1ac88bcb2e..bb5e1a0c0298 100644 --- a/gcc/config/m68k/m68k.opt.urls +++ b/gcc/config/m68k/m68k.opt.urls @@ -70,7 +70,7 @@ mdiv UrlSuffix(gcc/M680x0-Options.html#index-mdiv-1) mhard-float -UrlSuffix(gcc/M680x0-Options.html#index-mhard-float-2) +UrlSuffix(gcc/M680x0-Options.html#index-mhard-float-1) ; skipping UrlSuffix for 'mid-shared-library' due to finding no URLs @@ -96,7 +96,7 @@ mshort UrlSuffix(gcc/M680x0-Options.html#index-mshort) msoft-float -UrlSuffix(gcc/M680x0-Options.html#index-msoft-float-6) +UrlSuffix(gcc/M680x0-Options.html#index-msoft-float-5) mstrict-align UrlSuffix(gcc/M680x0-Options.html#index-mstrict-align-2) diff --git a/gcc/config/microblaze/microblaze.opt.urls b/gcc/config/microblaze/microblaze.opt.urls index 33b13b84e2c2..be4230504ada 100644 --- a/gcc/config/microblaze/microblaze.opt.urls +++ b/gcc/config/microblaze/microblaze.opt.urls @@ -1,10 +1,10 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/config/microblaze/microblaze.opt and generated HTML msoft-float -UrlSuffix(gcc/MicroBlaze-Options.html#index-msoft-float-7) +UrlSuffix(gcc/MicroBlaze-Options.html#index-msoft-float-6) mhard-float -UrlSuffix(gcc/MicroBlaze-Options.html#index-mhard-float-3) +UrlSuffix(gcc/MicroBlaze-Options.html#index-mhard-float-2) msmall-divides UrlSuffix(gcc/MicroBlaze-Options.html#index-msmall-divides) diff --git a/gcc/config/mips/mips.cc b/gcc/config/mips/mips.cc index 42dfc3b35119..abdf0da7a84c 100644 --- a/gcc/config/mips/mips.cc +++ b/gcc/config/mips/mips.cc @@ -3315,7 +3315,7 @@ mips_unspec_address_offset (rtx base, rtx offset, enum mips_symbol_type symbol_type) { base = gen_rtx_UNSPEC (Pmode, gen_rtvec (1, base), - UNSPEC_ADDRESS_FIRST + symbol_type); + UNSPEC_ADDRESS_FIRST + (int) symbol_type); if (offset != const0_rtx) base = gen_rtx_PLUS (Pmode, base, offset); return gen_rtx_CONST (Pmode, base); diff --git a/gcc/config/mips/mips.opt.urls b/gcc/config/mips/mips.opt.urls index 5921d6929b28..a85ea0313a16 100644 --- a/gcc/config/mips/mips.opt.urls +++ b/gcc/config/mips/mips.opt.urls @@ -1,10 +1,10 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/config/mips/mips.opt and generated HTML EB -UrlSuffix(gcc/MIPS-Options.html#index-EB-2) +UrlSuffix(gcc/MIPS-Options.html#index-EB-1) EL -UrlSuffix(gcc/MIPS-Options.html#index-EL-2) +UrlSuffix(gcc/MIPS-Options.html#index-EL-1) mabi= UrlSuffix(gcc/MIPS-Options.html#index-mabi-3) @@ -133,7 +133,7 @@ mplt UrlSuffix(gcc/MIPS-Options.html#index-mplt) mhard-float -UrlSuffix(gcc/MIPS-Options.html#index-mhard-float-4) +UrlSuffix(gcc/MIPS-Options.html#index-mhard-float-3) minterlink-compressed UrlSuffix(gcc/MIPS-Options.html#index-minterlink-compressed) @@ -154,7 +154,7 @@ mlocal-sdata UrlSuffix(gcc/MIPS-Options.html#index-mlocal-sdata) mlong-calls -UrlSuffix(gcc/MIPS-Options.html#index-mlong-calls-6) +UrlSuffix(gcc/MIPS-Options.html#index-mlong-calls-7) mlong32 UrlSuffix(gcc/MIPS-Options.html#index-mlong32) @@ -208,7 +208,7 @@ msmartmips UrlSuffix(gcc/MIPS-Options.html#index-msmartmips) msoft-float -UrlSuffix(gcc/MIPS-Options.html#index-msoft-float-8) +UrlSuffix(gcc/MIPS-Options.html#index-msoft-float-7) msplit-addresses UrlSuffix(gcc/MIPS-Options.html#index-msplit-addresses) diff --git a/gcc/config/mmix/mmix.opt.urls b/gcc/config/mmix/mmix.opt.urls index 6722f9e4e01d..dda41cadf8d3 100644 --- a/gcc/config/mmix/mmix.opt.urls +++ b/gcc/config/mmix/mmix.opt.urls @@ -22,7 +22,7 @@ mtoplevel-symbols UrlSuffix(gcc/MMIX-Options.html#index-mtoplevel-symbols) melf -UrlSuffix(gcc/MMIX-Options.html#index-melf-1) +UrlSuffix(gcc/MMIX-Options.html#index-melf) mbranch-predict UrlSuffix(gcc/MMIX-Options.html#index-mbranch-predict) diff --git a/gcc/config/or1k/or1k.opt.urls b/gcc/config/or1k/or1k.opt.urls index b3ba2df4ab7f..0927d6af1dbb 100644 --- a/gcc/config/or1k/or1k.opt.urls +++ b/gcc/config/or1k/or1k.opt.urls @@ -13,10 +13,10 @@ msoft-mul UrlSuffix(gcc/OpenRISC-Options.html#index-msoft-mul) msoft-float -UrlSuffix(gcc/OpenRISC-Options.html#index-msoft-float-9) +UrlSuffix(gcc/OpenRISC-Options.html#index-msoft-float-8) mhard-float -UrlSuffix(gcc/OpenRISC-Options.html#index-mhard-float-5) +UrlSuffix(gcc/OpenRISC-Options.html#index-mhard-float-4) mdouble-float UrlSuffix(gcc/OpenRISC-Options.html#index-mdouble-float-3) diff --git a/gcc/config/pa/pa.opt.urls b/gcc/config/pa/pa.opt.urls index 5516332ead13..29489f9b3bf0 100644 --- a/gcc/config/pa/pa.opt.urls +++ b/gcc/config/pa/pa.opt.urls @@ -34,7 +34,7 @@ mlinker-opt UrlSuffix(gcc/HPPA-Options.html#index-mlinker-opt) mlong-calls -UrlSuffix(gcc/HPPA-Options.html#index-mlong-calls-5) +UrlSuffix(gcc/HPPA-Options.html#index-mlong-calls-6) ; skipping UrlSuffix for 'mlra' due to finding no URLs @@ -63,7 +63,7 @@ mschedule= UrlSuffix(gcc/HPPA-Options.html#index-mschedule) msoft-float -UrlSuffix(gcc/HPPA-Options.html#index-msoft-float-4) +UrlSuffix(gcc/HPPA-Options.html#index-msoft-float-3) msoft-mult UrlSuffix(gcc/HPPA-Options.html#index-msoft-mult) diff --git a/gcc/config/pdp11/pdp11.opt.urls b/gcc/config/pdp11/pdp11.opt.urls index f0544ca84f69..2e8c7b1972f7 100644 --- a/gcc/config/pdp11/pdp11.opt.urls +++ b/gcc/config/pdp11/pdp11.opt.urls @@ -28,7 +28,7 @@ mint32 UrlSuffix(gcc/PDP-11-Options.html#index-mint32-1) msoft-float -UrlSuffix(gcc/PDP-11-Options.html#index-msoft-float-10) +UrlSuffix(gcc/PDP-11-Options.html#index-msoft-float-9) msplit UrlSuffix(gcc/PDP-11-Options.html#index-msplit) @@ -37,5 +37,5 @@ munix-asm UrlSuffix(gcc/PDP-11-Options.html#index-munix-asm) mlra -UrlSuffix(gcc/PDP-11-Options.html#index-mlra-2) +UrlSuffix(gcc/PDP-11-Options.html#index-mlra-1) diff --git a/gcc/config/riscv/andes-23-series.md b/gcc/config/riscv/andes-23-series.md new file mode 100644 index 000000000000..8e19e05da17d --- /dev/null +++ b/gcc/config/riscv/andes-23-series.md @@ -0,0 +1,190 @@ +;; DFA-based pipeline description for Andes 23 series. +;; +;; Copyright (C) 2025 Free Software Foundation, Inc. +;; +;; This file is part of GCC. +;; +;; GCC is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published +;; by the Free Software Foundation; either version 3, or (at your +;; option) any later version. + +;; GCC is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GCC; see the file COPYING3. If not see +;; . + +(define_automaton "andes_23_arch") + +(define_cpu_unit + "andes_23_alu0, andes_23_alu1, andes_23_lsu0, + andes_23_lsu1, andes_23_lsu2" + "andes_23_arch") + +(define_cpu_unit "andes_23_mdu" "andes_23_arch") +(define_cpu_unit "andes_23_fpu" "andes_23_arch") + +;; andes 23 unsupported insns are mapped to dummies reservations +(define_reservation "andes_23_dummies" + "andes_23_alu0 | andes_23_alu1 | andes_23_lsu0 | andes_23_lsu1 | + andes_23_lsu2 | andes_23_mdu | andes_23_fpu") + +(define_reservation "andes_23_alu" + "andes_23_alu0 | andes_23_alu1") + +(define_reservation "andes_23_lsu" + "andes_23_lsu0 | andes_23_lsu1 | andes_23_lsu2") + +(define_reservation "andes_23_pipe_unify" + "andes_23_alu0 + andes_23_alu1") + +(define_insn_reservation "andes_23_alu_insn" 1 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "unknown,const,arith,slt,multi,nop,move, + shift,logical,mvpair,auipc")) + "andes_23_alu") + +(define_insn_reservation "andes_23_load" 3 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "load")) + "andes_23_pipe_unify, andes_23_lsu*3") + +(define_insn_reservation "andes_23_store" 0 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "store")) + "andes_23_pipe_unify,andes_23_lsu*3") + +(define_insn_reservation "andes_23_branch" 0 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "branch,jump,call,jalr,ret,trap")) + "andes_23_pipe_unify") + +(define_insn_reservation "andes_23_imul" 2 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "imul")) + "andes_23_alu0, andes_23_mdu") + +(define_insn_reservation "andes_23_idivsi" 35 + (and (eq_attr "tune" "andes_23_series") + (and (eq_attr "type" "idiv") + (eq_attr "mode" "SI"))) + "andes_23_pipe_unify, andes_23_mdu* 34") + +(define_insn_reservation "andes_23_idivdi" 35 + (and (eq_attr "tune" "andes_23_series") + (and (eq_attr "type" "idiv") + (eq_attr "mode" "DI"))) + "andes_23_pipe_unify, andes_23_mdu* 34") + +(define_insn_reservation "andes_23_xfer" 1 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "mfc,mtc")) + "andes_23_alu") + +(define_insn_reservation "andes_23_fpu_alu" 4 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "fadd")) + "andes_23_pipe_unify, andes_23_fpu") + +(define_insn_reservation "andes_23_fpu_mul" 4 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "fmul")) + "andes_23_pipe_unify, andes_23_fpu") + +(define_insn_reservation "andes_23_fpu_mac" 4 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "fmadd")) + "andes_23_pipe_unify, andes_23_fpu") + +(define_insn_reservation "andes_23_fpu_div" 33 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "fdiv")) + "andes_23_pipe_unify, andes_23_fpu*33") + +(define_insn_reservation "andes_23_fpu_sqrt" 33 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "fsqrt")) + "andes_23_pipe_unify, andes_23_fpu*33") + +(define_insn_reservation "andes_23_fpu_move" 2 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "fmove,mtc,mfc")) + "andes_23_pipe_unify, andes_23_fpu") + +(define_insn_reservation "andes_23_fpu_cmp" 3 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "fcmp")) + "andes_23_pipe_unify, andes_23_fpu") + +(define_insn_reservation "andes_23_fpu_cvt" 3 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "fcvt,fcvt_i2f,fcvt_f2i")) + "andes_23_pipe_unify, andes_23_fpu") + +(define_insn_reservation "andes_23_fpu_load" 3 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "fpload")) + "andes_23_pipe_unify, andes_23_lsu*3") + +(define_insn_reservation "andes_23_fpu_store" 0 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "fpstore")) + "andes_23_pipe_unify, andes_23_lsu*3") + +(define_insn_reservation "andes_23_bitmanip" 1 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "bitmanip,minu,maxu,min,max,clmul,rotate,cpop,clz,ctz")) + "andes_23_alu0") + +(define_insn_reservation "andes_23_crypto" 1 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "crypto")) + "andes_23_alu0") + +(define_bypass 3 + "andes_23_fpu_mul" + "andes_23_fpu_alu,andes_23_fpu_mac, + andes_23_fpu_div,andes_23_fpu_sqrt") + +(define_bypass 3 + "andes_23_fpu_alu" + "andes_23_fpu_mul,andes_23_fpu_alu,andes_23_fpu_mac, + andes_23_fpu_div,andes_23_fpu_sqrt") + +(define_bypass 3 + "andes_23_fpu_mac" + "andes_23_fpu_mul,andes_23_fpu_alu,andes_23_fpu_mac, + andes_23_fpu_div,andes_23_fpu_sqrt") + +(define_bypass 2 + "andes_23_fpu_load" + "andes_23_fpu_div,andes_23_fpu_sqrt") + +(define_insn_reservation "andes_23_unknown" 1 + (and (eq_attr "tune" "andes_23_series") + (eq_attr "type" "ghost,zicond,mvpair,sfb_alu,condmove,atomic, + vclz,vror,vsha2ch,vsm4k,vaesef,vghsh,vsm4r,vsm3c, + vaeskf1,vandn,vaesdm,vclmul,vclmulh,vrol,vcpop,vbrev8, + vsm3me,vbrev,vctz,vgmul,vsha2ms,vaesz,vrev8, + vaeskf2,vsha2cl,vwsll,vaesdf,vaesem,vfwmaccbf16, + sf_vqmacc,sf_vc,sf_vc_se,sf_vfnrclip,vmsfs,vfwalu, + vnshift,vldm,vslidedown,vicmp,vfcvtftoi,vmffs,vlsegdux, + vfredo,vstux,vsshift,vfwcvtbf16,vmpop,vicalu,vldff, + vislide1down,vstox,vfwcvtftof,vfmov,vislide1up,vldr, + vfmul,vfrecp,vfncvtitof,vfwcvtftoi,vsts,viminmax,vext, + vaalu,vfdiv,vidiv,viwalu,vssegte,wrvxrm,vfmovvf,vlde, + vfclass,vshift,vimovxv,vssegtox,vfsqrt,vector,vmalu, + vfcvtitof,vlsegdff,vfslide1down,vimov,vialu,vmidx, + vsalu,vfmerge,rdvl,vlds,vfmuladd,vfsgnj,vslideup, + vfcmp,vfmovfv,vfwcvtitof,vfwmuladd,vfwredo,vlsegdox, + viwmul,vldox,vsmul,vstm,vfminmax,vmov,vfalu,vfncvtbf16, + vnclip,vimerge,vfwmul,vimovvx,vfncvtftoi,viwred,rdvlenb, + vfslide1up,vfncvtftof,vsetvl,viwmuladd,vfredu,vfwredu, + vlsegde,vmiota,vstr,vgather,vssegts,vldux,vlsegds,vimul, + vste,vsetvl_pre,vimuladd,vcompress,vssegtux,wrfrm,rdfrm, + vired")) + "andes_23_dummies") diff --git a/gcc/config/riscv/andes-45-series.md b/gcc/config/riscv/andes-45-series.md new file mode 100644 index 000000000000..7693db84746b --- /dev/null +++ b/gcc/config/riscv/andes-45-series.md @@ -0,0 +1,379 @@ +;; DFA-based pipeline description for Andes 45 series. +;; +;; Copyright (C) 2025 Free Software Foundation, Inc. +;; +;; This file is part of GCC. +;; +;; GCC is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published +;; by the Free Software Foundation; either version 3, or (at your +;; option) any later version. + +;; GCC is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GCC; see the file COPYING3. If not see +;; . + +(define_automaton "andes_45_arch, andes_45_vector") + +(define_cpu_unit "andes_45_pipe0" "andes_45_arch") +(define_cpu_unit "andes_45_pipe1" "andes_45_arch") +(define_cpu_unit "andes_45_vpu_pipe0" "andes_45_vector") +(define_cpu_unit "andes_45_vpu_pipe1" "andes_45_vector") + +(define_reservation "andes_45_vpu_pipe" "(andes_45_vpu_pipe0 + andes_45_pipe0 | andes_45_vpu_pipe1 + andes_45_pipe1)") + +(define_cpu_unit "andes_45_mdu,andes_45_alu0,andes_45_alu1,andes_45_bru0,andes_45_bru1,andes_45_lsu" "andes_45_arch") +(define_cpu_unit "andes_45_fpu_fmac,andes_45_fpu_fdiv,andes_45_fpu_fmis,andes_45_fpu_fmv" "andes_45_arch") +(define_cpu_unit "andes_45_vpu_alu,andes_45_vpu_mac,andes_45_vpu_fmis,andes_45_vpu_permut, + andes_45_vpu_div,andes_45_vpu_fdiv,andes_45_vpu_mask,andes_45_vpu_lsu" "andes_45_vector") + +(define_reservation "andes_45_fpu_arith" + "andes_45_pipe0 + andes_45_fpu_fmac | andes_45_pipe1 + andes_45_fpu_fmac") + +;; andes 45 series unsupported insns are mapped to dummies reservations +(define_reservation "andes_45_dummies" + "andes_45_pipe0 | andes_45_pipe1, andes_45_alu0 | andes_45_alu1") + +;; andes 45 series vector unsupported insns are mapped to dummies reservations +(define_reservation "andes_45_vector_dummies" + "andes_45_pipe0 | andes_45_pipe1, andes_45_vpu_alu") + +(define_insn_reservation "andes_45_alu_insn_s" 1 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "shift,nop,logical")) + "andes_45_pipe0 + andes_45_alu0 | andes_45_pipe1 + andes_45_alu1") + +(define_insn_reservation "andes_45_alu_insn_l" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "unknown,const,arith,multi,slt,move,auipc,atomic,bitmanip")) + "andes_45_pipe0 + andes_45_alu0 | andes_45_pipe1 + andes_45_alu1") + +(define_insn_reservation "andes_45_cmov" 1 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "condmove")) + "andes_45_pipe0 + andes_45_alu0 + andes_45_pipe1 + andes_45_alu1") + +(define_insn_reservation "andes_45_load_wd" 4 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "load") + (not (eq_attr "mode" "QI,HI")))) + "andes_45_pipe0 + andes_45_lsu | andes_45_pipe1 + andes_45_lsu") + +(define_insn_reservation "andes_45_load_bh" 5 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "load") + (eq_attr "mode" "QI,HI"))) + "andes_45_pipe0 + andes_45_lsu | andes_45_pipe1 + andes_45_lsu") + +(define_insn_reservation "andes_45_store_d" 0 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "store") + (eq_attr "mode" "DI,SI"))) + "andes_45_pipe0 + andes_45_lsu | andes_45_pipe1 + andes_45_lsu") + +(define_insn_reservation "andes_45_store" 0 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "store") + (not (eq_attr "mode" "DI,SI")))) + "andes_45_pipe0 + andes_45_pipe1 + andes_45_lsu") + +(define_insn_reservation "andes_45_branch" 1 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "branch,jump,call,ret,jalr,trap")) + "andes_45_pipe0 + andes_45_bru0 | andes_45_pipe1 + andes_45_bru1") + +(define_insn_reservation "andes_45_imul" 3 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "imul")) + "andes_45_pipe0 + andes_45_alu0 | andes_45_pipe1 + andes_45_alu1, andes_45_mdu * 2") + +(define_insn_reservation "andes_45_idivsi" 38 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "idiv") + (eq_attr "mode" "SI"))) + "andes_45_pipe0 + andes_45_alu0 | andes_45_pipe1 + andes_45_alu1, andes_45_mdu * 2") + +(define_insn_reservation "andes_45_idivdi" 70 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "idiv") + (eq_attr "mode" "DI"))) + "andes_45_pipe0 + andes_45_alu0 | andes_45_pipe1 + andes_45_alu1, andes_45_mdu * 2") + +(define_insn_reservation "andes_45_xfer" 1 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "mfc,mtc")) + "andes_45_pipe0 + andes_45_alu0 | andes_45_pipe1 + andes_45_alu1") + +(define_insn_reservation "andes_45_fpu_alu_s" 3 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "fadd") + (eq_attr "mode" "SF"))) + "andes_45_fpu_arith") + +(define_insn_reservation "andes_45_fpu_alu_d" 4 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "fadd") + (eq_attr "mode" "DF"))) + "andes_45_fpu_arith") + +(define_insn_reservation "andes_45_fpu_mul_s" 3 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "fmul") + (eq_attr "mode" "SF"))) + "andes_45_fpu_arith") + +(define_insn_reservation "andes_45_fpu_mul_d" 4 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "fmul") + (eq_attr "mode" "DF"))) + "andes_45_fpu_arith") + +(define_insn_reservation "andes_45_fpu_mac_s" 3 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "fmadd") + (eq_attr "mode" "SF"))) + "(andes_45_pipe0 | andes_45_pipe1) + andes_45_fpu_fmac + andes_45_fpu_fmv + andes_45_fpu_fmis") + +(define_insn_reservation "andes_45_fpu_mac_d" 4 + (and (eq_attr "tune" "andes_45_series") + (and (eq_attr "type" "fmadd") + (eq_attr "mode" "DF"))) + "(andes_45_pipe0 | andes_45_pipe1) + andes_45_fpu_fmac + andes_45_fpu_fmv + andes_45_fpu_fmis") + +(define_insn_reservation "andes_45_fpu_div" 33 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "fdiv")) + "andes_45_pipe0 + andes_45_fpu_fdiv | andes_45_pipe1 + andes_45_fpu_fdiv, andes_45_fpu_fdiv * 27") + +(define_insn_reservation "andes_45_fpu_sqrt" 33 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "fsqrt")) + "andes_45_pipe0 + andes_45_fpu_fdiv | andes_45_pipe1 + andes_45_fpu_fdiv, andes_45_fpu_fdiv * 27") + +(define_insn_reservation "andes_45_fpu_move" 1 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "fmove,mtc,mfc")) + "andes_45_pipe0 + andes_45_fpu_fmv | andes_45_pipe1 + andes_45_fpu_fmv") + +(define_insn_reservation "andes_45_fpu_cmp" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "fcmp")) + "andes_45_pipe0 + andes_45_fpu_fmis | andes_45_pipe1 + andes_45_fpu_fmis") + +(define_insn_reservation "andes_45_fpu_cvt" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "fcvt,fcvt_f2i,fcvt_i2f")) + "andes_45_pipe0 + andes_45_fpu_fmis | andes_45_pipe1 + andes_45_fpu_fmis") + +(define_insn_reservation "andes_45_fpu_load" 4 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "fpload")) + "andes_45_pipe0 + andes_45_pipe1 + andes_45_lsu") + +(define_insn_reservation "andes_45_fpu_store" 0 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "fpstore")) + "andes_45_pipe0 + andes_45_pipe1 + andes_45_lsu") + +(define_insn_reservation "andes_45_vpu_load_e" 8 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vlde,vldm,vldr,vlsegde,vldff,vlsegdff")) + "(andes_45_vpu_pipe + andes_45_vpu_lsu), andes_45_vpu_lsu * 2") + +(define_insn_reservation "andes_45_vpu_load_s" 10 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vlds,vlsegds")) + "(andes_45_vpu_pipe + andes_45_vpu_lsu), andes_45_vpu_lsu * 3") + +(define_insn_reservation "andes_45_vpu_load_x" 12 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vldox,vldux,vlsegdox,vlsegdux")) + "(andes_45_vpu_pipe + andes_45_vpu_lsu), andes_45_vpu_lsu * 4") + +(define_insn_reservation "andes_45_vpu_store" 0 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vste,vstm,vstr,vsts,vstux,vstox,vssegtox,vssegte, + vssegtux,vssegts")) + "andes_45_vpu_pipe + andes_45_lsu + andes_45_vpu_lsu") + +(define_insn_reservation "andes_45_vpu_alu" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vialu,viwalu,vicalu,vsalu,vaalu,vector")) + "andes_45_vpu_pipe + andes_45_vpu_alu") + +(define_insn_reservation "andes_45_vpu_ext" 3 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vext")) + "andes_45_vpu_pipe + andes_45_vpu_permut") + +(define_insn_reservation "andes_45_vpu_shift" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vshift,vnshift,vsshift")) + "andes_45_vpu_pipe + andes_45_vpu_alu") + +(define_insn_reservation "andes_45_vpu_minmax" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "viminmax")) + "andes_45_vpu_pipe + andes_45_vpu_alu") + +(define_insn_reservation "andes_45_vpu_cmp" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vicmp")) + "andes_45_vpu_pipe + andes_45_vpu_alu") + +(define_insn_reservation "andes_45_vpu_mul" 3 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vimul,viwmul,vsmul")) + "andes_45_vpu_pipe + andes_45_vpu_mac") + +(define_insn_reservation "andes_45_vpu_div" 36 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vidiv")) + "andes_45_vpu_pipe + andes_45_vpu_div * 35") + +(define_insn_reservation "andes_45_vpu_madd" 4 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vimuladd,viwmuladd")) + "andes_45_vpu_pipe + andes_45_vpu_mac") + +(define_insn_reservation "andes_45_vpu_merge" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vimerge")) + "andes_45_vpu_pipe + andes_45_vpu_alu") + +(define_insn_reservation "andes_45_vpu_move" 3 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vimov,vimovvx,vimovxv,vmov,vslideup,vslidedown,vislide1up,vislide1down")) + "andes_45_vpu_pipe + andes_45_vpu_permut") + +(define_insn_reservation "andes_45_vpu_clip" 3 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vnclip")) + "andes_45_vpu_pipe + andes_45_vpu_alu") + +(define_insn_reservation "andes_45_vpu_falu" 4 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfalu,vfwalu,vfmul,vfwmul")) + "andes_45_vpu_pipe + andes_45_vpu_mac") + +(define_insn_reservation "andes_45_vpu_fdiv" 38 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfdiv,vfsqrt")) + "andes_45_vpu_pipe + andes_45_vpu_fdiv") + +(define_insn_reservation "andes_45_vpu_fmadd" 5 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfmuladd,vfwmuladd")) + "andes_45_vpu_pipe + andes_45_vpu_mac") + +(define_insn_reservation "andes_45_vpu_fminmax" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfminmax")) + "andes_45_vpu_pipe + andes_45_vpu_fmis") + +(define_insn_reservation "andes_45_vpu_fcmp" 3 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfcmp,vfrecp")) + "andes_45_vpu_pipe + andes_45_vpu_fmis") + +(define_insn_reservation "andes_45_vpu_fsgnj" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfsgnj")) + "andes_45_vpu_pipe + andes_45_vpu_fmis") + +(define_insn_reservation "andes_45_vpu_fclass" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfclass")) + "andes_45_vpu_pipe + andes_45_vpu_fmis") + +(define_insn_reservation "andes_45_vpu_fmerge" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfmerge")) + "andes_45_vpu_pipe + andes_45_vpu_fmis") + +(define_insn_reservation "andes_45_vpu_fmove" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfmov,vfmovvf,vfmovfv,vfslide1up,vfslide1down")) + "andes_45_vpu_pipe + andes_45_vpu_permut") + +(define_insn_reservation "andes_45_vpu_fcvt" 3 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfcvtitof,vfcvtftoi,vfwcvtitof,vfwcvtftoi,vfwcvtftof, + vfncvtitof,vfncvtftoi,vfncvtftof,vfwcvtbf16,vfncvtbf16")) + "andes_45_vpu_pipe + andes_45_vpu_fmis") + +(define_insn_reservation "andes_45_vpu_red" 9 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vired,viwred")) + "andes_45_vpu_pipe + andes_45_vpu_alu") + +(define_insn_reservation "andes_45_vpu_fredu" 6 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfredu,vfwredu")) + "andes_45_vpu_pipe + andes_45_vpu_mac") + +(define_insn_reservation "andes_45_vpu_fredo" 34 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vfredo,vfwredo")) + "andes_45_vpu_pipe + andes_45_vpu_mac") + +(define_insn_reservation "andes_45_vpu_malu" 3 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vmalu")) + "andes_45_vpu_pipe + andes_45_vpu_mask") + +(define_insn_reservation "andes_45_vpu_mask" 4 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vmpop,vmffs,vmsfs,vmiota,vmidx")) + "andes_45_vpu_pipe + andes_45_vpu_mask") + +(define_insn_reservation "andes_45_vpu_gather" 2 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vgather")) + "andes_45_vpu_pipe + andes_45_vpu_permut") + +(define_insn_reservation "andes_45_vpu_compress" 4 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vcompress")) + "andes_45_vpu_pipe + andes_45_vpu_permut") + +(define_insn_reservation "andes_45_vcpu_csr" 1 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "wrvxrm,wrfrm,rdvlenb,rdvl,vsetvl,vsetvl_pre")) + "andes_45_vpu_pipe") + +(define_bypass 1 + "andes_45_fpu_alu_s, andes_45_fpu_mul_s, andes_45_fpu_mac_s" + "andes_45_load_wd, andes_45_load_bh, andes_45_store, + andes_45_fpu_load, andes_45_fpu_store") + +(define_bypass 2 + "andes_45_fpu_alu_d, andes_45_fpu_mul_d, andes_45_fpu_mac_d" + "andes_45_load_wd, andes_45_load_bh, andes_45_store, + andes_45_fpu_load, andes_45_fpu_store") + +(define_bypass 1 + "andes_45_fpu_cmp, andes_45_fpu_cvt" + "andes_45_load_wd, andes_45_load_bh, andes_45_store, + andes_45_fpu_load, andes_45_fpu_store, andes_45_alu_insn_s, + andes_45_alu_insn_l, andes_45_xfer") + +(define_insn_reservation "andes_45_unknown" 1 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "ghost,cpop,clz,ctz,zicond,mvpair,sfb_alu,minu,maxu, + min,max,clmul,rotate,crypto,condmove,rdfrm")) + "andes_45_dummies") + +(define_insn_reservation "andes_45_vector_unknown" 1 + (and (eq_attr "tune" "andes_45_series") + (eq_attr "type" "vclz,vror,vsha2ch,vsm4k,vaesef,vghsh,vsm4r,vsm3c, + vaeskf1,vandn,vaesdm,vclmul,vclmulh,vrol,vcpop,vbrev8, + vsm3me,vbrev,vctz,vgmul,vsha2ms,vaesz,vrev8, + vaeskf2,vsha2cl,vwsll,vaesdf,vaesem,vfwmaccbf16, + sf_vqmacc,sf_vc,sf_vc_se,sf_vfnrclip,vlsegde")) + "andes_45_vector_dummies") diff --git a/gcc/config/riscv/riscv-c.cc b/gcc/config/riscv/riscv-c.cc index d497326e0611..4fc052817824 100644 --- a/gcc/config/riscv/riscv-c.cc +++ b/gcc/config/riscv/riscv-c.cc @@ -165,15 +165,6 @@ riscv_cpu_cpp_builtins (cpp_reader *pfile) if (!subset_list) return; - /* Define profile macro if a profile was used. */ - const char *profile_name = subset_list->get_profile_name (); - if (profile_name) - { - char *profile_macro = (char *)alloca (strlen (profile_name) + 10); - sprintf (profile_macro, "__riscv_%s", profile_name); - builtin_define (profile_macro); - } - size_t max_ext_len = 0; /* Figure out the max length of extension name for reserving buffer. */ diff --git a/gcc/config/riscv/riscv-cores.def b/gcc/config/riscv/riscv-cores.def index abe9d496cda6..7266b5eac113 100644 --- a/gcc/config/riscv/riscv-cores.def +++ b/gcc/config/riscv/riscv-cores.def @@ -55,6 +55,8 @@ RISCV_TUNE("generic-ooo", generic_ooo, generic_ooo_tune_info) RISCV_TUNE("size", generic, optimize_size_tune_info) RISCV_TUNE("mips-p8700", mips_p8700, mips_p8700_tune_info) RISCV_TUNE("andes-25-series", andes_25_series, andes_25_tune_info) +RISCV_TUNE("andes-23-series", andes_23_series, andes_23_tune_info) +RISCV_TUNE("andes-45-series", andes_45_series, andes_45_tune_info) #undef RISCV_TUNE @@ -181,8 +183,19 @@ RISCV_CORE("andes-nx25", "rv64imc_zicsr_zifencei_xandesperf", "andes-25- RISCV_CORE("andes-ax25", "rv64imafdc_zicsr_zifencei_xandesperf", "andes-25-series") RISCV_CORE("andes-a27", "rv32imafdc_zicsr_zifencei_xandesperf", "andes-25-series") RISCV_CORE("andes-ax27", "rv64imafdc_zicsr_zifencei_xandesperf", "andes-25-series") +RISCV_CORE("andes-n225", "rv32im_zicsr_zifencei_zca_zcb_zcmp_zcmt_" + "zba_zbb_zbc_zbs_xandesperf", + "andes-23-series") +RISCV_CORE("andes-d23", "rv32im_zicsr_zifencei_zicbop_zicbom_zicboz_" + "zca_zcb_zcmp_zcmt_zba_zbb_zbc_zbs_xandesperf", + "andes-23-series") +RISCV_CORE("andes-n45", "rv32imc_zicsr_zifencei_xandesperf", "andes-45-series") +RISCV_CORE("andes-nx45", "rv64imc_zicsr_zifencei_xandesperf", "andes-45-series") +RISCV_CORE("andes-a45", "rv32imafdc_zicsr_zifencei_xandesperf", "andes-45-series") +RISCV_CORE("andes-ax45", "rv64imafdc_zicsr_zifencei_xandesperf", "andes-45-series") + RISCV_CORE("spacemit-x60", "rv64imafdcv_zba_zbb_zbc_zbs_zicboz_zicond_" - "zbkc_zfh_zvfh_zvkt_zvl256b_sscofpmf", + "zbkc_zfh_zvfh_zvkt_zvl256b_sscofpmf_xsmtvdot", "spacemit-x60") #undef RISCV_CORE diff --git a/gcc/config/riscv/riscv-ext-spacemit.def b/gcc/config/riscv/riscv-ext-spacemit.def new file mode 100644 index 000000000000..3482384e1c41 --- /dev/null +++ b/gcc/config/riscv/riscv-ext-spacemit.def @@ -0,0 +1,36 @@ +/* SpacemiT extension definition file for RISC-V. + Copyright (C) 2025 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GCC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. + +Please run `make riscv-regen` in build folder to make sure updated anything. + +Format of DEFINE_RISCV_EXT, please refer to riscv-ext.def. */ + +DEFINE_RISCV_EXT( + /* NAME */ xsmtvdot, + /* UPPERCASE_NAME */ XSMTVDOT, + /* FULL_NAME */ "SpacemiT vector dot product extension", + /* DESC */ "", + /* URL */ , + /* DEP_EXTS */ ({"zve32x"}), + /* SUPPORTED_VERSIONS */ ({{1, 0}}), + /* FLAG_GROUP */ xsmt, + /* BITMASK_GROUP_ID */ BITMASK_NOT_YET_ALLOCATED, + /* BITMASK_BIT_POSITION*/ BITMASK_NOT_YET_ALLOCATED, + /* EXTRA_EXTENSION_FLAGS */ 0) + diff --git a/gcc/config/riscv/riscv-ext.def b/gcc/config/riscv/riscv-ext.def index 80f534c64614..62d638015f35 100644 --- a/gcc/config/riscv/riscv-ext.def +++ b/gcc/config/riscv/riscv-ext.def @@ -2084,3 +2084,4 @@ DEFINE_RISCV_EXT( #include "riscv-ext-ventana.def" #include "riscv-ext-mips.def" #include "riscv-ext-andes.def" +#include "riscv-ext-spacemit.def" diff --git a/gcc/config/riscv/riscv-ext.opt b/gcc/config/riscv/riscv-ext.opt index 2036c16498b6..af8e556842bf 100644 --- a/gcc/config/riscv/riscv-ext.opt +++ b/gcc/config/riscv/riscv-ext.opt @@ -55,6 +55,9 @@ int riscv_xmips_subext TargetVariable int riscv_xsf_subext +TargetVariable +int riscv_xsmt_subext + TargetVariable int riscv_xthead_subext @@ -403,18 +406,6 @@ Mask(SVADE) Var(riscv_sv_subext) Mask(SVBARE) Var(riscv_sv_subext) -Mask(XANDESPERF) Var(riscv_xandes_subext) - -Mask(XANDESBFHCVT) Var(riscv_xandes_subext) - -Mask(XANDESVBFHCVT) Var(riscv_xandes_subext) - -Mask(XANDESVSINTLOAD) Var(riscv_xandes_subext) - -Mask(XANDESVPACKFPH) Var(riscv_xandes_subext) - -Mask(XANDESVDOT) Var(riscv_xandes_subext) - Mask(XCVALU) Var(riscv_xcv_subext) Mask(XCVBI) Var(riscv_xcv_subext) @@ -466,3 +457,18 @@ Mask(XVENTANACONDOPS) Var(riscv_xventana_subext) Mask(XMIPSCMOV) Var(riscv_xmips_subext) Mask(XMIPSCBOP) Var(riscv_xmips_subext) + +Mask(XANDESPERF) Var(riscv_xandes_subext) + +Mask(XANDESBFHCVT) Var(riscv_xandes_subext) + +Mask(XANDESVBFHCVT) Var(riscv_xandes_subext) + +Mask(XANDESVSINTLOAD) Var(riscv_xandes_subext) + +Mask(XANDESVPACKFPH) Var(riscv_xandes_subext) + +Mask(XANDESVDOT) Var(riscv_xandes_subext) + +Mask(XSMTVDOT) Var(riscv_xsmt_subext) + diff --git a/gcc/config/riscv/riscv-opts.h b/gcc/config/riscv/riscv-opts.h index bca5382485c3..9b92a965e27f 100644 --- a/gcc/config/riscv/riscv-opts.h +++ b/gcc/config/riscv/riscv-opts.h @@ -62,6 +62,8 @@ enum riscv_microarchitecture_type { mips_p8700, tt_ascalon_d8, andes_25_series, + andes_23_series, + andes_45_series, spacemit_x60, }; extern enum riscv_microarchitecture_type riscv_microarchitecture; diff --git a/gcc/config/riscv/riscv-subset.h b/gcc/config/riscv/riscv-subset.h index 1887ed7cc1c3..4cd860fee59b 100644 --- a/gcc/config/riscv/riscv-subset.h +++ b/gcc/config/riscv/riscv-subset.h @@ -105,8 +105,6 @@ class riscv_subset_list unsigned xlen () const {return m_xlen;}; - const char *get_profile_name () const; - riscv_subset_list *clone () const; static riscv_subset_list *parse (const char *, location_t *); diff --git a/gcc/config/riscv/riscv-v.cc b/gcc/config/riscv/riscv-v.cc index c6c22371d9a9..5e30b77b4ebf 100644 --- a/gcc/config/riscv/riscv-v.cc +++ b/gcc/config/riscv/riscv-v.cc @@ -1811,7 +1811,8 @@ expand_const_vector_onestep (rtx target, rvv_builder &builder) rtx dest = gen_reg_rtx (mode); insn_code icode = code_for_pred_mov (mode); rtx ops3[] = {dest, tmp3, tmp1}; - emit_nonvlmax_insn (icode, __MASK_OP_TUMA | UNARY_OP_P, ops3, GEN_INT (n)); + emit_nonvlmax_insn (icode, (unsigned) __MASK_OP_TUMA | UNARY_OP_P, + ops3, GEN_INT (n)); emit_move_insn (target, dest); } @@ -5265,7 +5266,7 @@ emit_vec_cvt_x_f (rtx op_dest, rtx op_src, rtx mask, { insn_code icode = code_for_pred_fcvt_x_f (UNSPEC_VFCVT, vec_mode); - if (type & USE_VUNDEF_MERGE_P) + if (type & (insn_type) USE_VUNDEF_MERGE_P) { rtx cvt_x_ops[] = {op_dest, mask, op_src}; emit_vlmax_insn (icode, type, cvt_x_ops); @@ -5333,7 +5334,7 @@ emit_vec_cvt_x_f_rtz (rtx op_dest, rtx op_src, rtx mask, { insn_code icode = code_for_pred (FIX, vec_mode); - if (type & USE_VUNDEF_MERGE_P) + if (type & (insn_type) USE_VUNDEF_MERGE_P) { rtx cvt_x_ops[] = {op_dest, mask, op_src}; emit_vlmax_insn (icode, type, cvt_x_ops); diff --git a/gcc/config/riscv/riscv-vsetvl.cc b/gcc/config/riscv/riscv-vsetvl.cc index 580ac9cbe8e8..127187b45552 100644 --- a/gcc/config/riscv/riscv-vsetvl.cc +++ b/gcc/config/riscv/riscv-vsetvl.cc @@ -1176,7 +1176,7 @@ class vsetvl_info if (fault_first_load_p (insn->rtl ())) { for (insn_info *i = insn->next_nondebug_insn (); - i->bb () == insn->bb (); i = i->next_nondebug_insn ()) + i && i->bb () == insn->bb (); i = i->next_nondebug_insn ()) { if (find_access (i->defs (), VL_REGNUM)) break; diff --git a/gcc/config/riscv/riscv.cc b/gcc/config/riscv/riscv.cc index 2d14b3c92f57..1804d5a689b4 100644 --- a/gcc/config/riscv/riscv.cc +++ b/gcc/config/riscv/riscv.cc @@ -784,6 +784,56 @@ static const struct riscv_tune_param spacemit_x60_tune_info= { true, /* prefer-agnostic. */ }; +/* Costs to use when optimizing for Andes 23 series. */ +static const struct riscv_tune_param andes_23_tune_info = { + {COSTS_N_INSNS (4), COSTS_N_INSNS (5)}, /* fp_add */ + {COSTS_N_INSNS (4), COSTS_N_INSNS (5)}, /* fp_mul */ + {COSTS_N_INSNS (20), COSTS_N_INSNS (20)}, /* fp_div */ + {COSTS_N_INSNS (2), COSTS_N_INSNS (2)}, /* int_mul */ + {COSTS_N_INSNS (24), COSTS_N_INSNS (24)}, /* int_div */ + 2, /* issue_rate */ + 3, /* branch_cost */ + 3, /* memory_cost */ + 8, /* fmv_cost */ + false, /* slow_unaligned_access */ + false, /* vector_unaligned_access */ + true, /* use_divmod_expansion */ + false, /* overlap_op_by_pieces */ + false, /* use_zero_stride_load */ + false, /* speculative_sched_vsetvl */ + RISCV_FUSE_NOTHING, /* fusible_ops */ + NULL, /* vector cost */ + NULL, /* function_align */ + NULL, /* jump_align */ + NULL, /* loop_align */ + true, /* prefer-agnostic. */ +}; + +/* Costs to use when optimizing for Andes 45 series. */ +static const struct riscv_tune_param andes_45_tune_info = { + {COSTS_N_INSNS (4), COSTS_N_INSNS (5)}, /* fp_add */ + {COSTS_N_INSNS (4), COSTS_N_INSNS (5)}, /* fp_mul */ + {COSTS_N_INSNS (20), COSTS_N_INSNS (20)}, /* fp_div */ + {COSTS_N_INSNS (2), COSTS_N_INSNS (2)}, /* int_mul */ + {COSTS_N_INSNS (24), COSTS_N_INSNS (24)}, /* int_div */ + 2, /* issue_rate */ + 3, /* branch_cost */ + 3, /* memory_cost */ + 8, /* fmv_cost */ + false, /* slow_unaligned_access */ + false, /* vector_unaligned_access */ + true, /* use_divmod_expansion */ + false, /* overlap_op_by_pieces */ + false, /* use_zero_stride_load */ + false, /* speculative_sched_vsetvl */ + RISCV_FUSE_NOTHING, /* fusible_ops */ + NULL, /* vector cost */ + NULL, /* function_align */ + NULL, /* jump_align */ + NULL, /* loop_align */ + true, /* prefer-agnostic. */ +}; + static bool riscv_avoid_shrink_wrapping_separate (); static tree riscv_handle_fndecl_attribute (tree *, tree, tree, int, bool *); static tree riscv_handle_type_attribute (tree *, tree, tree, int, bool *); @@ -2814,7 +2864,7 @@ riscv_unspec_address_offset (rtx base, rtx offset, enum riscv_symbol_type symbol_type) { base = gen_rtx_UNSPEC (Pmode, gen_rtvec (1, base), - UNSPEC_ADDRESS_FIRST + symbol_type); + UNSPEC_ADDRESS_FIRST + (int) symbol_type); if (offset != const0_rtx) base = gen_rtx_PLUS (Pmode, base, offset); return gen_rtx_CONST (Pmode, base); @@ -4964,7 +5014,7 @@ riscv_output_move (rtx dest, rtx src) if (TARGET_ZFHMIN || TARGET_ZFBFMIN) return "fmv.x.h\t%0,%1"; /* Using fmv.x.s + sign-extend to emulate fmv.x.h. */ - return "fmv.x.s\t%0,%1;slli\t%0,%0,16;srai\t%0,%0,16"; + return "fmv.x.s\t%0,%1\n\tslli\t%0,%0,16\n\tsrai\t%0,%0,16"; case 4: return "fmv.x.s\t%0,%1"; case 8: diff --git a/gcc/config/riscv/riscv.h b/gcc/config/riscv/riscv.h index a0ad75c765a1..6a3e5372d3b5 100644 --- a/gcc/config/riscv/riscv.h +++ b/gcc/config/riscv/riscv.h @@ -60,17 +60,18 @@ extern const char *riscv_arch_help (int argc, const char **argv); { "riscv_arch_help", riscv_arch_help }, /* Support for a compile-time default CPU, et cetera. The rules are: - --with-arch is ignored if -march or -mcpu is specified. + --with-arch and --with-cpu are ignored if -march or -mcpu is specified. --with-abi is ignored if -mabi is specified. --with-tune is ignored if -mtune or -mcpu is specified. --with-isa-spec is ignored if -misa-spec is specified. --with-tls is ignored if -mtls-dialect is specified. - But using default -march/-mtune value if -mcpu don't have valid option. */ + Uses default values if -mcpu doesn't have a valid option. */ #define OPTION_DEFAULT_SPECS \ {"tune", "%{!mtune=*:" \ " %{!mcpu=*:-mtune=%(VALUE)}" \ " %{mcpu=*:-mtune=%:riscv_default_mtune(%* %(VALUE))}}" }, \ + {"cpu", "%{!march=*:%{!mcpu=*:%:riscv_expand_arch_from_cpu(%(VALUE))}}" }, \ {"arch", "%{!march=*|march=unset:" \ " %{!mcpu=*:-march=%(VALUE)}" \ " %{mcpu=*:%:riscv_expand_arch_from_cpu(%* %(VALUE))}}" }, \ diff --git a/gcc/config/riscv/riscv.md b/gcc/config/riscv/riscv.md index affccec2b5e6..6f8cd26e5c95 100644 --- a/gcc/config/riscv/riscv.md +++ b/gcc/config/riscv/riscv.md @@ -674,7 +674,7 @@ ;; Keep this in sync with enum riscv_microarchitecture. (define_attr "tune" "generic,sifive_7,sifive_p400,sifive_p600,xiangshan,generic_ooo,mips_p8700, - tt_ascalon_d8,andes_25_series,spacemit_x60" + tt_ascalon_d8,andes_25_series,andes_23_series,andes_45_series,spacemit_x60" (const (symbol_ref "((enum attr_tune) riscv_microarchitecture)"))) ;; Describe a user's asm statement. @@ -4989,5 +4989,7 @@ (include "generic-vector-ooo.md") (include "generic-ooo.md") (include "tt-ascalon-d8.md") +(include "andes-23-series.md") (include "andes-25-series.md") +(include "andes-45-series.md") (include "spacemit-x60.md") diff --git a/gcc/config/riscv/t-riscv b/gcc/config/riscv/t-riscv index 3f92feab50ec..2761e5e20c00 100644 --- a/gcc/config/riscv/t-riscv +++ b/gcc/config/riscv/t-riscv @@ -222,7 +222,8 @@ RISCV_EXT_DEFS = \ $(srcdir)/config/riscv/riscv-ext-thead.def \ $(srcdir)/config/riscv/riscv-ext-ventana.def \ $(srcdir)/config/riscv/riscv-ext-mips.def \ - $(srcdir)/config/riscv/riscv-ext-andes.def + $(srcdir)/config/riscv/riscv-ext-andes.def \ + $(srcdir)/config/riscv/riscv-ext-spacemit.def $(srcdir)/config/riscv/riscv-ext.opt: $(RISCV_EXT_DEFS) diff --git a/gcc/config/rs6000/rs6000-logue.cc b/gcc/config/rs6000/rs6000-logue.cc index 5377ad6cee62..0005039733bd 100644 --- a/gcc/config/rs6000/rs6000-logue.cc +++ b/gcc/config/rs6000/rs6000-logue.cc @@ -5332,18 +5332,18 @@ rs6000_output_function_epilogue (FILE *file) /* Tbtab format type. Use format type 0. */ fputs ("\t.byte 0,", file); - /* Language type. Unfortunately, there does not seem to be any - official way to discover the language being compiled, so we - use language_string. - C is 0. Fortran is 1. Ada is 3. Modula-2 is 8. C++ is 9. - Java is 13. Objective-C is 14. Objective-C++ isn't assigned - a number, so for now use 9. LTO, Go, D, and JIT aren't assigned - numbers either, so for now use 0. */ + /* Language type. Unfortunately, there does not seem to be any official + way to discover the language being compiled, so we use + language_string. C is 0. Fortran is 1. Ada is 3. Modula-2 is 8. + C++ is 9. Java is 13. Objective-C is 14. Objective-C++ isn't + assigned a number, so for now use 9. LTO, Go, D, Algol 68 and JIT + aren't assigned numbers either, so for now use 0. */ if (lang_GNU_C () || ! strcmp (language_string, "GNU GIMPLE") || ! strcmp (language_string, "GNU Go") || ! strcmp (language_string, "GNU D") || ! strcmp (language_string, "GNU Rust") + || ! strcmp (language_string, "GNU Algol 68") || ! strcmp (language_string, "libgccjit")) i = 0; else if (! strcmp (language_string, "GNU F77") diff --git a/gcc/config/rs6000/rs6000.cc b/gcc/config/rs6000/rs6000.cc index 1d5cd25c0f08..bf899adc5315 100644 --- a/gcc/config/rs6000/rs6000.cc +++ b/gcc/config/rs6000/rs6000.cc @@ -28490,7 +28490,7 @@ static inline built_in_function complex_multiply_builtin_code (machine_mode mode) { gcc_assert (IN_RANGE (mode, MIN_MODE_COMPLEX_FLOAT, MAX_MODE_COMPLEX_FLOAT)); - int func = BUILT_IN_COMPLEX_MUL_MIN + mode - MIN_MODE_COMPLEX_FLOAT; + int func = BUILT_IN_COMPLEX_MUL_MIN + (mode - MIN_MODE_COMPLEX_FLOAT); return (built_in_function) func; } @@ -28501,7 +28501,7 @@ static inline built_in_function complex_divide_builtin_code (machine_mode mode) { gcc_assert (IN_RANGE (mode, MIN_MODE_COMPLEX_FLOAT, MAX_MODE_COMPLEX_FLOAT)); - int func = BUILT_IN_COMPLEX_DIV_MIN + mode - MIN_MODE_COMPLEX_FLOAT; + int func = BUILT_IN_COMPLEX_DIV_MIN + (mode - MIN_MODE_COMPLEX_FLOAT); return (built_in_function) func; } diff --git a/gcc/config/rs6000/rs6000.opt.urls b/gcc/config/rs6000/rs6000.opt.urls index 0b418c09a083..ff2a53413098 100644 --- a/gcc/config/rs6000/rs6000.opt.urls +++ b/gcc/config/rs6000/rs6000.opt.urls @@ -37,10 +37,10 @@ mmultiple UrlSuffix(gcc/RS_002f6000-and-PowerPC-Options.html#index-mmultiple) msoft-float -UrlSuffix(gcc/RS_002f6000-and-PowerPC-Options.html#index-msoft-float-11) +UrlSuffix(gcc/RS_002f6000-and-PowerPC-Options.html#index-msoft-float-10) mhard-float -UrlSuffix(gcc/RS_002f6000-and-PowerPC-Options.html#index-mhard-float-6) +UrlSuffix(gcc/RS_002f6000-and-PowerPC-Options.html#index-mhard-float-5) mpopcntd UrlSuffix(gcc/RS_002f6000-and-PowerPC-Options.html#index-mpopcntd) diff --git a/gcc/config/s390/s390-builtins.h b/gcc/config/s390/s390-builtins.h index e19fc7eec51b..1e596aef7ce4 100644 --- a/gcc/config/s390/s390-builtins.h +++ b/gcc/config/s390/s390-builtins.h @@ -134,10 +134,10 @@ S390_OVERLOADED_BUILTIN_VAR_MAX #define S390_OVERLOADED_BUILTIN_OFFSET S390_BUILTIN_MAX #define S390_OVERLOADED_BUILTIN_VAR_OFFSET \ - (S390_BUILTIN_MAX + S390_OVERLOADED_BUILTIN_MAX) -#define S390_ALL_BUILTIN_MAX \ - (S390_BUILTIN_MAX + S390_OVERLOADED_BUILTIN_MAX + \ - S390_OVERLOADED_BUILTIN_VAR_MAX) + ((int)S390_BUILTIN_MAX + (int)S390_OVERLOADED_BUILTIN_MAX) +#define S390_ALL_BUILTIN_MAX \ + ((int)S390_BUILTIN_MAX + (int)S390_OVERLOADED_BUILTIN_MAX + \ + (int)S390_OVERLOADED_BUILTIN_VAR_MAX) extern const unsigned int bflags_builtin[S390_BUILTIN_MAX + 1]; extern const unsigned int opflags_builtin[S390_BUILTIN_MAX + 1]; @@ -172,6 +172,4 @@ opflags_for_builtin (int fcode) return opflags_builtin[fcode]; } -extern GTY(()) tree s390_builtin_decls[S390_BUILTIN_MAX + - S390_OVERLOADED_BUILTIN_MAX + - S390_OVERLOADED_BUILTIN_VAR_MAX]; +extern GTY(()) tree s390_builtin_decls[S390_ALL_BUILTIN_MAX]; diff --git a/gcc/config/s390/s390.cc b/gcc/config/s390/s390.cc index d65109026f2a..359ea1c3d64b 100644 --- a/gcc/config/s390/s390.cc +++ b/gcc/config/s390/s390.cc @@ -686,9 +686,7 @@ opflags_overloaded_builtin_var[S390_OVERLOADED_BUILTIN_VAR_MAX + 1] = tree s390_builtin_types[BT_MAX]; tree s390_builtin_fn_types[BT_FN_MAX]; -tree s390_builtin_decls[S390_BUILTIN_MAX + - S390_OVERLOADED_BUILTIN_MAX + - S390_OVERLOADED_BUILTIN_VAR_MAX]; +tree s390_builtin_decls[S390_ALL_BUILTIN_MAX]; static enum insn_code const code_for_builtin[S390_BUILTIN_MAX + 1] = { #undef B_DEF @@ -771,12 +769,12 @@ s390_init_builtins (void) ATTRS); #undef OB_DEF #define OB_DEF(NAME, FIRST_VAR_NAME, LAST_VAR_NAME, BFLAGS, FNTYPE) \ - if (s390_builtin_decls[S390_OVERLOADED_BUILTIN_##NAME + S390_BUILTIN_MAX] \ + if (s390_builtin_decls[(int)S390_OVERLOADED_BUILTIN_##NAME + (int)S390_BUILTIN_MAX] \ == NULL) \ - s390_builtin_decls[S390_OVERLOADED_BUILTIN_##NAME + S390_BUILTIN_MAX] = \ + s390_builtin_decls[(int)S390_OVERLOADED_BUILTIN_##NAME + (int)S390_BUILTIN_MAX] = \ add_builtin_function ("__builtin_" #NAME, \ s390_builtin_fn_types[FNTYPE], \ - S390_OVERLOADED_BUILTIN_##NAME + S390_BUILTIN_MAX, \ + (int)S390_OVERLOADED_BUILTIN_##NAME + (int)S390_BUILTIN_MAX, \ BUILT_IN_MD, \ NULL, \ 0); diff --git a/gcc/config/s390/s390.opt.urls b/gcc/config/s390/s390.opt.urls index be0904ce1ced..021f2d790158 100644 --- a/gcc/config/s390/s390.opt.urls +++ b/gcc/config/s390/s390.opt.urls @@ -22,16 +22,16 @@ mhard-dfp UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mhard-dfp-1) mhard-float -UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mhard-float-7) +UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mhard-float-6) mhotpatch= UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mhotpatch) mlong-double-128 -UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mlong-double-128) +UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mlong-double-128-1) mlong-double-64 -UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mlong-double-64) +UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mlong-double-64-1) mhtm UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mhtm-1) @@ -46,7 +46,7 @@ msmall-exec UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-msmall-exec) msoft-float -UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-msoft-float-12) +UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-msoft-float-11) mstack-guard= UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mstack-guard) @@ -58,7 +58,9 @@ mstack-protector-guard-record UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mstack-protector-guard-record) mstack-size= -UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mstack-size-2) +UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mstack-size-1) + +; skipping UrlSuffix for 'mno-stack-size' due to finding no URLs mtune= UrlSuffix(gcc/S_002f390-and-zSeries-Options.html#index-mtune-14) diff --git a/gcc/config/sparc/sparc.opt.urls b/gcc/config/sparc/sparc.opt.urls index 1188f88fdaab..a221b6b1ea24 100644 --- a/gcc/config/sparc/sparc.opt.urls +++ b/gcc/config/sparc/sparc.opt.urls @@ -4,10 +4,10 @@ mfpu UrlSuffix(gcc/SPARC-Options.html#index-mfpu-4) mhard-float -UrlSuffix(gcc/SPARC-Options.html#index-mhard-float-8) +UrlSuffix(gcc/SPARC-Options.html#index-mhard-float-7) msoft-float -UrlSuffix(gcc/SPARC-Options.html#index-msoft-float-13) +UrlSuffix(gcc/SPARC-Options.html#index-msoft-float-12) mflat UrlSuffix(gcc/SPARC-Options.html#index-mflat) diff --git a/gcc/config/v850/v850.opt.urls b/gcc/config/v850/v850.opt.urls index a06f4833f47c..6f8102f9996c 100644 --- a/gcc/config/v850/v850.opt.urls +++ b/gcc/config/v850/v850.opt.urls @@ -18,7 +18,7 @@ mghs UrlSuffix(gcc/V850-Options.html#index-mghs) mlong-calls -UrlSuffix(gcc/V850-Options.html#index-mlong-calls-7) +UrlSuffix(gcc/V850-Options.html#index-mlong-calls-8) mprolog-function UrlSuffix(gcc/V850-Options.html#index-mprolog-function) @@ -71,10 +71,10 @@ mlong-jumps UrlSuffix(gcc/V850-Options.html#index-mlong-jumps) msoft-float -UrlSuffix(gcc/V850-Options.html#index-msoft-float-14) +UrlSuffix(gcc/V850-Options.html#index-msoft-float-13) mhard-float -UrlSuffix(gcc/V850-Options.html#index-mhard-float-9) +UrlSuffix(gcc/V850-Options.html#index-mhard-float-8) mrh850-abi UrlSuffix(gcc/V850-Options.html#index-mrh850-abi) diff --git a/gcc/config/vax/vax.opt.urls b/gcc/config/vax/vax.opt.urls index 7813b886baa2..758a5a733e6c 100644 --- a/gcc/config/vax/vax.opt.urls +++ b/gcc/config/vax/vax.opt.urls @@ -19,5 +19,5 @@ munix UrlSuffix(gcc/VAX-Options.html#index-munix) mlra -UrlSuffix(gcc/VAX-Options.html#index-mlra-3) +UrlSuffix(gcc/VAX-Options.html#index-mlra-2) diff --git a/gcc/config/visium/visium.opt.urls b/gcc/config/visium/visium.opt.urls index 38ba88dfe612..16984e7f176f 100644 --- a/gcc/config/visium/visium.opt.urls +++ b/gcc/config/visium/visium.opt.urls @@ -10,10 +10,10 @@ mfpu UrlSuffix(gcc/Visium-Options.html#index-mfpu-5) mhard-float -UrlSuffix(gcc/Visium-Options.html#index-mhard-float-10) +UrlSuffix(gcc/Visium-Options.html#index-mhard-float-9) msoft-float -UrlSuffix(gcc/Visium-Options.html#index-msoft-float-15) +UrlSuffix(gcc/Visium-Options.html#index-msoft-float-14) mcpu= UrlSuffix(gcc/Visium-Options.html#index-mcpu-13) diff --git a/gcc/configure b/gcc/configure index eba199a85262..d7074355e42b 100755 --- a/gcc/configure +++ b/gcc/configure @@ -10492,6 +10492,8 @@ if test "x$ZSTD_LIB" != x \ ZSTD_LDFLAGS=-L$ZSTD_LIB fi +saved_CXXFLAGS="$CXXFLAGS" +saved_LDFLAGS="$LDFLAGS" CXXFLAGS="$CXXFLAGS $ZSTD_CPPFLAGS" LDFLAGS="$LDFLAGS $ZSTD_LDFLAGS" @@ -10600,6 +10602,9 @@ elif test "x$with_zstd" != x; then fi fi +CXXFLAGS="$saved_CXXFLAGS" +LDFLAGS="$saved_LDFLAGS" + for ac_func in times clock kill getrlimit setrlimit atoq \ @@ -21872,7 +21877,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 21875 "configure" +#line 21880 "configure" #include "confdefs.h" #if HAVE_DLFCN_H @@ -21978,7 +21983,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 21981 "configure" +#line 21986 "configure" #include "confdefs.h" #if HAVE_DLFCN_H diff --git a/gcc/configure.ac b/gcc/configure.ac index 598c09761cbc..b6d9608d5994 100644 --- a/gcc/configure.ac +++ b/gcc/configure.ac @@ -1502,6 +1502,8 @@ if test "x$ZSTD_LIB" != x \ ZSTD_LDFLAGS=-L$ZSTD_LIB fi +saved_CXXFLAGS="$CXXFLAGS" +saved_LDFLAGS="$LDFLAGS" CXXFLAGS="$CXXFLAGS $ZSTD_CPPFLAGS" LDFLAGS="$LDFLAGS $ZSTD_LDFLAGS" @@ -1533,6 +1535,9 @@ elif test "x$with_zstd" != x; then fi fi +CXXFLAGS="$saved_CXXFLAGS" +LDFLAGS="$saved_LDFLAGS" + dnl Disabled until we have a complete test for buggy enum bitfields. dnl gcc_AC_C_ENUM_BF_UNSIGNED diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index 04c9684aa6fe..a4c2db7ca013 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,70 @@ +2025-11-30 Jakub Jelinek + + PR c++/122465 + * parser.cc (cp_parser_simple_declaration): Adjust function comment. + Set *maybe_range_for_decl to error_mark_node instead of keeping it + NULL_TREE in error cases or when followed by CPP_COLON. + +2025-11-30 Nathaniel Shead + + PR c++/119864 + * module.cc (trees_in::read_function_def): Don't call + post_process on OpenMP UDT reductions. + * parser.cc (cp_parser_omp_declare_reduction): Call push_decl + for block_scope, even when processing_template_decl. + +2025-11-29 Eczbek + Jason Merrill + + PR c++/116952 + * parser.cc (cp_parser_lambda_expression): Revert + r11-8166-ge1666ebd9ad31d change prohibiting lambda in non-type + parameter. + +2025-11-29 Jakub Jelinek + + PR c++/122758 + * decl.cc (pop_labels): Don't call adjust_backward_gotos if + processing_template_decl. + (decl_instrument_init_bypass_p): Always return false if + processing_template_decl. + (check_goto_1): Don't push anything to direct_goto vector + if processing_template_decl. + +2025-11-28 Jakub Jelinek + + PR c++/119969 + * cp-objcp-common.cc (cxx_get_alias_set): Remove special cases + for TYPE_PTRMEMFUNC_P and INDIRECT_TYPE_P for TYPE_PTRMEMFUNC_P. + +2025-11-26 Marek Polacek + + PR c++/121325 + * pt.cc (tsubst_tree_vec): New. + (tsubst_pack_index): Call it. + +2025-11-25 Nathaniel Shead + + PR c++/122699 + * name-lookup.h (expose_existing_namespace): Declare. + * name-lookup.cc (expose_existing_namespace): New function. + (push_namespace): Call it. + * pt.cc (tsubst_friend_function): Likewise. + +2025-11-25 Nathaniel Shead + + PR c++/122789 + * module.cc (trees_out::core_vals): Treat REQUIRES_EXPR + specially and stream the chained decls of its first operand. + (trees_in::core_vals): Likewise. + (trees_out::tree_node): Check the PARM_DECLs we see are what we + expect. + +2025-11-25 Jason Merrill + + * lang-specs.h: Add @c++-system-module. + * g++spec.cc (lang_specific_driver): Handle --compile-std-module. + 2025-11-24 Marek Polacek PR c++/119964 diff --git a/gcc/cp/cp-objcp-common.cc b/gcc/cp/cp-objcp-common.cc index c7e88cb7bfea..859c7d69746d 100644 --- a/gcc/cp/cp-objcp-common.cc +++ b/gcc/cp/cp-objcp-common.cc @@ -180,12 +180,6 @@ cxx_get_alias_set (tree t) complete type. */ return get_alias_set (TYPE_CONTEXT (t)); - /* Punt on PMFs until we canonicalize functions properly. */ - if (TYPE_PTRMEMFUNC_P (t) - || (INDIRECT_TYPE_P (t) - && TYPE_PTRMEMFUNC_P (TREE_TYPE (t)))) - return 0; - return c_common_get_alias_set (t); } diff --git a/gcc/cp/decl.cc b/gcc/cp/decl.cc index c5066dfc60be..d1fbbab6e4c3 100644 --- a/gcc/cp/decl.cc +++ b/gcc/cp/decl.cc @@ -517,7 +517,8 @@ pop_labels (tree block) auto_vec labels (named_labels->elements ()); hash_table::iterator end (named_labels->end ()); - if (flag_auto_var_init > AUTO_INIT_UNINITIALIZED) + if (flag_auto_var_init > AUTO_INIT_UNINITIALIZED + && !processing_template_decl) { for (decltype (end) iter (named_labels->begin ()); iter != end; ++iter) { @@ -3875,6 +3876,7 @@ decl_instrument_init_bypass_p (tree decl) tree type = TREE_TYPE (decl); return (flag_auto_var_init > AUTO_INIT_UNINITIALIZED + && !processing_template_decl && type != error_mark_node && VAR_P (decl) && !TREE_STATIC (decl) @@ -4357,7 +4359,9 @@ check_goto_1 (named_label_entry *ent, tree *declp) && ent->uses->binding_level == current_binding_level && ent->uses->names_in_scope == current_binding_level->names) { - if (declp && flag_auto_var_init > AUTO_INIT_UNINITIALIZED) + if (declp + && flag_auto_var_init > AUTO_INIT_UNINITIALIZED + && !processing_template_decl) vec_safe_push (ent->uses->direct_goto, named_label_fwd_direct_goto { declp }); return; @@ -4371,7 +4375,9 @@ check_goto_1 (named_label_entry *ent, tree *declp) new_use->in_omp_scope = false; new_use->computed_goto = computed ? make_tree_vector () : nullptr; new_use->direct_goto = nullptr; - if (declp && flag_auto_var_init > AUTO_INIT_UNINITIALIZED) + if (declp + && flag_auto_var_init > AUTO_INIT_UNINITIALIZED + && !processing_template_decl) vec_safe_push (new_use->direct_goto, named_label_fwd_direct_goto { declp }); @@ -18754,7 +18760,11 @@ start_enum (tree name, tree enumtype, tree underlying_type, } /* Returns true if TYPE is an enum that uses an enumerator name for - linkage purposes. */ + linkage purposes at namespace scope. The term is defined in [dcl.enum]/12 + for all enums, not just those at namespace scope, but for backward ABI + compatibility we want to treat those not at namespace scope the old way + and e.g. mangle the class scope ones based on their position within the + class rather than the first enumerator. */ bool enum_with_enumerator_for_linkage_p (tree type) @@ -18762,7 +18772,8 @@ enum_with_enumerator_for_linkage_p (tree type) return (cxx_dialect >= cxx20 && UNSCOPED_ENUM_P (type) && TYPE_ANON_P (type) - && TYPE_VALUES (type)); + && TYPE_VALUES (type) + && TYPE_NAMESPACE_SCOPE_P (type)); } /* After processing and defining all the values of an enumeration type, diff --git a/gcc/cp/module.cc b/gcc/cp/module.cc index 92449286a842..ea22cef24a5b 100644 --- a/gcc/cp/module.cc +++ b/gcc/cp/module.cc @@ -13015,7 +13015,13 @@ trees_in::read_function_def (tree decl, tree maybe_template) SET_DECL_FRIEND_CONTEXT (decl, context); if (cexpr.decl) register_constexpr_fundef (cexpr); - post_process (pdata); + + if (DECL_LOCAL_DECL_P (decl)) + /* Block-scope OMP UDRs aren't real functions, and don't need a + function structure to be allocated or to be expanded. */ + gcc_checking_assert (DECL_OMP_DECLARE_REDUCTION_P (decl)); + else + post_process (pdata); } else if (maybe_dup) { diff --git a/gcc/cp/parser.cc b/gcc/cp/parser.cc index e0c8e0ec8ad2..4289f47e1b23 100644 --- a/gcc/cp/parser.cc +++ b/gcc/cp/parser.cc @@ -11964,21 +11964,7 @@ cp_parser_lambda_expression (cp_parser* parser, LAMBDA_EXPR_CONSTEVAL_BLOCK_P (lambda_expr) = consteval_block_p; if (cxx_dialect >= cxx20) - { - /* C++20 allows lambdas in unevaluated context, but one in the type of a - non-type parameter is nonsensical. - - Distinguish a lambda in the parameter type from a lambda in the - default argument by looking at local_variables_forbidden_p, which is - only set in default arguments. */ - if (processing_template_parmlist && !parser->local_variables_forbidden_p) - { - error_at (token->location, - "lambda-expression in template parameter type"); - token->error_reported = true; - ok = false; - } - } + /* C++20 allows lambdas in unevaluated context. */; else if (cp_unevaluated_operand) { if (!token->error_reported) @@ -17100,8 +17086,9 @@ cp_parser_block_declaration (cp_parser *parser, If MAYBE_RANGE_FOR_DECL is not NULL, the pointed tree will be set to the parsed declaration if it is an uninitialized single declarator not followed - by a `;', or to error_mark_node otherwise. Either way, the trailing `;', - if present, will not be consumed. */ + by a `;', or to NULL_TREE when not followed by `:' or to error_mark_node + otherwise. Either way, the trailing `;', if present, will not be + consumed. */ static void cp_parser_simple_declaration (cp_parser* parser, @@ -17153,7 +17140,7 @@ cp_parser_simple_declaration (cp_parser* parser, && !decl_specifiers.any_specifiers_p) { cp_parser_error (parser, "expected declaration"); - goto done; + goto error_out; } /* If the next two tokens are both identifiers, the code is @@ -17169,7 +17156,7 @@ cp_parser_simple_declaration (cp_parser* parser, looking at a declaration. */ cp_parser_commit_to_tentative_parse (parser); /* Give up. */ - goto done; + goto error_out; } cp_parser_maybe_commit_to_declaration (parser, &decl_specifiers); @@ -17194,11 +17181,7 @@ cp_parser_simple_declaration (cp_parser* parser, if (token->type == CPP_SEMICOLON) goto finish; else if (maybe_range_for_decl) - { - if (*maybe_range_for_decl == NULL_TREE) - *maybe_range_for_decl = error_mark_node; - goto finish; - } + goto finish; /* Anything else is an error. */ else { @@ -17277,7 +17260,7 @@ cp_parser_simple_declaration (cp_parser* parser, statement is treated as a declaration-statement until proven otherwise.) */ if (cp_parser_error_occurred (parser)) - goto done; + goto error_out; if (auto_specifier_p && cxx_dialect >= cxx14) { @@ -17415,6 +17398,9 @@ cp_parser_simple_declaration (cp_parser* parser, if (comma_loc != UNKNOWN_LOCATION) error_at (comma_loc, "multiple declarations in range-based % loop"); + error_out: + if (maybe_range_for_decl && *maybe_range_for_decl == NULL_TREE) + *maybe_range_for_decl = error_mark_node; } done: @@ -53751,10 +53737,7 @@ cp_parser_omp_declare_reduction (cp_parser *parser, cp_token *pragma_tok, fndecl = push_template_decl (fndecl); if (block_scope) - { - if (!processing_template_decl) - pushdecl (fndecl); - } + pushdecl (fndecl); else if (current_class_type) { if (cp == NULL) diff --git a/gcc/cp/pt.cc b/gcc/cp/pt.cc index e74e34d81499..4dc8f980d0d0 100644 --- a/gcc/cp/pt.cc +++ b/gcc/cp/pt.cc @@ -14203,6 +14203,25 @@ tsubst_pack_expansion (tree t, tree args, tsubst_flags_t complain, return result; } +/* Substitute ARGS into T, which is a TREE_VEC. This function creates a new + TREE_VEC rather than substituting the elements in-place. */ + +static tree +tsubst_tree_vec (tree t, tree args, tsubst_flags_t complain, tree in_decl) +{ + const int len = TREE_VEC_LENGTH (t); + tree r = make_tree_vec (len); + for (int i = 0; i < len; ++i) + { + tree arg = TREE_VEC_ELT (t, i); + if (TYPE_P (arg)) + TREE_VEC_ELT (r, i) = tsubst (arg, args, complain, in_decl); + else + TREE_VEC_ELT (r, i) = tsubst_expr (arg, args, complain, in_decl); + } + return r; +} + /* Substitute ARGS into T, which is a pack index (i.e., PACK_INDEX_TYPE or PACK_INDEX_EXPR). Returns a single type or expression, a PACK_INDEX_* node if only a partial substitution could be performed, or ERROR_MARK_NODE @@ -14220,7 +14239,7 @@ tsubst_pack_index (tree t, tree args, tsubst_flags_t complain, tree in_decl) a partially instantiated closure. Let tsubst find the fully-instantiated one. */ gcc_assert (TREE_CODE (pack) == TREE_VEC); - pack = tsubst (pack, args, complain, in_decl); + pack = tsubst_tree_vec (pack, args, complain, in_decl); } if (TREE_CODE (pack) == TREE_VEC && TREE_VEC_LENGTH (pack) == 0) { diff --git a/gcc/crc-verification.cc b/gcc/crc-verification.cc index c7b0fedd6e4d..4b0018de5d67 100644 --- a/gcc/crc-verification.cc +++ b/gcc/crc-verification.cc @@ -58,7 +58,7 @@ crc_symbolic_execution::is_used_outside_the_loop (tree def) return false; } -/* Calculate value of the rhs operation of GS assigment statement +/* Calculate value of the rhs operation of GS assignment statement and assign it to lhs variable. */ bool diff --git a/gcc/d/ChangeLog b/gcc/d/ChangeLog index ab6042be5288..f2dd24ed1e86 100644 --- a/gcc/d/ChangeLog +++ b/gcc/d/ChangeLog @@ -1,3 +1,7 @@ +2025-11-30 Andrew Pinski + + * lang.opt.urls: Regenerate. + 2025-08-18 Indu Bhagat * d-attribs.cc (d_handle_no_sanitize_attribute): Use diff --git a/gcc/d/lang.opt.urls b/gcc/d/lang.opt.urls index b4886bf18ad4..d0d9bc8fd3d2 100644 --- a/gcc/d/lang.opt.urls +++ b/gcc/d/lang.opt.urls @@ -10,7 +10,7 @@ Hf LangUrlSuffix_D(gdc/Code-Generation.html#index-Hf) I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) J LangUrlSuffix_D(gdc/Directory-Options.html#index-J) @@ -103,7 +103,7 @@ fall-instantiations LangUrlSuffix_D(gdc/Runtime-Options.html#index-fall-instantiations) fassert -LangUrlSuffix_D(gdc/Runtime-Options.html#index-fassert) +LangUrlSuffix_D(gdc/Runtime-Options.html#index-fassert) LangUrlSuffix_Algol68(ga68/Runtime-options.html#index-fassert) fbounds-check LangUrlSuffix_D(gdc/Runtime-Options.html#index-fbounds-check) LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fbounds-check) diff --git a/gcc/doc/avr-mmcu.texi b/gcc/doc/avr-mmcu.texi index 1938994d74f9..427357979705 100644 --- a/gcc/doc/avr-mmcu.texi +++ b/gcc/doc/avr-mmcu.texi @@ -54,7 +54,7 @@ @item @anchor{avrxmega3}avrxmega3 ``XMEGA'' devices with up to 64@tie{}KiB of combined program memory and RAM, and with program memory visible in the RAM address space. -@*@var{mcu}@tie{}= @code{attiny202}, @code{attiny204}, @code{attiny212}, @code{attiny214}, @code{attiny402}, @code{attiny404}, @code{attiny406}, @code{attiny412}, @code{attiny414}, @code{attiny416}, @code{attiny416auto}, @code{attiny417}, @code{attiny424}, @code{attiny426}, @code{attiny427}, @code{attiny804}, @code{attiny806}, @code{attiny807}, @code{attiny814}, @code{attiny816}, @code{attiny817}, @code{attiny824}, @code{attiny826}, @code{attiny827}, @code{attiny1604}, @code{attiny1606}, @code{attiny1607}, @code{attiny1614}, @code{attiny1616}, @code{attiny1617}, @code{attiny1624}, @code{attiny1626}, @code{attiny1627}, @code{attiny3214}, @code{attiny3216}, @code{attiny3217}, @code{attiny3224}, @code{attiny3226}, @code{attiny3227}, @code{atmega808}, @code{atmega809}, @code{atmega1608}, @code{atmega1609}, @code{atmega3208}, @code{atmega3209}, @code{atmega4808}, @code{atmega4809}, @code{avr16dd14}, @code{avr16dd20}, @code{avr16dd28}, @code{avr16dd32}, @code{avr16du14}, @code{avr16du20}, @code{avr16du28}, @code{avr16du32}, @code{avr16ea28}, @code{avr16ea32}, @code{avr16ea48}, @code{avr16eb14}, @code{avr16eb20}, @code{avr16eb28}, @code{avr16eb32}, @code{avr32da28}, @code{avr32da28s}, @code{avr32da32}, @code{avr32da32s}, @code{avr32da48}, @code{avr32da48s}, @code{avr32db28}, @code{avr32db32}, @code{avr32db48}, @code{avr32dd14}, @code{avr32dd20}, @code{avr32dd28}, @code{avr32dd32}, @code{avr32du14}, @code{avr32du20}, @code{avr32du28}, @code{avr32du32}, @code{avr32ea28}, @code{avr32ea32}, @code{avr32ea48}, @code{avr32eb14}, @code{avr32eb20}, @code{avr32eb28}, @code{avr32eb32}, @code{avr32sd20}, @code{avr32sd28}, @code{avr32sd32}. +@*@var{mcu}@tie{}= @code{attiny202}, @code{attiny204}, @code{attiny212}, @code{attiny214}, @code{attiny402}, @code{attiny404}, @code{attiny406}, @code{attiny412}, @code{attiny414}, @code{attiny416}, @code{attiny416auto}, @code{attiny417}, @code{attiny424}, @code{attiny426}, @code{attiny427}, @code{attiny804}, @code{attiny806}, @code{attiny807}, @code{attiny814}, @code{attiny816}, @code{attiny817}, @code{attiny824}, @code{attiny826}, @code{attiny827}, @code{attiny1604}, @code{attiny1606}, @code{attiny1607}, @code{attiny1614}, @code{attiny1616}, @code{attiny1617}, @code{attiny1624}, @code{attiny1626}, @code{attiny1627}, @code{attiny3214}, @code{attiny3216}, @code{attiny3217}, @code{attiny3224}, @code{attiny3226}, @code{attiny3227}, @code{atmega808}, @code{atmega809}, @code{atmega1608}, @code{atmega1609}, @code{atmega3208}, @code{atmega3209}, @code{atmega4808}, @code{atmega4809}, @code{avr16dd14}, @code{avr16dd20}, @code{avr16dd28}, @code{avr16dd32}, @code{avr16du14}, @code{avr16du20}, @code{avr16du28}, @code{avr16du32}, @code{avr16ea28}, @code{avr16ea32}, @code{avr16ea48}, @code{avr16eb14}, @code{avr16eb20}, @code{avr16eb28}, @code{avr16eb32}, @code{avr16la14}, @code{avr16la20}, @code{avr16la28}, @code{avr16la32}, @code{avr32da28}, @code{avr32da28s}, @code{avr32da32}, @code{avr32da32s}, @code{avr32da48}, @code{avr32da48s}, @code{avr32db28}, @code{avr32db32}, @code{avr32db48}, @code{avr32dd14}, @code{avr32dd20}, @code{avr32dd28}, @code{avr32dd32}, @code{avr32du14}, @code{avr32du20}, @code{avr32du28}, @code{avr32du32}, @code{avr32ea28}, @code{avr32ea32}, @code{avr32ea48}, @code{avr32eb14}, @code{avr32eb20}, @code{avr32eb28}, @code{avr32eb32}, @code{avr32la14}, @code{avr32la20}, @code{avr32la28}, @code{avr32la32}, @code{avr32sd20}, @code{avr32sd28}, @code{avr32sd32}. @item @anchor{avrxmega4}avrxmega4 ``XMEGA'' devices with more than 64@tie{}KiB and up to 128@tie{}KiB of program memory. diff --git a/gcc/doc/extend.texi b/gcc/doc/extend.texi index b9d1a6aac75a..11f6b02db366 100644 --- a/gcc/doc/extend.texi +++ b/gcc/doc/extend.texi @@ -5015,8 +5015,6 @@ from the code model of the callee function. Like attribute @code{target}, these options also reflect the behavior of similar command line options. -Note that this attribute requires GLIBC2.38 and newer that support HWCAP. - @code{string} can take the following values: @itemize @bullet @@ -13567,6 +13565,7 @@ C and/or C++ standards, while others remain specific to GNU C. * Nested Functions:: Nested functions in GNU C. * Typeof:: @code{typeof}: referring to the type of an expression. * _Countof:: Determining the number of elements of arrays +* _Maxof and _Minof:: The maximum and minimum representable values of a type. * Offsetof:: Special syntax for @code{offsetof}. * Alignment:: Determining the alignment of a function, type or variable. * Enum Extensions:: Forward declarations and specifying the underlying type. @@ -14233,6 +14232,25 @@ _Countof (int [7][n++]); // integer constant expression _Countof (int [n++][7]); // run-time value; n++ is evaluated @end smallexample +@node _Maxof and _Minof +@subsection The maximum and minimum representable values of a type +@findex _Maxof +@findex _Minof + +The keywords @code{_Maxof} and @code{_Minof} determine +the maximum and minimum representable values of an integer type. +Their syntax is similar to @code{sizeof}. +The operand must be +a parenthesized integer type. +The result of these operators is an integer constant expression +of the same type as the operand. +For example: + +@smallexample +_Maxof (int); // returns '(int) INT_MAX' +_Minof (short); // returns '(short) SHRT_MIN' +@end smallexample + @node Offsetof @subsection Support for @code{offsetof} @findex __builtin_offsetof diff --git a/gcc/doc/install.texi b/gcc/doc/install.texi index 437e4636db33..df0711874b83 100644 --- a/gcc/doc/install.texi +++ b/gcc/doc/install.texi @@ -1687,10 +1687,10 @@ not use transactional memory. Specify which cpu variant the compiler should generate code for by default. @var{cpu} will be used as the default value of the @option{-mcpu=} switch. This option is only supported on some targets, including ARC, ARM, i386, M68k, -PowerPC, and SPARC@. It is mandatory for ARC@. The @option{--with-cpu-32} and -@option{--with-cpu-64} options specify separate default CPUs for -32-bit and 64-bit modes; these options are only supported for aarch64, i386, -x86-64, PowerPC, and SPARC@. +PowerPC, RISC-V, and SPARC@. It is mandatory for ARC@. The +@option{--with-cpu-32} and @option{--with-cpu-64} options specify separate +default CPUs for 32-bit and 64-bit modes; these options are only supported for +aarch64, i386, x86-64, PowerPC, and SPARC@. @item --with-schedule=@var{cpu} @itemx --with-arch=@var{cpu} @@ -2103,13 +2103,13 @@ their runtime libraries should be built. For a list of valid values for grep ^language= */config-lang.in @end smallexample Currently, you can use any of the following: -@code{all}, @code{default}, @code{ada}, @code{c}, @code{c++}, +@code{all}, @code{default}, @code{ada}, @code{algol68}, @code{c}, @code{c++}, @code{cobol}, @code{d}, @code{fortran}, @code{go}, @code{jit}, @code{lto}, @code{m2}, @code{objc}, @code{obj-c++}. Building the Ada compiler has special requirements, see below. If you do not pass this flag, or specify the option @code{default}, then the default languages available in the @file{gcc} sub-tree will be configured. -Ada, COBOL, D, Go, Jit, Objective-C++ and Modula-2 are not default languages. +Algol 68, Ada, COBOL, D, Go, Jit, Objective-C++ and Modula-2 are not default languages. LTO is not a default language, but is built by default because @option{--enable-lto} is enabled by default. The other languages are default languages. If @@ -2913,6 +2913,41 @@ In order to avoid shell and @command{make} quoting issues for complex overrides, you can pass a setting for @env{CONFIG_SITE} and set variables in the site file. +@subheading Algol 68-Specific Options + +The following options apply to the build of the Algol 68 runtime library. + +@table @code +@item --enable-algol68-gc +Specify that an additional variant of the GNU Algol 68 runtime library +is built, using an external build of the Boehm-Demers-Weiser garbage +collector (@uref{https://www.hboehm.info/gc/}). + +This library needs to be available for each multilib variant, unless +configured with @option{--enable-objc-gc=@samp{auto}} in which case +the build of the additional runtime library is skipped when not +available and the build continues. + +@item --with-target-bdw-gc=@var{list} +@itemx --with-target-bdw-gc-include=@var{list} +@itemx --with-target-bdw-gc-lib=@var{list} +Specify search directories for the garbage collector header files and +libraries. @var{list} is a comma separated list of key value pairs of the +form @samp{@var{multilibdir}=@var{path}}, where the default multilib key +is named as @samp{.} (dot), or is omitted (e.g.@: +@samp{--with-target-bdw-gc=/opt/bdw-gc,32=/opt-bdw-gc32}). + +The options @option{--with-target-bdw-gc-include} and +@option{--with-target-bdw-gc-lib} must always be specified together +for each multilib variant and they take precedence over +@option{--with-target-bdw-gc}. If @option{--with-target-bdw-gc-include} +is missing values for a multilib, then the value for the default +multilib is used (e.g.@: @samp{--with-target-bdw-gc-include=/opt/bdw-gc/include} +@samp{--with-target-bdw-gc-lib=/opt/bdw-gc/lib64,32=/opt-bdw-gc/lib32}). +If none of these options are specified, the library is assumed in +default locations. +@end table + @subheading Objective-C-Specific Options The following options apply to the build of the Objective-C runtime library. @@ -4084,16 +4119,17 @@ supported ISAs as multilib; use @code{--with-multilib-list=} to tailor the built multilibs. Note that mixing ISAs in the same binary is not supported and gives a linker error. -By default, multilib support is built for @code{gfx900}, @code{gfx906}, -@code{gfx908}, @code{gfx90a}, @code{gfx90c}, @code{gfx1030}, @code{gfx1036}, -@code{gfx1100} and @code{gfx1103}. The default multilib configuration -requires LLVM 15 or newer. LLVM 13.0.1 or LLVM 14 can be used by specifying -a @code{--with-multilib-list=} that does not list any GFX 11 device nor -@code{gfx1036}. At least LLVM 16 is required for @code{gfx1150} and -@code{gfx1151}, LLVM 18 for @code{gfx942}, LLVM 19 for the generic +By default, multilib support is built for @code{gfx908}, @code{gfx90a}, @code{gfx9-generic}, @code{gfx9-4-generic}, @code{gfx10-3-generic}, and -@code{gfx11-generic} targets and for @code{gfx1152}, while LLVM 20 is required -for @code{gfx950} and @code{gfx1153}. +@code{gfx11-generic}, which covers all supported archs. The default multilib +configuration requires LLVM 19 or newer. LLVM 13.0.1 or LLVM 14 can be used by +specifying a @code{--with-multilib-list=} that only lists GFX9 or GFX10-3 +devices, while LLVM 15 is required for GFX 11 device and @code{gfx1036}. +At least LLVM 16 is required for @code{gfx1150} and @code{gfx1151}, +LLVM 18 for @code{gfx942}, LLVM 19 for the generic @code{gfx9-generic}, +@code{gfx9-4-generic}, @code{gfx10-3-generic}, and @code{gfx11-generic} +targets and for @code{gfx1152}, while LLVM 20 is required for +@code{gfx950} and @code{gfx1153}. The supported ISA architectures are listed in the GCC manual. The generic ISA targets @code{gfx9-generic}, @code{gfx10-3-generic}, and diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index 06723c2b3b62..3be6635c70a3 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -215,7 +215,8 @@ in the following sections. @item C++ Language Options @xref{C++ Dialect Options,,Options Controlling C++ Dialect}. -@gccoptlist{-fabi-compat-version=@var{n} -fabi-version=@var{n} +@gccoptlist{--compile-std-module +-fabi-compat-version=@var{n} -fabi-version=@var{n} -fno-access-control -faligned-new=@r{[}@var{n}@r{]} -fno-assume-sane-operators-new-delete -fchar8_t -fcheck-new @@ -888,33 +889,37 @@ Objective-C and Objective-C++ Dialects}. -menable-sysreg-checking -mgeneral-regs-only -mcmodel=tiny -mcmodel=small -mcmodel=large --mstrict-align -mno-strict-align --momit-leaf-frame-pointer +-mstrict-align -momit-leaf-frame-pointer -mtls-dialect=desc -mtls-dialect=traditional --mtls-size=@var{size} +-mtls-size=@var{size} -mtp=@var{name} -mfix-cortex-a53-835769 -mfix-cortex-a53-843419 -mlow-precision-recip-sqrt -mlow-precision-sqrt -mlow-precision-div +-mmax-vectorization -mautovec-preference=@var{name} -mpc-relative-literal-loads -msign-return-address=@var{scope} -mbranch-protection=@var{features} -mharden-sls=@var{opts} -march=@var{name} -mcpu=@var{name} -mtune=@var{name} --moverride=@var{string} -mverbose-cost-dump --mstack-protector-guard=@var{guard} -mstack-protector-guard-reg=@var{sysreg} --mstack-protector-guard-offset=@var{offset} -mtrack-speculation --moutline-atomics -mearly-ldp-fusion -mlate-ldp-fusion --Wexperimental-fmv-target} +-moverride=@var{string} +-mstack-protector-guard=@var{guard} -mstack-protector-guard-reg=@var{sysreg} +-mstack-protector-guard-offset=@var{offset} -mtrack-speculation +-moutline-atomics -mearly-ra -mearly-ldp-fusion -mlate-ldp-fusion +-msve-vector-bits=@var{bits}} @emph{Adapteva Epiphany Options} (@ref{Adapteva Epiphany Options}) @gccoptlist{-mhalf-reg-file -mprefer-short-insn-regs -mbranch-cost=@var{num} -mcmove -mnops=@var{num} -msoft-cmpsf -msplit-lohi -mpost-inc -mpost-modify -mstack-offset=@var{num} -mround-nearest -mlong-calls -mshort-calls -msmall16 --mfp-mode=@var{mode} -mvect-double -max-vect-align=@var{num} +-mfp-mode=@var{mode} -mmay-round-for-trunc -mfp-iarith +-mvect-double -max-vect-align=@var{num} -msplit-vecmove-early -m1reg-@var{reg}} @emph{AMD GCN Options} (@ref{AMD GCN Options}) -@gccoptlist{-march=@var{gpu} -mtune=@var{gpu} -mstack-size=@var{bytes} +@gccoptlist{-march=@var{gpu} -mtune=@var{gpu} +-mgang-private-size=@var{bytes} +-msram-ecc=@r{[}on@r{|}off@r{|}any@r{]} +-mxnack=@r{[}on@r{|}off@r{|}any@r{]} -Wopenacc-dims} @emph{ARC Options} (@ref{ARC Options}) @@ -938,27 +943,22 @@ Objective-C and Objective-C++ Dialects}. -mdiv-rem -mcode-density -mll64 -mfpu=@var{fpu} -mrf16 -mbranch-index} @emph{ARM Options} (@ref{ARM Options}) -@gccoptlist{-mapcs-frame -mno-apcs-frame +@gccoptlist{-mapcs-frame -mapcs -mabi=@var{name} --mapcs-stack-check -mno-apcs-stack-check --mapcs-reentrant -mno-apcs-reentrant --mgeneral-regs-only --msched-prolog -mno-sched-prolog +-mgeneral-regs-only -mno-sched-prolog -mlittle-endian -mbig-endian -mbe8 -mbe32 -mfloat-abi=@var{name} -mfp16-format=@var{name} --mthumb-interwork -mno-thumb-interwork --mcpu=@var{name} -march=@var{name} -mfpu=@var{name} --mtune=@var{name} -mprint-tune-info +-mthumb-interwork +-mcpu=@var{name} -march=@var{name} -mfpu=@var{name} -mtune=@var{name} -mstructure-size-boundary=@var{n} --mabort-on-noreturn --mlong-calls -mno-long-calls --msingle-pic-base -mno-single-pic-base --mpic-register=@var{reg} +-mabort-on-noreturn -mlong-calls +-msingle-pic-base -mpic-register=@var{reg} +-mpic-data-is-text-relative -mnop-fun-dllimport -mpoke-function-name --mthumb -marm -mflip-thumb +-mthumb -marm -mtpcs-frame -mtpcs-leaf-frame -mcaller-super-interworking -mcallee-super-interworking -mtp=@var{name} -mtls-dialect=@var{dialect} @@ -967,15 +967,14 @@ Objective-C and Objective-C++ Dialects}. -mfix-cortex-a57-aes-1742098 -mfix-cortex-a72-aes-1655431 -munaligned-access --mneon-for-64bits -mslow-flash-data -masm-syntax-unified -mrestrict-it --mverbose-cost-dump -mpure-code -mcmse -mfix-cmse-cve-2021-35465 --mstack-protector-guard=@var{guard} -mstack-protector-guard-offset=@var{offset} +-mstack-protector-guard=@var{guard} +-mstack-protector-guard-offset=@var{offset} -mfdpic -mbranch-protection=@var{features}} @@ -992,18 +991,18 @@ Objective-C and Objective-C++ Dialects}. @emph{Blackfin Options} (@ref{Blackfin Options}) @gccoptlist{-mcpu=@var{cpu}@r{[}-@var{sirevision}@r{]} --msim -momit-leaf-frame-pointer -mno-omit-leaf-frame-pointer --mspecld-anomaly -mno-specld-anomaly -mcsync-anomaly -mno-csync-anomaly --mlow-64k -mno-low64k -mstack-check-l1 -mid-shared-library --mno-id-shared-library -mshared-library-id=@var{n} --mleaf-id-shared-library -mno-leaf-id-shared-library --msep-data -mno-sep-data -mlong-calls -mno-long-calls +-msim -momit-leaf-frame-pointer +-mspecld-anomaly -mcsync-anomaly +-mlow-64k -mstack-check-l1 -mid-shared-library +-mleaf-id-shared-library +-mshared-library-id=@var{n} +-msep-data -mlong-calls -mfast-fp -minline-plt -mmulticore -mcorea -mcoreb -msdram -micplb} @emph{C6X Options} (@ref{C6X Options}) @gccoptlist{-mbig-endian -mlittle-endian -march=@var{cpu} --msim -msdata=@var{sdata-type}} +-msim -msdata=@var{sdata-type} -mdsbt -mlong-calls} @emph{CRIS Options} (@ref{CRIS Options}) @gccoptlist{-mcpu=@var{cpu} -march=@var{cpu} @@ -1011,51 +1010,57 @@ Objective-C and Objective-C++ Dialects}. -metrax4 -metrax100 -mpdebug -mcc-init -mno-side-effects -mstack-align -mdata-align -mconst-align -m32-bit -m16-bit -m8-bit -mno-prologue-epilogue --melf -maout -sim -sim2 --mmul-bug-workaround -mno-mul-bug-workaround} +-mbest-lib-options -moverride-best-lib-options +-mtrap-using-break8 -mtrap-unaligned-atomic +-munaligned-atomic-may-use-library +-sim -sim2 +-mmul-bug-workaround} @emph{C-SKY Options} (@ref{C-SKY Options}) @gccoptlist{-march=@var{arch} -mcpu=@var{cpu} --mbig-endian -EB -mlittle-endian -EL --mhard-float -msoft-float -mfpu=@var{fpu} -mdouble-float -mfdivdu +-mbig-endian -mlittle-endian +-mfpu=@var{fpu} -mdouble-float -mfdivdu -mfloat-abi=@var{name} -melrw -mistack -mmp -mcp -mcache -msecurity -mtrust -mdsp -medsp -mvdsp -mdiv -msmart -mhigh-registers -manchor -mpushpop -mmultiple-stld -mconstpool -mstack-size -mccrt --mbranch-cost=@var{n} -mcse-cc -msched-prolog -msim} +-mbranch-cost=@var{n} -msched-prolog -msim} @emph{Cygwin and MinGW Options} (@ref{Cygwin and MinGW Options}) @gccoptlist{-mconsole -mcrtdll=@var{library} -mdll --mnop-fun-dllimport -mthread --municode -mwin32 -mwindows -fno-set-stack-executable} +-mnop-fun-dllimport -mthreads +-municode -mwin32 -mwindows -fno-set-stack-executable +-fwritable-relocated-rdata -mpe-aligned-commons} @emph{Darwin Options} (@ref{Darwin Options}) -@gccoptlist{-all_load -allowable_client -arch -arch_errors_fatal --arch_only -bind_at_load -bundle -bundle_loader +@gccoptlist{-all_load -allowable_client -arch @var{name} +-arch_errors_fatal -asm_macosx_version_min=@var{version} +-bind_at_load -bundle -bundle_loader -client_name -compatibility_version -current_version -dead_strip --dependency-file -dylib_file -dylinker_install_name +-dependency-file -dylib_file -dylinker -dylinker_install_name -dynamic -dynamiclib -exported_symbols_list --filelist -flat_namespace -force_cpusubtype_ALL --force_flat_namespace -headerpad_max_install_names --iframework --image_base -init -install_name -keep_private_externs --multi_module -multiply_defined -multiply_defined_unused --noall_load -no_dead_strip_inits_and_terms -nodefaultrpaths --nofixprebinding -nomultidefs -noprebind -noseglinkedit --pagezero_size -prebind -prebind_all_twolevel_modules --private_bundle -read_only_relocs -sectalign --sectobjectsymbols -whyload -seg1addr --sectcreate -sectobjectsymbols -sectorder --segaddr -segs_read_only_addr -segs_read_write_addr --seg_addr_table -seg_addr_table_filename -seglinkedit +-fapple-kext -fconstant-cfstrings -ffix-and-continue +-filelist -findirect-data -flat_namespace -force_cpusubtype_ALL +-force_flat_namespace -framework @var{name} -gfull -gused +-headerpad_max_install_names -iframework +-image_base -init @var{symbol-name} -install_name -keep_private_externs +-matt-stubs -mconstant-cfstrings -mdynamic-no-pic +-mfix-and-continue -mkernel -mmacosx-version-min=@var{version} +-mone-byte-bool -msymbol-stubs -mtarget-linker@r{[}=@r{]}@var{version} +-nodefaultexport -nodefaultrpaths +-pagezero_size -preload -read_only_relocs +-sectalign -sectcreate +-seg_addr_table +-seg1addr -segaddr -segprot -segs_read_only_addr -segs_read_write_addr --single_module -static -sub_library -sub_umbrella --twolevel_namespace -umbrella -undefined --unexported_symbols_list -weak_reference_mismatches --whatsloaded -F -gused -gfull -mmacosx-version-min=@var{version} --mkernel -mone-byte-bool} +-sub_library -sub_umbrella +-twolevel_namespace -twolevel_namespace_hints +-umbrella -undefined -unexported_symbols_list +-weak_framework @var{name} -weak_reference_mismatches +-whatsloaded -whyload +-F -ObjC -ObjC++ -Wnonportable-cfstrings} @emph{DEC Alpha Options} (@ref{DEC Alpha Options}) @gccoptlist{-mno-fp-regs -msoft-float @@ -1068,38 +1073,36 @@ Objective-C and Objective-C++ Dialects}. -mfloat-vax -mfloat-ieee -mexplicit-relocs -msmall-data -mlarge-data -msmall-text -mlarge-text --mmemory-latency=@var{time}} +-mmemory-latency=@var{time} +-mtls-kernel -mtls-size=@var{bitsize} +-mlong-double-128 -mlong-double-64} @emph{eBPF Options} (@ref{eBPF Options}) -@gccoptlist{-mbig-endian -mlittle-endian --mframe-limit=@var{bytes} -mxbpf -mco-re -mno-co-re -mjmpext --mjmp32 -malu32 -mv3-atomics -mbswap -msdiv -msmov -mcpu=@var{version} --masm=@var{dialect} -minline-memops-threshold=@var{bytes}} +@gccoptlist{-mbig-endian -mlittle-endian +-mframe-limit=@var{bytes} -mxbpf -mco-re -mjmpext -mjmp32 +-malu32 -mv3-atomics -mbswap -msdiv -msmov -mcpu=@var{version} +-masm=@var{dialect} -minline-memops-threshold=@var{bytes}} @emph{FR30 Options} (@ref{FR30 Options}) @gccoptlist{-msmall-model -mno-lsim} -@emph{FT32 Options} (@ref{FT32 Options}) -@gccoptlist{-msim -mlra -mnodiv -mft32b -mcompress -mnopm} - @emph{FRV Options} (@ref{FRV Options}) @gccoptlist{-mgpr-32 -mgpr-64 -mfpr-32 -mfpr-64 -mhard-float -msoft-float --malloc-cc -mfixed-cc -mdword -mno-dword --mdouble -mno-double --mmedia -mno-media -mmuladd -mno-muladd +-malloc-cc -mfixed-cc -mdword -mdouble -mmedia -mmuladd -mfdpic -minline-plt -mgprel-ro -multilib-library-pic -mlinked-fp -mlong-calls -malign-labels -mlibrary-pic -macc-4 -macc-8 --mpack -mno-pack -mno-eflags -mcond-move -mno-cond-move --moptimize-membar -mno-optimize-membar --mscc -mno-scc -mcond-exec -mno-cond-exec --mvliw-branch -mno-vliw-branch --mmulti-cond-exec -mno-multi-cond-exec -mnested-cond-exec --mno-nested-cond-exec -mtomcat-stats +-mpack -mno-eflags -mno-cond-move +-mno-optimize-membar -mno-scc -mno-cond-exec +-mno-vliw-branch -mno-multi-cond-exec -mno-nested-cond-exec +-mtomcat-stats -mTLS -mtls -mcpu=@var{cpu}} +@emph{FT32 Options} (@ref{FT32 Options}) +@gccoptlist{-msim -mnodiv -mft32b -mcompress -mnopm} + @emph{GNU/Linux Options} (@ref{GNU/Linux Options}) @gccoptlist{-mglibc -muclibc -mmusl -mbionic -mandroid -tno-android-cc -tno-android-ld} @@ -2627,21 +2630,21 @@ The name @samp{c++1z} is deprecated. @item gnu++17 @itemx gnu++1z GNU dialect of @option{-std=c++17}. -This is the default for C++ code. The name @samp{gnu++1z} is deprecated. @item c++20 @itemx c++2a The 2020 ISO C++ standard plus amendments. -Support is experimental, and could change in incompatible ways in -future releases. +C++20 modules support is still experimental and needs to be +enabled with @option{-fmodules} option. The name @samp{c++2a} is deprecated. @item gnu++20 @itemx gnu++2a GNU dialect of @option{-std=c++20}. -Support is experimental, and could change in incompatible ways in -future releases. +This is the default for C++ code. +C++20 modules support is still experimental and needs to be +enabled with @option{-fmodules} option. The name @samp{gnu++2a} is deprecated. @item c++23 @@ -3398,7 +3401,9 @@ called. If the handler returns, execution continues normally. @opindex fcoroutines @item -fcoroutines -Enable support for the C++ coroutines extension (experimental). +Enable support for the C++ coroutines extension. With @option{-std=c++20} +and above, coroutines are part of the language standard, so +@option{-fcoroutines} defaults to on. @opindex fdiagnostics-all-candidates @item -fdiagnostics-all-candidates @@ -22380,8 +22385,8 @@ platform. * DEC Alpha Options:: * eBPF Options:: * FR30 Options:: -* FT32 Options:: * FRV Options:: +* FT32 Options:: * GNU/Linux Options:: * H8/300 Options:: * HPPA Options:: @@ -22451,6 +22456,11 @@ The @samp{ilp32} model is deprecated. Generate big-endian code. This is the default when GCC is configured for an @samp{aarch64_be-*-*} target. +@opindex mlittle-endian +@item -mlittle-endian +Generate little-endian code. This is the default when GCC is configured for an +@samp{aarch64-*-*} but not an @samp{aarch64_be-*-*} target. + @opindex menable-sysreg-checking @item -menable-sysreg-checking Generates an error message if an attempt is made to access a system register @@ -22458,15 +22468,10 @@ which is not available on the target architecture. @opindex mgeneral-regs-only @item -mgeneral-regs-only -Generate code which uses only the general-purpose registers. This will prevent -the compiler from using floating-point and Advanced SIMD registers but will not +Generate code that uses only the general-purpose registers. This prevents +the compiler from using floating-point and Advanced SIMD registers but does not impose any restrictions on the assembler. -@opindex mlittle-endian -@item -mlittle-endian -Generate little-endian code. This is the default when GCC is configured for an -@samp{aarch64-*-*} but not an @samp{aarch64_be-*-*} target. - @opindex mcmodel= @opindex mcmodel=tiny @item -mcmodel=tiny @@ -22596,6 +22601,8 @@ This option only has an effect if @option{-ffast-math} or precision of division results to about 16 bits for single precision and to 32 bits for double precision. +@opindex mtrack-speculation +@opindex mno-track-speculation @item -mtrack-speculation @itemx -mno-track-speculation Enable or disable generation of additional code to track speculative @@ -22604,6 +22611,8 @@ be used by the compiler when expanding calls to @code{__builtin_speculation_safe_copy} to permit a more efficient code sequence to be generated. +@opindex moutline-atomics +@opindex mno-outline-atomics @item -moutline-atomics @itemx -mno-outline-atomics Enable or disable calls to out-of-line helpers to implement atomic operations. @@ -22618,6 +22627,8 @@ used directly. The same applies when using @option{-mcpu=} when the selected cpu supports the @samp{lse} feature. This option is on by default. +@opindex mmax-vectorization +@opindex mno-max-vectorization @item -mmax-vectorization @itemx -mno-max-vectorization Enable or disable an override to vectorizer cost model making vectorization @@ -22627,6 +22638,7 @@ used for auto-vectorization. Unlike @option{-fno-vect-cost-model} or @option{-fvect-cost-model=unlimited} this option does not turn off cost comparison between different vector modes. +@opindex mautovec-preference @item -mautovec-preference=@var{name} Force an ISA selection strategy for auto-vectorization. The possible values of @var{name} are: @@ -22794,11 +22806,6 @@ across releases. This option is only intended to be useful when developing GCC. -@opindex mverbose-cost-dump -@item -mverbose-cost-dump -Enable verbose cost model dumping in the debug dump files. This option is -provided for use in debugging the compiler. - @opindex mpc-relative-literal-loads @opindex mno-pc-relative-literal-loads @item -mpc-relative-literal-loads @@ -22815,7 +22822,7 @@ Permissible values are @samp{none}, which disables return address signing, @samp{non-leaf}, which enables pointer signing for functions which are not leaf functions, and @samp{all}, which enables pointer signing for all functions. The default value is @samp{none}. This option has been deprecated by --mbranch-protection. +@option{-mbranch-protection}. @opindex mbranch-protection @item -mbranch-protection=@var{features} @@ -22869,12 +22876,16 @@ disables the pass. @option{-Os}. @option{-mearly-ra=none} is the default otherwise. @opindex mearly-ldp-fusion +@opindex mno-early-ldp-fusion @item -mearly-ldp-fusion +@itemx -mno-early-ldp-fusion Enable the copy of the AArch64 load/store pair fusion pass that runs before register allocation. Enabled by default at @samp{-O} and above. @opindex mlate-ldp-fusion +@opindex mno-late-ldp-fusion @item -mlate-ldp-fusion +@itemx -mno-late-ldp-fusion Enable the copy of the AArch64 load/store pair fusion pass that runs after register allocation. Enabled by default at @samp{-O} and above. @@ -22900,10 +22911,6 @@ hardware SVE vector lengths. The default is @samp{-msve-vector-bits=scalable}, which produces vector-length agnostic code. -@opindex Wexperimental-fmv-target -@opindex Wno-experimental-fmv-target -@item -Wexperimental-fmv-target -This option is deprecated. @end table @subsubsection @option{-march} and @option{-mcpu} Feature Modifiers @@ -23121,12 +23128,16 @@ These @samp{-m} options are defined for Adapteva Epiphany: @table @gcctabopt @opindex mhalf-reg-file +@opindex mno-half-reg-file @item -mhalf-reg-file +@itemx -mno-half-reg-file Don't allocate any register in the range @code{r32}@dots{}@code{r63}. That allows code to run on hardware variants that lack these registers. @opindex mprefer-short-insn-regs +@opindex mno-prefer-short-insn-regs @item -mprefer-short-insn-regs +@itemx -mno-prefer-short-insn-regs Preferentially allocate registers that allow short instruction generation. This can result in increased instruction count, so this may either reduce or increase overall code size. @@ -23138,7 +23149,9 @@ This cost is only a heuristic and is not guaranteed to produce consistent results across releases. @opindex mcmove +@opindex mno-cmove @item -mcmove +@itemx -mno-cmove Enable the generation of conditional moves. @opindex mnops @@ -23148,6 +23161,7 @@ Emit @var{num} NOPs before every other generated instruction. @opindex mno-soft-cmpsf @opindex msoft-cmpsf @item -mno-soft-cmpsf +@itemx -msoft-cmpsf For single-precision floating-point comparisons, emit an @code{fsub} instruction and test the flags. This is faster than a software comparison, but can get incorrect results in the presence of NaNs, or when two different small @@ -23172,24 +23186,34 @@ toolchain with the appropriate @option{--with-stack-offset=@var{num}} option. @opindex mno-round-nearest @opindex mround-nearest @item -mno-round-nearest -Make the scheduler assume that the rounding mode has been set to +@itemx -mround-nearest +@option{-mno-round-nearest} +makes the scheduler assume that the rounding mode has been set to truncating. The default is @option{-mround-nearest}. @opindex mlong-calls +@opindex mno-long-calls @item -mlong-calls If not otherwise specified by an attribute, assume all calls might be beyond the offset range of the @code{b} / @code{bl} instructions, and therefore load the function address into a register before performing a (otherwise direct) call. This is the default. -@opindex short-calls +@opindex mshort-calls +@opindex mno-short-calls @item -mshort-calls If not otherwise specified by an attribute, assume all direct calls are in the range of the @code{b} / @code{bl} instructions, so use these instructions -for direct calls. The default is @option{-mlong-calls}. +for direct calls. + +The default is @option{-mlong-calls}. Note that @option{-mlong-calls} +is equivalent to @option{-mno-short-calls}, and similarly +@option{-mno-long-calls} is equivalent to @option{-mshort-calls}. @opindex msmall16 +@opindex mno-small16 @item -msmall16 +@itemx -mno-small16 Assume addresses can be loaded as 16-bit unsigned values. This does not apply to function addresses for which @option{-mlong-calls} semantics are in effect. @@ -23231,23 +23255,40 @@ integer multiply, or integer multiply-and-accumulate. The default is @option{-mfp-mode=caller} +@opindex mmay-round-for-trunc +@opindex mno-may-round-for-trunc +@item -mmay-round-for-trunc +@itemx -mno-may-round-for-trunc +This option allows floating point to integer truncation to be replaced +with rounding to save mode switching. It's disabled by default. + +@opindex mfp-iarith +@opindex mno-fp-iarith +@item -mfp-iarith +@itemx -mno-fp-iarith +This option enables use of the floating-point unit for integer add and +subtract. It's disabled by default. + @opindex mno-split-lohi @opindex msplit-lohi -@opindex mno-postinc -@opindex mpostinc +@opindex mno-post-inc +@opindex mpost-inc @opindex mno-postmodify -@opindex mpostmodify -@item -mno-split-lohi -@itemx -mno-postinc -@itemx -mno-postmodify -Code generation tweaks that disable, respectively, splitting of 32-bit +@opindex mpost-modify +@item -msplit-lohi +@itemx -mno-split-lohi +@itemx -mpost-inc +@itemx -mno-post-inc +@itemx -mpost-modify +@itemx -mno-post-modify +Code generation tweaks that control, respectively, splitting of 32-bit loads, generation of post-increment addresses, and generation of post-modify addresses. The defaults are @option{msplit-lohi}, @option{-mpost-inc}, and @option{-mpost-modify}. @opindex mno-vect-double @opindex mvect-double -@item -mnovect-double +@item -mno-vect-double Change the preferred SIMD mode to SImode. The default is @option{-mvect-double}, which uses DImode as preferred SIMD mode. @@ -23260,7 +23301,9 @@ interfaces are unaffected if they don't use SIMD vector modes in places that affect size and/or alignment of relevant types. @opindex msplit-vecmove-early +@opindex mno-split-vecmove-early @item -msplit-vecmove-early +@itemx -mno-split-vecmove-early Split vector moves into single word moves before reload. In theory this can give better register allocation, but so far the reverse seems to be generally the case. @@ -23384,6 +23427,11 @@ Compile generic code for GFX11 devices, executable on gfx1100, gfx1101, gfx1102, gfx1103, gfx1150, gfx1151, gfx1152, and gfx1153. @end table +@opindex mgang-private-size +@item -mgang-private-size=@var{bytes} +Set the amount of local data-share (LDS) memory to reserve for +gang-private variables. The default is 512. + @opindex msram-ecc @item -msram-ecc=on @itemx -msram-ecc=off @@ -23393,14 +23441,6 @@ disabled, or either mode. This feature can be enabled per-process on some devices. The compiled code must match the device mode. The default is @samp{any}, for devices that support it. -@opindex mstack-size -@item -mstack-size=@var{bytes} -Specify how many @var{bytes} of stack space will be requested for each GPU -thread (wave-front). Beware that there may be many threads and limited memory -available. The size of the stack allocation may also have an impact on -run-time performance. The default is 32KB when using OpenACC or OpenMP, and -1MB otherwise. - @opindex mxnack @item -mxnack=on @itemx -mxnack=off @@ -23414,7 +23454,8 @@ Memory, and @samp{-mxnack=no} otherwise. @opindex Wopenacc-dims @opindex Wno-openacc-dims @item -Wopenacc-dims -Warn about invalid OpenACC dimensions. +@itemx -Wno-openacc-dims +Control warnings about invalid OpenACC dimensions. @end table @@ -24217,6 +24258,7 @@ Generate code for the specified ABI@. Permissible values are: @samp{apcs-gnu}, @samp{atpcs}, @samp{aapcs} and @samp{aapcs-linux}. @opindex mapcs-frame +@opindex mno-apcs-frame @item -mapcs-frame Generate a stack frame that is compliant with the ARM Procedure Call Standard for all functions, even if this is not strictly necessary for @@ -24229,26 +24271,8 @@ This option is deprecated. @item -mapcs This is a synonym for @option{-mapcs-frame} and is deprecated. -@ignore -@c not currently implemented -@opindex mapcs-stack-check -@item -mapcs-stack-check -Generate code to check the amount of stack space available upon entry to -every function (that actually uses some stack space). If there is -insufficient space available then either the function -@code{__rt_stkovf_split_small} or @code{__rt_stkovf_split_big} is -called, depending upon the amount of stack space required. The runtime -system is required to provide these functions. The default is -@option{-mno-apcs-stack-check}, since this produces smaller code. - -@c not currently implemented -@opindex mapcs-reentrant -@item -mapcs-reentrant -Generate reentrant, position-independent code. The default is -@option{-mno-apcs-reentrant}. -@end ignore - @opindex mthumb-interwork +@opindex mno-thumb-interwork @item -mthumb-interwork Generate code that supports calling between the ARM and Thumb instruction sets. Without this option, on pre-v5 architectures, the @@ -24257,12 +24281,14 @@ default is @option{-mno-thumb-interwork}, since slightly larger code is generated when @option{-mthumb-interwork} is specified. In AAPCS configurations this option is meaningless. -@opindex mno-sched-prolog @opindex msched-prolog -@item -mno-sched-prolog -Prevent the reordering of instructions in the function prologue, or the +@opindex mno-sched-prolog +@item -msched-prolog +@itemx -mno-sched-prolog +Allow or prevent the reordering of instructions in the function prologue, or the merging of those instruction with the instructions in the function's -body. This means that all functions start with a recognizable set +body. With @option{-mno-sched-prolog}, +this means that all functions start with a recognizable set of instructions (or in fact one of a choice from a small set of different function prologues), and this information can be used to locate the start of functions inside an executable piece of code. The @@ -25026,6 +25052,7 @@ information using structures or unions. This option is deprecated. @opindex mabort-on-noreturn +@opindex mno-abort-on-noreturn @item -mabort-on-noreturn Generate a call to the function @code{abort} at the end of a @code{noreturn} function. It is executed if the function tries to @@ -25060,6 +25087,7 @@ the compiler generates code to handle function calls via function pointers. @opindex msingle-pic-base +@opindex mno-single-pic-base @item -msingle-pic-base Treat the register used for PIC addressing as read-only, rather than loading it in the prologue for each function. The runtime system is @@ -25075,6 +25103,7 @@ determined by compiler. For single PIC base case, the default is otherwise the default is @samp{R10}. @opindex mpic-data-is-text-relative +@opindex mno-pic-data-is-text-relative @item -mpic-data-is-text-relative Assume that the displacement between the text and data segments is fixed at static link time. This permits using PC-relative addressing @@ -25084,6 +25113,7 @@ disabled on such targets, it will enable @option{-msingle-pic-base} by default. @opindex mpoke-function-name +@opindex mno-poke-function-name @item -mpoke-function-name Write the name of each function into the text section, directly preceding the function prologue. The generated code is similar to this: @@ -25121,25 +25151,22 @@ You can also override the ARM and Thumb mode for each function by using the @code{target("thumb")} and @code{target("arm")} function attributes (@pxref{ARM Function Attributes}) or pragmas (@pxref{Function Specific Option Pragmas}). -@opindex mflip-thumb -@item -mflip-thumb -Switch ARM/Thumb modes on alternating functions. -This option is provided for regression testing of mixed Thumb/ARM code -generation, and is not intended for ordinary use in compiling code. - @opindex mtpcs-frame +@opindex mno-tpcs-frame @item -mtpcs-frame Generate a stack frame that is compliant with the Thumb Procedure Call Standard for all non-leaf functions. (A leaf function is one that does not call any other functions.) The default is @option{-mno-tpcs-frame}. @opindex mtpcs-leaf-frame +@opindex mno-tpcs-leaf-frame @item -mtpcs-leaf-frame Generate a stack frame that is compliant with the Thumb Procedure Call Standard for all leaf functions. (A leaf function is one that does not call any other functions.) The default is @option{-mno-apcs-leaf-frame}. @opindex mcallee-super-interworking +@opindex mno-callee-super-interworking @item -mcallee-super-interworking Gives all externally visible functions in the file being compiled an ARM instruction set header which switches to Thumb mode before executing the @@ -25148,6 +25175,7 @@ non-interworking code. This option is not valid in AAPCS configurations because interworking is enabled by default. @opindex mcaller-super-interworking +@opindex mno-caller-super-interworking @item -mcaller-super-interworking Allows calls via function pointers (including virtual functions) to execute correctly regardless of whether the target code has been @@ -25181,6 +25209,7 @@ library support. Initial and local exec TLS models are unaffected by this option and always use the original scheme. @opindex mword-relocations +@opindex mno-word-relocations @item -mword-relocations Only generate absolute relocations on word-sized values (i.e.@: R_ARM_ABS32). This is enabled by default on targets (uClinux, SymbianOS) where the runtime @@ -25188,6 +25217,7 @@ loader imposes this restriction, and when @option{-fpic} or @option{-fPIC} is specified. This option conflicts with @option{-mslow-flash-data}. @opindex mfix-cortex-m3-ldrd +@opindex mno-fix-cortex-m3-ldrd @item -mfix-cortex-m3-ldrd Some Cortex-M3 cores can cause data corruption when @code{ldrd} instructions with overlapping destination and base registers are used. This option avoids @@ -25220,11 +25250,8 @@ setting of this option. If unaligned access is enabled then the preprocessor symbol @code{__ARM_FEATURE_UNALIGNED} is also defined. -@opindex mneon-for-64bits -@item -mneon-for-64bits -This option is deprecated and has no effect. - @opindex mslow-flash-data +@opindex mno-slow-flash-data @item -mslow-flash-data Assume loading data from flash is slower than fetching instruction. Therefore literal load is minimized for better performance. @@ -25232,6 +25259,7 @@ This option is only supported when compiling for ARMv7 M-profile and off by default. It conflicts with @option{-mword-relocations}. @opindex masm-syntax-unified +@opindex mno-asm-syntax-unified @item -masm-syntax-unified Assume inline assembler is using unified asm syntax. The default is currently off which implies divided syntax. This option has no impact @@ -25239,24 +25267,14 @@ on Thumb2. However, this may change in future releases of GCC. Divided syntax should be considered deprecated. @opindex mrestrict-it +@opindex mno-restrict-it @item -mrestrict-it Restricts generation of IT blocks to conform to the rules of ARMv8-A. IT blocks can only contain a single 16-bit instruction from a select set of instructions. This option is on by default for ARMv8-A Thumb mode. -@opindex mprint-tune-info -@item -mprint-tune-info -Print CPU tuning information as comment in assembler file. This is -an option used only for regression testing of the compiler and not -intended for ordinary use in compiling code. This option is disabled -by default. - -@opindex mverbose-cost-dump -@item -mverbose-cost-dump -Enable verbose cost model dumping in the debug dump files. This option is -provided for use in debugging the compiler. - @opindex mpure-code +@opindex mno-pure-code @item -mpure-code Do not allow constant data to be placed in code sections. Additionally, when compiling for ELF object format give all text sections the @@ -25270,6 +25288,7 @@ Development Tools Engineering Specification", which can be found on @url{https://developer.arm.com/documentation/ecm0359818/latest/}. @opindex mfix-cmse-cve-2021-35465 +@opindex mno-fix-cmse-cve-2021-35465 @item -mfix-cmse-cve-2021-35465 Mitigate against a potential security issue with the @code{VLLDM} instruction in some M-profile devices when using CMSE (CVE-2021-365465). This option is @@ -26145,73 +26164,66 @@ Certain other options, such as @option{-mid-shared-library} and @option{-mfdpic}, imply @option{-msim}. @opindex momit-leaf-frame-pointer +@opindex mno-omit-leaf-frame-pointer @item -momit-leaf-frame-pointer Don't keep the frame pointer in a register for leaf functions. This avoids the instructions to save, set up and restore frame pointers and makes an extra register available in leaf functions. @opindex mspecld-anomaly +@opindex mno-specld-anomaly @item -mspecld-anomaly +@itemx -mno-specld-anomaly When enabled, the compiler ensures that the generated code does not contain speculative loads after jump instructions. If this option is used, @code{__WORKAROUND_SPECULATIVE_LOADS} is defined. -@opindex mno-specld-anomaly -@opindex mspecld-anomaly -@item -mno-specld-anomaly -Don't generate extra code to prevent speculative loads from occurring. - @opindex mcsync-anomaly +@opindex mno-csync-anomaly @item -mcsync-anomaly +@itemx -mno-csync-anomaly When enabled, the compiler ensures that the generated code does not contain CSYNC or SSYNC instructions too soon after conditional branches. If this option is used, @code{__WORKAROUND_SPECULATIVE_SYNCS} is defined. -@opindex mno-csync-anomaly -@opindex mcsync-anomaly -@item -mno-csync-anomaly -Don't generate extra code to prevent CSYNC or SSYNC instructions from -occurring too soon after a conditional branch. - @opindex mlow64k +@opindex mno-low64k @item -mlow64k +@itemx -mno-low64k When enabled, the compiler is free to take advantage of the knowledge that -the entire program fits into the low 64k of memory. - -@opindex mno-low64k -@item -mno-low64k -Assume that the program is arbitrarily large. This is the default. +the entire program fits into the low 64k of memory. The default behavior +is to assume that the program is arbitrarily large (@option{-mno-low64k}). @opindex mstack-check-l1 +@opindex mno-stack-check-l1 @item -mstack-check-l1 Do stack checking using information placed into L1 scratchpad memory by the uClinux kernel. @opindex mid-shared-library +@opindex mno-id-shared-library @item -mid-shared-library +@itemx -mno-id-shared-library Generate code that supports shared libraries via the library ID method. This allows for execute in place and shared libraries in an environment without virtual memory management. This option implies @option{-fPIC}. With a @samp{bfin-elf} target, this option implies @option{-msim}. - -@opindex mno-id-shared-library -@opindex mid-shared-library -@item -mno-id-shared-library -Generate code that doesn't assume ID-based shared libraries are being used. -This is the default. +The default is @option{-mno-id-shared-library}, to generate +code that doesn't assume ID-based shared libraries are being used. @opindex mleaf-id-shared-library +@opindex mno-leaf-id-shared-library @item -mleaf-id-shared-library +@itemx -mno-leaf-id-shared-library Generate code that supports shared libraries via the library ID method, but assumes that this library or executable won't link against any other ID shared libraries. That allows the compiler to use faster code for jumps and calls. -@opindex mno-leaf-id-shared-library -@opindex mleaf-id-shared-library -@item -mno-leaf-id-shared-library -Do not assume that the code being compiled won't link against any ID shared -libraries. Slower code is generated for jump and call insns. +The default is @option{-mno-leaf-id-shared-library}, in which the +no assumption is made that the code being compiled won't link +against any ID shared libraries. Slower code is generated for jump +and call insns. @opindex mshared-library-id @item -mshared-library-id=n @@ -26221,17 +26233,15 @@ other values forces the allocation of that number to the current library but is no more space- or time-efficient than omitting this option. @opindex msep-data +@opindex mno-sep-data @item -msep-data +@itemx -mno-sep-data Generate code that allows the data segment to be located in a different area of memory from the text segment. This allows for execute in place in an environment without virtual memory management by eliminating relocations -against the text section. - -@opindex mno-sep-data -@opindex msep-data -@item -mno-sep-data -Generate code that assumes that the data segment follows the text segment. -This is the default. +against the text section. The default is @option{-mno-sep-data}, which +tells GCC to generate code that assumes that the data segment follows +the text segment. @opindex mlong-calls @opindex mno-long-calls @@ -26249,17 +26259,20 @@ switches have no effect on how the compiler generates code to handle function calls via function pointers. @opindex mfast-fp +@opindex mno-fast-fp @item -mfast-fp Link with the fast floating-point library. This library relaxes some of the IEEE floating-point standard's rules for checking inputs against Not-a-Number (NAN), in the interest of performance. @opindex minline-plt +@opindex mno-inline-plt @item -minline-plt Enable inlining of PLT entries in function calls to functions that are not known to bind locally. It has no effect without @option{-mfdpic}. @opindex mmulticore +@opindex mno-multicore @item -mmulticore Build a standalone application for multicore Blackfin processors. This option causes proper start files and link scripts supporting @@ -26276,6 +26289,7 @@ If this option is not used, the single-core application programming model is used. @opindex mcorea +@opindex mno-corea @item -mcorea Build a standalone application for Core A of BF561 when using the one-application-per-core programming model. Proper start files @@ -26284,6 +26298,7 @@ and link scripts are used to support Core A, and the macro This option can only be used in conjunction with @option{-mmulticore}. @opindex mcoreb +@opindex mno-coreb @item -mcoreb Build a standalone application for Core B of BF561 when using the one-application-per-core programming model. Proper start files @@ -26293,6 +26308,7 @@ should be used instead of @code{main}. This option can only be used in conjunction with @option{-mmulticore}. @opindex msdram +@opindex mno-sdram @item -msdram Build a standalone application for SDRAM. Proper start files and link scripts are used to put the application into SDRAM, and the macro @@ -26300,6 +26316,7 @@ link scripts are used to put the application into SDRAM, and the macro The loader should initialize SDRAM before loading the application. @opindex micplb +@opindex mno-icplb @item -micplb Assume that ICPLBs are enabled at run time. This has an effect on certain anomaly workarounds. For Linux targets, the default is to assume ICPLBs @@ -26352,6 +26369,17 @@ addresses to access all data. Put all initialized global and static data in the @code{.fardata} section, and all uninitialized data in the @code{.far} section. Put all constant data into the @code{.const} section. + +@opindex mdsbt +@opindex mno-dsbt +@item -mdsbt +Compile for the DSBT shared library ABI. This option is required to +compile with @option{-fpic} or @option{-fPIC}, and implies @option{-fpic}. + +@opindex mlong-calls +@opindex mno-long-calls +@item -mlong-calls +Avoid generating PC-relative calls; use indirection instead. @end table @node CRIS Options @@ -26383,6 +26411,8 @@ Warn when the stack frame of a function exceeds @var{n} bytes. @opindex metrax4 @opindex metrax100 +@opindex mno-etrax4 +@opindex mno-etrax100 @item -metrax4 @itemx -metrax100 The options @option{-metrax4} and @option{-metrax100} are synonyms for @@ -26396,6 +26426,7 @@ Work around a bug in the @code{muls} and @code{mulu} instructions for CPU models where it applies. This option is disabled by default. @opindex mpdebug +@opindex mno-pddebug @item -mpdebug Enable CRIS-specific verbose debug-related information in the assembly code. This option also has the effect of turning off the @samp{#NO_APP} @@ -26403,6 +26434,7 @@ formatted-code indicator to the assembler at the beginning of the assembly file. @opindex mcc-init +@opindex mno-cc-init @item -mcc-init Do not use condition-code results from previous instruction; always emit compare and test instructions before use of condition codes. @@ -26452,9 +26484,32 @@ option only together with visual inspection of the compiled code: no warnings or errors are generated when call-saved registers must be saved, or storage for local variables needs to be allocated. -@opindex melf -@item -melf -Legacy no-op option. +@opindex mbest-lib-options +@opindex moverride-best-lib-options +@item -mbest-lib-options +@itemx -moverride-best-lib-options +@option{-mbest-lib-options} selects the most feature-enabling options +allowed by other options. This option has no @samp{no-} form, but +@option{-moverride-best-lib-options} disables it regardless of the relative +order of the two options on the command line. + +@opindex mtrap-using-break8 +@opindex mno-trap-using-break8 +@item -mtrap-using-break8 +Emit traps as @samp{break 8}. This is the default for CRIS v3 and up. If +disabled, calls to @code{abort} are used instead. + +@opindex mtrap-unaligned-atomic +@opindex mno-trap-unaligned-atomic +@item -mtrap-unaligned-atomic +Emit checks causing @samp{break 8} instructions to execute when +applying atomic builtins on misaligned memory. + +@opindex munaligned-atomic-may-use-library +@opindex mno-unaligned-atomic-may-use-library +@item -munaligned-atomic-may-use-library +Handle atomic builtins that may be applied to unaligned data by calling +library functions. This option overrides @option{-mtrap-unaligned-atomic}. @opindex sim @item -sim @@ -26503,13 +26558,9 @@ Specify the C-SKY target processor. Valid values for @var{cpu} are: @samp{ck810tv}, @samp{ck810ft}, and @samp{ck810ftv}. @opindex mbig-endian -@opindex EB @opindex mlittle-endian -@opindex EL @item -mbig-endian -@itemx -EB @itemx -mlittle-endian -@itemx -EL Select big- or little-endian code. The default is little-endian. @@ -26530,15 +26581,8 @@ the hard-float and soft-float ABIs are not link-compatible; you must compile your entire program with the same ABI, and link with a compatible set of libraries. -@opindex mhard-float -@opindex msoft-float -@item -mhard-float -@itemx -msoft-float - -Select hardware or software floating-point implementations. -The default is soft float. - @opindex mdouble-float +@opindex mno-double-float @item -mdouble-float @itemx -mno-double-float When @option{-mhard-float} is in effect, enable generation of @@ -26546,6 +26590,7 @@ double-precision float instructions. This is the default except when compiling for CK803. @opindex mfdivdu +@opindex mno-fdivdu @item -mfdivdu @itemx -mno-fdivdu When @option{-mhard-float} is in effect, enable generation of @@ -26562,12 +26607,14 @@ Values for @var{fpu} are @samp{fpv2_divd} (@samp{-mdouble-float -mdivdu}). @opindex melrw +@opindex mno-elrw @item -melrw @itemx -mno-elrw Enable the extended @code{lrw} instruction. This option defaults to on for CK801 and off otherwise. @opindex mistack +@opindex mno-istack @item -mistack @itemx -mno-istack Enable interrupt stack instructions; the default is off. @@ -26577,40 +26624,58 @@ The @option{-mistack} option is required to handle the (@pxref{C-SKY Function Attributes}). @opindex mmp +@opindex mno-mp @item -mmp +@itemx -mno-mp Enable multiprocessor instructions; the default is off. @opindex mcp +@opindex mno-cp @item -mcp +@itemx -mno-cp Enable coprocessor instructions; the default is off. @opindex mcache +@opindex mno-cache @item -mcache +@itemx -mno-cache Enable coprocessor instructions; the default is off. @opindex msecurity +@opindex mno-security @item -msecurity +@itemx -mno-security Enable C-SKY security instructions; the default is off. @opindex mtrust +@opindex mno-trust @item -mtrust +@itemx -mno-trust Enable C-SKY trust instructions; the default is off. @opindex mdsp +@opindex mno-dsp @opindex medsp +@opindex mno-edsp @opindex mvdsp +@opindex mno-vdsp @item -mdsp +@itemx -mno-dsp @itemx -medsp +@itemx -mno-edsp @itemx -mvdsp +@itemx -mno-vdsp Enable C-SKY DSP, Enhanced DSP, or Vector DSP instructions, respectively. All of these options default to off. @opindex mdiv +@opindex mno-div @item -mdiv @itemx -mno-div Generate divide instructions. Default is off. @opindex msmart +@opindex mno-smart @item -msmart @itemx -mno-smart Generate code for Smart Mode, using only registers numbered 0-7 to allow @@ -26619,6 +26684,7 @@ is the required behavior, and it defaults to on for CK802. For other targets, the default is off. @opindex mhigh-registers +@opindex mno-high-registers @item -mhigh-registers @itemx -mno-high-registers Generate code using the high registers numbered 16-31. This option @@ -26626,25 +26692,27 @@ is not supported on CK801, CK802, or CK803, and is enabled by default for other processors. @opindex manchor +@opindex mno-anchor @item -manchor @itemx -mno-anchor Generate code using global anchor symbol addresses. @opindex mpushpop +@opindex mno-pushpop @item -mpushpop @itemx -mno-pushpop Generate code using @code{push} and @code{pop} instructions. This option defaults to on. @opindex mmultiple-stld +@opindex mno-multiple-stld @item -mmultiple-stld -@itemx -mstm @itemx -mno-multiple-stld -@itemx -mno-stm Generate code using @code{stm} and @code{ldm} instructions. This option isn't supported on CK801 but is enabled by default on other processors. @opindex mconstpool +@opindex mno-constpool @item -mconstpool @itemx -mno-constpool Create constant pools in the compiler instead of deferring it to the @@ -26652,12 +26720,14 @@ assembler. This option is the default and required for correct code generation on CK801 and CK802, and is optional on other processors. @opindex mstack-size +@opindex mno-stack-size @item -mstack-size -@item -mno-stack-size +@itemx -mno-stack-size Emit @code{.stack_size} directives for each function in the assembly output. This option defaults to off. @opindex mccrt +@opindex mno-ccrt @item -mccrt @itemx -mno-ccrt Generate code for the C-SKY compiler runtime instead of libgcc. This @@ -26676,7 +26746,9 @@ prologue requirements and that cannot be debugged or backtraced. It is disabled by default. @opindex msim +@opindex mno-sim @item -msim +@itemx -mno-sim Links the library libsemi.a which is in compatible with simulator. Applicable to ELF compiler only. @@ -26730,6 +26802,7 @@ generated, enabling the selection of the required runtime startup object and entry point. @opindex mnop-fun-dllimport +@opindex mno-nop-fun-dllimport @item -mnop-fun-dllimport This option is available for Cygwin and MinGW targets. It specifies that the @code{dllimport} attribute should be ignored. @@ -26740,12 +26813,14 @@ This option is available for MinGW targets. It specifies that MinGW-specific thread support is to be used. @opindex municode +@opindex mno-unicode @item -municode This option is available for MinGW-w64 targets. It causes the @code{UNICODE} preprocessor macro to be predefined, and chooses Unicode-capable runtime startup code. @opindex mwin32 +@opindex mno-win32 @item -mwin32 This option is available for Cygwin and MinGW targets. It specifies that the typical Microsoft Windows predefined macros are to @@ -26753,6 +26828,7 @@ be set in the pre-processor, but does not influence the choice of runtime library/startup code. @opindex mwindows +@opindex mno-windows @item -mwindows This option is available for Cygwin and MinGW targets. It specifies that a GUI application is to be generated by @@ -26855,6 +26931,24 @@ directory. The main difference between this @option{-iframework} and warn about constructs contained within header files found via @var{dir}. This option is valid only for the C family of languages. +@opindex arch +@item -arch @var{name} +Generate output for architecture @var{name}. As described above, GCC +generates output for the architecture it was configured for, using its +usual options to select subarchitecture variants. The @option{-arch} +option is accepted for compatibility, but an error is diagnosed if +@var{name} is inconsistent with GCC's own idea of the target architecture. + +@opindex dependency-file +@item -dependency-file @var{filename} +Alias for the preprocessor option @option{-MF @var{filename}}. +@xref{Preprocessor Options}. + +@opindex fapple-kext +@opindex fno-apple-kext +@item -fapple-kext +Generate code for Darwin loadable kernel extensions. + @opindex gused @item -gused Emit debugging information for symbols that are used. For stabs @@ -26865,28 +26959,45 @@ This is by default ON@. @item -gfull Emit debugging information for all symbols and types. -@opindex fconstant-cfstrings -@item -fconstant-cfstrings -The @option{-fconstant-cfstrings} is an alias for @option{-mconstant-cfstrings}. +@opindex matt-stubs +@opindex mno-att-stubs +@item -matt-stubs +@itemx -mno-att-stubs +Enable AT&T-style PIC stubs. This is the default when supported by +the target architecture (currently x86 only). @opindex mconstant-cfstrings +@opindex mno-constant-cfstrings +@opindex fconstant-cfstrings @item -mconstant-cfstrings +@itemx -fconstant-cfstrings When the NeXT runtime is being used (the default on these systems), override any @option{-fconstant-string-class} setting and cause @code{@@"@dots{}"} literals to be laid out as constant CoreFoundation strings. -@opindex mmacosx-version-min -@item -mmacosx-version-min=@var{version} -The earliest version of MacOS X that this executable will run on is -@var{version}. Typical values supported for @var{version} include @code{12}, -@code{10.12}, and @code{10.5.8}. +@option{-fconstant-cfstrings} is an alias for @option{-mconstant-cfstrings}. -If the compiler was built to use the system's headers by default, -then the default for this option is the system version on which the -compiler is running, otherwise the default is to make choices that -are compatible with as many systems and code bases as possible. +@opindex mdynamic-no-pic +@opindex mno-dynamic-no-pic +@item -mdynamic-no-pic +Generate code suitable for executables (not shared libraries). This +option is incompatible with @option{-fpic}, @option{-fPIC}, @option{-fpie}, +or @option{-fPIE}. + +@opindex mfix-and-continue +@opindex mno-fix-and-continue +@opindex ffix-and-continue +@opindex findirect-data +@item -mfix-and-continue +@itemx -ffix-and-continue +@itemx -findirect-data +Generate code suitable for fast turnaround development, such as to +allow GDB to dynamically load @file{.o} files into already-running +programs. @option{-findirect-data} and @option{-ffix-and-continue} +are provided for backwards compatibility. @opindex mkernel +@opindex mno-kernel @item -mkernel Enable kernel development mode. The @option{-mkernel} option sets @option{-static}, @option{-fno-common}, @option{-fno-use-cxa-atexit}, @@ -26896,6 +27007,23 @@ applicable. This mode also sets @option{-mno-altivec}, @option{-msoft-float}, @option{-fno-builtin} and @option{-mlong-branch} for PowerPC targets. +@opindex mmacosx-version-min +@opindex asm_macosx_version_min +@item -mmacosx-version-min=@var{version} +@itemx -asm_macosx_version_min=@var{version} +The @option{-mmacosx-version-min} option specifies +the earliest version of MacOS X that this executable will run on is +@var{version}. Typical values supported for @var{version} include @code{12}, +@code{10.12}, and @code{10.5.8}. + +If the compiler was built to use the system's headers by default, +then the default for this option is the system version on which the +compiler is running, otherwise the default is to make choices that +are compatible with as many systems and code bases as possible. + +@option{-asm_macosx_version_min=@var{version}} is similar, but the GCC +driver passes its @var{version} information only to the assembler. + @opindex mone-byte-bool @item -mone-byte-bool Override the defaults for @code{bool} so that @code{sizeof(bool)==1}. @@ -26909,16 +27037,37 @@ without that switch. Using this switch may require recompiling all other modules in a program, including system libraries. Use this switch to conform to a non-default data model. -@opindex mfix-and-continue -@opindex ffix-and-continue -@opindex findirect-data -@item -mfix-and-continue -@itemx -ffix-and-continue -@itemx -findirect-data -Generate code suitable for fast turnaround development, such as to -allow GDB to dynamically load @file{.o} files into already-running -programs. @option{-findirect-data} and @option{-ffix-and-continue} -are provided for backwards compatibility. +@opindex msymbol-stubs +@opindex mno-symbol-stubs +@item -msymbol-stubs +@itemx -mno-symbol-stubs +Force generation of external symbol indirection stubs for PIC references. +By default, this option is enabled automatically if the target linker +version (@option{-mtarget-linker}) is old enough to require them. + +@opindex mtarget-linker +@item -mtarget-linker=@var{version} +@item -mtarget-linker @var{version} +Specify the target @command{ld64} version, overriding any version specified +in the GCC configuration. Newer linker versions support improved code +generation in some cases, for example for PIC code. + +@opindex ObjC +@item -ObjC +Equivalent to @samp{-x objective-c}; specifies that the input is +is Objective-C source code. + +@opindex ObjC++ +@item -ObjC++ +Equivalent to @samp{-x objective-c++}; specifies that the input is +is Objective-C++ source code. + +@opindex Wnonportable-cfstrings +@opindex Wno-nonportable-cfstrings +@item -Wnonportable-cfstrings +@itemx -Wno-nonportable-cfstrings +Warn if constant CoreFoundation string objects contain non-portable +characters. This warning is enabled by default. @opindex all_load @item -all_load @@ -26963,127 +27112,96 @@ the embedded runpath is added by default unless the user adds @option{-nodefaultrpaths} to the link line. Run paths are needed (and therefore enforced) to build on macOS version 10.11 or later. -@item -allowable_client @var{client_name} -@itemx -client_name -@itemx -compatibility_version -@itemx -current_version -@itemx -dead_strip -@itemx -dependency-file -@itemx -dylib_file -@itemx -dylinker_install_name -@itemx -dynamic -@itemx -exported_symbols_list -@itemx -filelist -@need 800 -@itemx -flat_namespace -@itemx -force_flat_namespace -@itemx -headerpad_max_install_names -@itemx -image_base -@itemx -init -@itemx -install_name -@itemx -keep_private_externs -@itemx -multi_module -@itemx -multiply_defined -@itemx -multiply_defined_unused -@need 800 -@itemx -noall_load -@itemx -no_dead_strip_inits_and_terms -@itemx -nofixprebinding -@itemx -nomultidefs -@itemx -noprebind -@itemx -noseglinkedit -@itemx -pagezero_size -@itemx -prebind -@itemx -prebind_all_twolevel_modules -@itemx -private_bundle -@need 800 -@itemx -read_only_relocs -@itemx -sectalign -@itemx -sectobjectsymbols -@itemx -whyload -@itemx -seg1addr -@itemx -sectcreate -@itemx -sectobjectsymbols -@itemx -sectorder -@itemx -segaddr -@itemx -segs_read_only_addr -@need 800 -@itemx -segs_read_write_addr -@itemx -seg_addr_table -@itemx -seg_addr_table_filename -@itemx -seglinkedit -@itemx -segprot -@itemx -segs_read_only_addr -@itemx -segs_read_write_addr -@itemx -single_module -@itemx -static -@itemx -sub_library -@need 800 +@opindex nodefaultexport +@item -nodefaultexport +Do not add default symbol exports to modules or dynamic libraries. + @opindex allowable_client @opindex client_name @opindex compatibility_version @opindex current_version @opindex dead_strip -@opindex dependency-file @opindex dylib_file +@opindex dylinker @opindex dylinker_install_name @opindex dynamic @opindex exported_symbols_list @opindex filelist @opindex flat_namespace @opindex force_flat_namespace +@opindex framework @opindex headerpad_max_install_names @opindex image_base @opindex init @opindex install_name @opindex keep_private_externs -@opindex multi_module -@opindex multiply_defined -@opindex multiply_defined_unused -@opindex noall_load -@opindex no_dead_strip_inits_and_terms -@opindex nofixprebinding -@opindex nomultidefs -@opindex noprebind -@opindex noseglinkedit @opindex pagezero_size -@opindex prebind -@opindex prebind_all_twolevel_modules -@opindex private_bundle @opindex read_only_relocs @opindex sectalign -@opindex sectobjectsymbols -@opindex whyload -@opindex seg1addr @opindex sectcreate -@opindex sectobjectsymbols -@opindex sectorder -@opindex segaddr -@opindex segs_read_only_addr -@opindex segs_read_write_addr @opindex seg_addr_table -@opindex seg_addr_table_filename -@opindex seglinkedit +@opindex seg1addr +@opindex segaddr @opindex segprot @opindex segs_read_only_addr @opindex segs_read_write_addr -@opindex single_module -@opindex static @opindex sub_library @opindex sub_umbrella @opindex twolevel_namespace +@opindex twolevel_namespace_hints @opindex umbrella @opindex undefined @opindex unexported_symbols_list +@opindex weak_framework @opindex weak_reference_mismatches @opindex whatsloaded +@opindex whyload +@item -allowable_client @var{client_name} +@itemx -client_name +@itemx -compatibility_version +@itemx -current_version +@itemx -dead_strip +@itemx -dylib_file +@itemx -dylinker +@itemx -dylinker_install_name +@itemx -dynamic +@itemx -exported_symbols_list +@itemx -filelist +@need 800 +@itemx -flat_namespace +@itemx -force_flat_namespace +@itemx -framework +@itemx -headerpad_max_install_names +@itemx -image_base +@itemx -init @var{symbol-name} +@itemx -install_name +@itemx -keep_private_externs +@need 800 +@itemx -pagezero_size +@itemx -preload +@need 800 +@itemx -read_only_relocs +@itemx -sectalign +@itemx -sectcreate +@itemx -seg_addr_table +@itemx -seg1addr +@itemx -segaddr +@need 800 +@itemx -segprot +@itemx -segs_read_only_addr +@itemx -segs_read_write_addr +@itemx -sub_library +@need 800 @itemx -sub_umbrella @itemx -twolevel_namespace +@itemx -twolevel_namespace_hints @itemx -umbrella @itemx -undefined @itemx -unexported_symbols_list +@itemx -weak_framework @itemx -weak_reference_mismatches @itemx -whatsloaded +@itemx -whyload These options are passed to the Darwin linker. The Darwin linker man page describes them in detail. @end table @@ -27420,6 +27538,24 @@ The compiler contains estimates of the number of clock cycles for Note that L3 is only valid for EV5. @end table + +@opindex mtls-kernel +@opindex mno-tls-kernel +@item -mtls-kernel +Emit @code{rdval} instead of @code{rduniq} for thread pointer. + +@opindex mtls-size +@item -mtls-size=@var{bitsize} +Specify bit size of immediate TLS offsets. Valid values for @var{bitsize} +are 16, 32, and 64; it defaults to 32. + +@opindex mlong-double-128 +@opindex mlong-double-64 +@item -mlong-double-128 +@itemx -mlong-double-64 +Specify the size of the @code{long double} type. Note that +@option{-mlong-double-128} is incompatible with VAX floating point. + @end table @node eBPF Options @@ -27442,41 +27578,48 @@ Generate code for a big-endian target. Generate code for a little-endian target. This is the default. @opindex mjmpext +@opindex mno-jmpext @item -mjmpext @itemx -mno-jmpext Enable or disable generation of extra conditional-branch instructions. Enabled for CPU v2 and above. @opindex mjmp32 +@opindex mno-jmp32 @item -mjmp32 @itemx -mno-jmp32 Enable or disable generation of 32-bit jump instructions. Enabled for CPU v3 and above. @opindex malu32 +@opindex mno-alu32 @item -malu32 @itemx -mno-alu32 Enable or disable generation of 32-bit ALU instructions. Enabled for CPU v3 and above. @opindex mv3-atomics +@opindex mno-v3-atomics @item -mv3-atomics @itemx -mno-v3-atomics Enable or disable instructions for general atomic operations introduced in CPU v3. Enabled for CPU v3 and above. @opindex mbswap +@opindex mno-bswap @item -mbswap @itemx -mno-bswap Enable or disable byte swap instructions. Enabled for CPU v4 and above. @opindex msdiv +@opindex mno-sdiv @item -msdiv @itemx -mno-sdiv Enable or disable signed division and modulus instructions. Enabled for CPU v4 and above. @opindex msmov +@opindex mno-smov @item -msmov @itemx -mno-smov Enable or disable sign-extending move and memory load instructions. @@ -27514,16 +27657,15 @@ All features of v3, plus: @end table @opindex mco-re -@item -mco-re -Enable BPF Compile Once - Run Everywhere (CO-RE) support. Requires and -is implied by @option{-gbtf}. - @opindex mno-co-re -@item -mno-co-re -Disable BPF Compile Once - Run Everywhere (CO-RE) support. BPF CO-RE -support is enabled by default when generating BTF debug information for -the BPF target. +@item -mco-re +@itemx -mno-co-re +Enable or disable BPF Compile Once - Run Everywhere (CO-RE) support. +BPF CO-RE support is enabled by default when generating BTF debug +information for the BPF target (@option{-gbtf}). +@opindex mxbpf +@opindex mno-xbpf @item -mxbpf Generate code for an expanded version of BPF, which relaxes some of the restrictions imposed by the BPF architecture: @@ -27568,6 +27710,7 @@ These options are defined specifically for the FR30 port. @table @gcctabopt @opindex msmall-model +@opindex mno-small-model @item -msmall-model Use the small address space model. This can produce smaller code, but it does assume that all symbolic values and addresses fit into a @@ -27581,44 +27724,6 @@ command line. @end table -@node FT32 Options -@subsection FT32 Options -@cindex FT32 Options - -These options are defined specifically for the FT32 port. - -@table @gcctabopt - -@opindex msim -@item -msim -Specifies that the program will be run on the simulator. This causes -an alternate runtime startup and library to be linked. -You must not use this option when generating programs that will run on -real hardware; you must provide your own runtime library for whatever -I/O functions are needed. - -@opindex mlra -@item -mlra -Does nothing. Preserved for backward compatibility. - -@opindex mnodiv -@item -mnodiv -Do not use div and mod instructions. - -@opindex mft32b -@item -mft32b -Enable use of the extended instructions of the FT32B processor. - -@opindex mcompress -@item -mcompress -Compress all code using the Ft32B code compression scheme. - -@opindex mnopm -@item -mnopm -Do not generate code that reads program memory. - -@end table - @node FRV Options @subsection FRV Options @cindex FRV Options @@ -27666,47 +27771,35 @@ Do not try to dynamically allocate condition code registers, only use @code{icc0} and @code{fcc0}. @opindex mdword -@item -mdword - -Change ABI to use double word insns. - @opindex mno-dword -@opindex mdword -@item -mno-dword +@item -mdword +@itemx -mno-dword -Do not use double word instructions. +Control whether the ABI uses double-word instructions. @opindex mdouble -@item -mdouble - -Use floating-point double instructions. - @opindex mno-double -@item -mno-double +@item -mdouble +@itemx -mno-double -Do not use floating-point double instructions. +Enable or disable use of floating-point double instructions. @opindex mmedia -@item -mmedia - -Use media instructions. - @opindex mno-media -@item -mno-media +@item -mmedia +@itemx -mno-media -Do not use media instructions. +Enable or disable use of media instructions. @opindex mmuladd -@item -mmuladd - -Use multiply and add/subtract instructions. - @opindex mno-muladd -@item -mno-muladd +@item -mmuladd +@itemx -mno-muladd -Do not use multiply and add/subtract instructions. +Enable or disable use of multiply and add/subtract instructions. @opindex mfdpic +@opindex mno-fdpic @item -mfdpic Select the FDPIC ABI, which uses function descriptors to represent @@ -27718,6 +27811,7 @@ are computed with 32 bits. With a @samp{bfin-elf} target, this option implies @option{-msim}. @opindex minline-plt +@opindex mno-inline-plt @item -minline-plt Enable inlining of PLT entries in function calls to functions that are @@ -27738,6 +27832,7 @@ Assume a large TLS segment when generating thread-local code. Do not assume a large TLS segment when generating thread-local code. @opindex mgprel-ro +@opindex mno-gprel-ro @item -mgprel-ro Enable the use of @code{GPREL} relocations in the FDPIC ABI for data @@ -27758,6 +27853,7 @@ Link with the (library, not FD) pic libraries. It's implied by it explicitly. @opindex mlinked-fp +@opindex mno-linked-fp @item -mlinked-fp Follow the EABI requirement of always creating a frame pointer whenever @@ -27765,6 +27861,7 @@ a stack frame is allocated. This option is enabled by default and can be disabled with @option{-mno-linked-fp}. @opindex mlong-calls +@opindex mno-long-calls @item -mlong-calls Use indirect addressing to call functions outside the current @@ -27772,6 +27869,7 @@ compilation unit. This allows the functions to be placed anywhere within the 32-bit address space. @opindex malign-labels +@opindex mno-align-labels @item -malign-labels Try to align labels to an 8-byte boundary by inserting NOPs into the @@ -27780,6 +27878,7 @@ is enabled. It doesn't create new packets; it merely adds NOPs to existing ones. @opindex mlibrary-pic +@opindex mno-library-pic @item -mlibrary-pic Generate position-independent EABI code. @@ -27795,14 +27894,11 @@ Use only the first four media accumulator registers. Use all eight media accumulator registers. @opindex mpack -@item -mpack - -Pack VLIW instructions. - @opindex mno-pack +@item -mpack @item -mno-pack -Do not pack VLIW instructions. +Enable or disable packing VLIW instructions. @opindex mno-eflags @item -mno-eflags @@ -27810,116 +27906,80 @@ Do not pack VLIW instructions. Do not mark ABI switches in e_flags. @opindex mcond-move -@item -mcond-move - -Enable the use of conditional-move instructions (default). - -This switch is mainly for debugging the compiler and will likely be removed -in a future version. - @opindex mno-cond-move -@item -mno-cond-move +@item -mcond-move +@itemx -mno-cond-move -Disable the use of conditional-move instructions. +Enable or disable the use of conditional-move instructions; it is enabled +by default. This switch is mainly for debugging the compiler and will likely be removed in a future version. @opindex mscc -@item -mscc - -Enable the use of conditional set instructions (default). - -This switch is mainly for debugging the compiler and will likely be removed -in a future version. - @opindex mno-scc -@item -mno-scc +@item -mscc +@itemx -mno-scc -Disable the use of conditional set instructions. +Enable or disable the use of conditional set instructions; it is enabled +by default. This switch is mainly for debugging the compiler and will likely be removed in a future version. @opindex mcond-exec -@item -mcond-exec - -Enable the use of conditional execution (default). - -This switch is mainly for debugging the compiler and will likely be removed -in a future version. - @opindex mno-cond-exec -@item -mno-cond-exec +@item -mcond-exec +@itemx -mno-cond-exec -Disable the use of conditional execution. +Enable or disable the use of conditional execution; it is enabled by default. This switch is mainly for debugging the compiler and will likely be removed in a future version. @opindex mvliw-branch -@item -mvliw-branch - -Run a pass to pack branches into VLIW instructions (default). - -This switch is mainly for debugging the compiler and will likely be removed -in a future version. - @opindex mno-vliw-branch -@item -mno-vliw-branch +@item -mvliw-branch +@itemx -mno-vliw-branch -Do not run a pass to pack branches into VLIW instructions. +Enable or disable an optimization pass to pack branches into VLIW instructions; +it is enabled by default. This switch is mainly for debugging the compiler and will likely be removed in a future version. @opindex mmulti-cond-exec -@item -mmulti-cond-exec - -Enable optimization of @code{&&} and @code{||} in conditional execution -(default). - -This switch is mainly for debugging the compiler and will likely be removed -in a future version. - @opindex mno-multi-cond-exec -@item -mno-multi-cond-exec +@item -mmulti-cond-exec +@itemx -mno-multi-cond-exec -Disable optimization of @code{&&} and @code{||} in conditional execution. +Enable or disable optimization of @code{&&} and @code{||} in conditional +execution; it is enabled by default. This switch is mainly for debugging the compiler and will likely be removed in a future version. @opindex mnested-cond-exec -@item -mnested-cond-exec - -Enable nested conditional execution optimizations (default). - -This switch is mainly for debugging the compiler and will likely be removed -in a future version. - @opindex mno-nested-cond-exec -@item -mno-nested-cond-exec +@item -mnested-cond-exec +@itemx -mno-nested-cond-exec -Disable nested conditional execution optimizations. +Enable or disable nested conditional execution optimizations; it is enabled +by default. This switch is mainly for debugging the compiler and will likely be removed in a future version. @opindex moptimize-membar +@opindex mno-optimize-membar @item -moptimize-membar +@itemx -mno-optimize-membar This switch removes redundant @code{membar} instructions from the compiler-generated code. It is enabled by default. -@opindex mno-optimize-membar -@opindex moptimize-membar -@item -mno-optimize-membar - -This switch disables the automatic removal of redundant @code{membar} -instructions from the generated code. - @opindex mtomcat-stats +@opindex mno-tomcat-stats @item -mtomcat-stats Cause gas to print out tomcat statistics. @@ -27933,6 +27993,45 @@ Select the processor type for which to generate code. Possible values are @end table +@node FT32 Options +@subsection FT32 Options +@cindex FT32 Options + +These options are defined specifically for the FT32 port. + +@table @gcctabopt + +@opindex msim +@opindex mno-sim +@item -msim +Specifies that the program will be run on the simulator. This causes +an alternate runtime startup and library to be linked. +You must not use this option when generating programs that will run on +real hardware; you must provide your own runtime library for whatever +I/O functions are needed. + +@opindex mnodiv +@opindex mno-nodiv +@item -mnodiv +Do not use div and mod instructions. + +@opindex mft32b +@opindex mno-ft32b +@item -mft32b +Enable use of the extended instructions of the FT32B processor. + +@opindex mcompress +@opindex mno-compress +@item -mcompress +Compress all code using the Ft32B code compression scheme. + +@opindex mnopm +@opindex mno-nopm +@item -mnopm +Do not generate code that reads program memory. + +@end table + @node GNU/Linux Options @subsection GNU/Linux Options @@ -27961,7 +28060,9 @@ Use Bionic C library. This is the default on @samp{*-*-linux-*android*} targets. @opindex mandroid +@opindex mno-android @item -mandroid +@itemx -mno-android Compile code compatible with Android platform. This is the default on @samp{*-*-linux-*android*} targets. @@ -27971,6 +28072,8 @@ this option makes the GCC driver pass Android-specific options to the linker. Finally, this option causes the preprocessor macro @code{__ANDROID__} to be defined. +This option can be disabled completely with @option{-mno-android}. + @opindex tno-android-cc @item -tno-android-cc Disable compilation effects of @option{-mandroid}, i.e., do not enable diff --git a/gcc/doc/riscv-ext.texi b/gcc/doc/riscv-ext.texi index 13056e73bad9..0dc667b561ca 100644 --- a/gcc/doc/riscv-ext.texi +++ b/gcc/doc/riscv-ext.texi @@ -746,4 +746,8 @@ @tab 5.0 @tab Andes vector dot product extension +@item xsmtvdot +@tab 1.0 +@tab SpacemiT vector dot product extension + @end multitable diff --git a/gcc/doc/riscv-mcpu.texi b/gcc/doc/riscv-mcpu.texi index 8fcba597ad19..eaf96933b107 100644 --- a/gcc/doc/riscv-mcpu.texi +++ b/gcc/doc/riscv-mcpu.texi @@ -82,4 +82,16 @@ by particular CPU name. Permissible values for this option are: @samp{andes-ax27}, +@samp{andes-n225}, + +@samp{andes-d23}, + +@samp{andes-n45}, + +@samp{andes-nx45}, + +@samp{andes-a45}, + +@samp{andes-ax45}, + @samp{spacemit-x60}. diff --git a/gcc/doc/riscv-mtune.texi b/gcc/doc/riscv-mtune.texi index 02fcd342384a..3e61d11462a9 100644 --- a/gcc/doc/riscv-mtune.texi +++ b/gcc/doc/riscv-mtune.texi @@ -60,4 +60,8 @@ particular CPU name. Permissible values for this option are: @samp{andes-25-series}, +@samp{andes-23-series}, + +@samp{andes-45-series}, + and all valid options for @option{-mcpu=}. diff --git a/gcc/doc/sourcebuild.texi b/gcc/doc/sourcebuild.texi index ef3736125b04..49460649f973 100644 --- a/gcc/doc/sourcebuild.texi +++ b/gcc/doc/sourcebuild.texi @@ -91,6 +91,9 @@ The Decimal Float support library. @item libffi The @code{libffi} library, used as part of the Go runtime library. +@item libga68 +The Algol 68 runtime library. + @item libgcc The GCC runtime library. diff --git a/gcc/doc/standards.texi b/gcc/doc/standards.texi index c7c6f28ee218..2c2063a750a9 100644 --- a/gcc/doc/standards.texi +++ b/gcc/doc/standards.texi @@ -289,7 +289,7 @@ select an extended version of the C++ language explicitly with @option{-std=gnu++23} (for C++23 with GNU extensions). The default, if -no C++ language dialect options are given, is @option{-std=gnu++17}. +no C++ language dialect options are given, is @option{-std=gnu++20}. @section Objective-C and Objective-C++ Languages @cindex Objective-C diff --git a/gcc/dwarf2out.cc b/gcc/dwarf2out.cc index 9251bcf6cbb9..16f9b855a993 100644 --- a/gcc/dwarf2out.cc +++ b/gcc/dwarf2out.cc @@ -25821,6 +25821,14 @@ gen_compile_unit_die (const char *filename) else if (strcmp (language_string, "GNU Rust") == 0) language = DW_LANG_Rust; } + else if (!dwarf_strict) + { + if (strcmp (language_string, "GNU Algol 68") == 0) + { + language = DW_LANG_Algol68; + lname = DW_LNAME_Algol68; + } + } } /* Use a degraded Fortran setting in strict DWARF2 so is_fortran works. */ else if (startswith (language_string, "GNU Fortran")) diff --git a/gcc/fold-const.cc b/gcc/fold-const.cc index 85e7da595c6a..535377737f3e 100644 --- a/gcc/fold-const.cc +++ b/gcc/fold-const.cc @@ -10938,10 +10938,12 @@ tree_expr_nonzero_p (tree t) return ret; } -/* Return true if T is known not to be equal to an integer W. */ +/* Return true if T is known not to be equal to an integer W. + If STMT is specified, the check is if T on STMT is not equal + to W. */ bool -expr_not_equal_to (tree t, const wide_int &w) +expr_not_equal_to (tree t, const wide_int &w, gimple *stmt /* = NULL */) { int_range_max vr; switch (TREE_CODE (t)) @@ -10953,7 +10955,7 @@ expr_not_equal_to (tree t, const wide_int &w) if (!INTEGRAL_TYPE_P (TREE_TYPE (t))) return false; - get_range_query (cfun)->range_of_expr (vr, t); + get_range_query (cfun)->range_of_expr (vr, t, stmt); if (!vr.undefined_p () && !vr.contains_p (w)) return true; /* If T has some known zero bits and W has any of those bits set, diff --git a/gcc/fold-const.h b/gcc/fold-const.h index 149992d1f107..c80dbcff32f7 100644 --- a/gcc/fold-const.h +++ b/gcc/fold-const.h @@ -223,7 +223,7 @@ extern bool merge_ranges (int *, tree *, tree *, int, tree, tree, int, extern tree sign_bit_p (tree, const_tree); extern bool simple_condition_p (tree); extern tree exact_inverse (tree, tree); -extern bool expr_not_equal_to (tree t, const wide_int &); +extern bool expr_not_equal_to (tree t, const wide_int &, gimple * = NULL); extern tree const_unop (enum tree_code, tree, tree); extern tree vector_const_binop (enum tree_code, tree, tree, tree (*) (enum tree_code, tree, tree)); diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3d6ed745e4cd..bcb008e4ab45 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,71 @@ +2025-11-30 Andrew Pinski + + * lang.opt.urls: Regenerate. + +2025-11-28 Tobias Burnus + + PR c/122892 + * openmp.cc (gfc_resolve_omp_allocate): Reject non-local + static variables with cgroup/pteam/thread allocators. + * parse.cc: Permit OMP ALLOCATE in BLOCK DATA. + +2025-11-26 Tobias Burnus + + * dump-parse-tree.cc (show_attr): Handle OpenMP's 'local' clause + and the 'groupprivate' directive. + (show_omp_clauses): Handle dyn_groupprivate. + * frontend-passes.cc (gfc_code_walker): Walk dyn_groupprivate. + * gfortran.h (enum gfc_statement): Add ST_OMP_GROUPPRIVATE. + (enum gfc_omp_fallback, gfc_add_omp_groupprivate, + gfc_add_omp_declare_target_local): New. + * match.h (gfc_match_omp_groupprivate): New. + * module.cc (enum ab_attribute, mio_symbol_attribute, load_commons, + write_common_0): Handle 'groupprivate' + declare target's 'local'. + * openmp.cc (gfc_omp_directives): Add 'groupprivate'. + (gfc_free_omp_clauses): Free dyn_groupprivate. + (enum omp_mask2): Add OMP_CLAUSE_LOCAL and OMP_CLAUSE_DYN_GROUPPRIVATE. + (gfc_match_omp_clauses): Match them. + (OMP_TARGET_CLAUSES): Add OMP_CLAUSE_DYN_GROUPPRIVATE. + (OMP_DECLARE_TARGET_CLAUSES): Add OMP_CLAUSE_LOCAL. + (gfc_match_omp_declare_target): Handle groupprivate + fixes. + (gfc_match_omp_threadprivate): Code move to and calling now ... + (gfc_match_omp_thread_group_private): ... this new function. + Also handle groupprivate. + (gfc_match_omp_groupprivate): New. + (resolve_omp_clauses): Resolve dyn_groupprivate. + * parse.cc (decode_omp_directive): Match groupprivate. + (case_omp_decl, parse_spec, gfc_ascii_statement): Handle it. + * resolve.cc (resolve_symbol): Handle groupprivate. + * symbol.cc (gfc_check_conflict, gfc_copy_attr): Handle 'local' + and 'groupprivate'. + (gfc_add_omp_groupprivate, gfc_add_omp_declare_target_local): New. + * trans-common.cc (build_common_decl, + accumulate_equivalence_attributes): Print 'sorry' for + groupprivate and declare target's local. + * trans-decl.cc (add_attributes_to_decl): Likewise.. + * trans-openmp.cc (gfc_trans_omp_clauses): Print 'sorry' for + dyn_groupprivate. + (fallback): Process declare target with link/local as + done for 'enter'. + +2025-11-26 Paul Thomas + + PR fortran/104650 + * decl.cc (gfc_get_pdt_instance): If the PDT template has + finalizers, make a new f2k_derived namespace for this intance + and copy the template namespace into it. Set the instance + template_sym field to point to the template. + * expr.cc (gfc_check_pointer_assign): Allow array value pointer + lvalues to point to scalar null expressions in initialization. + * gfortran.h : Add the template_sym field to gfc_symbol. + * resolve.cc (gfc_resolve_finalizers): For a pdt_type, copy the + final subroutines with the same type argument into the pdt_type + finalizer list. Prevent final subroutine type checking and + creation of the vtab for pdt_templates. + * symbol.cc (gfc_free_symbol): Do not call gfc_free_namespace + for pdt_type with finalizers. Instead, free the finalizers and + the namespace. + 2025-11-24 Paul Thomas PR fortran/122766 diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 1346f329e612..2568f7378926 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -4200,6 +4200,16 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, instance->attr.pdt_type = 1; instance->declared_at = gfc_current_locus; + /* In resolution, the finalizers are copied, according to the type of the + argument, to the instance finalizers. However, they are retained by the + template and procedures are freed there. */ + if (pdt->f2k_derived && pdt->f2k_derived->finalizers) + { + instance->f2k_derived = gfc_get_namespace (NULL, 0); + instance->template_sym = pdt; + *instance->f2k_derived = *pdt->f2k_derived; + } + /* Add the components, replacing the parameters in all expressions with the expressions for their values in 'type_param_spec_list'. */ c1 = pdt->components; diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index eda0659d6e23..2a4ebb0fa0f9 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -843,6 +843,8 @@ show_attr (symbol_attribute *attr, const char * module) fputs (" VALUE", dumpfile); if (attr->volatile_) fputs (" VOLATILE", dumpfile); + if (attr->omp_groupprivate) + fputs (" GROUPPRIVATE", dumpfile); if (attr->threadprivate) fputs (" THREADPRIVATE", dumpfile); if (attr->temporary) @@ -938,6 +940,8 @@ show_attr (symbol_attribute *attr, const char * module) fputs (" OMP-DECLARE-TARGET", dumpfile); if (attr->omp_declare_target_link) fputs (" OMP-DECLARE-TARGET-LINK", dumpfile); + if (attr->omp_declare_target_local) + fputs (" OMP-DECLARE-TARGET-LOCAL", dumpfile); if (attr->omp_declare_target_indirect) fputs (" OMP-DECLARE-TARGET-INDIRECT", dumpfile); if (attr->omp_device_type == OMP_DEVICE_TYPE_HOST) @@ -2211,6 +2215,20 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) fputs (" DEPEND(source)", dumpfile); if (omp_clauses->doacross_source) fputs (" DOACROSS(source:)", dumpfile); + if (omp_clauses->dyn_groupprivate) + { + fputs (" DYN_GROUPPRIVATE(", dumpfile); + if (omp_clauses->fallback != OMP_FALLBACK_NONE) + fputs ("FALLBACK(", dumpfile); + if (omp_clauses->fallback == OMP_FALLBACK_ABORT) + fputs ("ABORT):", dumpfile); + else if (omp_clauses->fallback == OMP_FALLBACK_DEFAULT_MEM) + fputs ("DEFAULT_MEM):", dumpfile); + else if (omp_clauses->fallback == OMP_FALLBACK_NULL) + fputs ("NULL):", dumpfile); + show_expr (omp_clauses->dyn_groupprivate); + fputc (')', dumpfile); + } if (omp_clauses->capture) fputs (" CAPTURE", dumpfile); if (omp_clauses->depobj_update != OMP_DEPEND_UNSET) diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index a11ff79ab6be..00abd9e8734c 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -4577,7 +4577,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, return false; } - if (lvalue->rank != rvalue->rank && !rank_remap) + if (lvalue->rank != rvalue->rank && !rank_remap + && !(rvalue->expr_type == EXPR_NULL && is_init_expr)) { gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); return false; diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index 595c5095eaf9..b699231e971e 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -5645,6 +5645,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, WALK_SUBEXPR (co->ext.omp_clauses->num_tasks); WALK_SUBEXPR (co->ext.omp_clauses->priority); WALK_SUBEXPR (co->ext.omp_clauses->detach); + WALK_SUBEXPR (co->ext.omp_clauses->dyn_groupprivate); WALK_SUBEXPR (co->ext.omp_clauses->novariants); WALK_SUBEXPR (co->ext.omp_clauses->nocontext); for (idx = 0; idx < ARRAY_SIZE (list_types); idx++) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 848ad9ca1fa2..72aecfb83794 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -311,6 +311,7 @@ enum gfc_statement ST_OMP_TASKLOOP, ST_OMP_END_TASKLOOP, ST_OMP_SCAN, ST_OMP_DEPOBJ, ST_OMP_TASKLOOP_SIMD, ST_OMP_END_TASKLOOP_SIMD, ST_OMP_ORDERED_DEPEND, ST_OMP_REQUIRES, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, + ST_OMP_GROUPPRIVATE, ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST, ST_EVENT_WAIT, ST_FAIL_IMAGE, ST_FORM_TEAM, ST_CHANGE_TEAM, ST_END_TEAM, ST_SYNC_TEAM, ST_OMP_PARALLEL_MASTER, @@ -1042,8 +1043,10 @@ typedef struct /* Mentioned in OMP DECLARE TARGET. */ unsigned omp_declare_target:1; unsigned omp_declare_target_link:1; + unsigned omp_declare_target_local:1; unsigned omp_declare_target_indirect:1; ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2; + unsigned omp_groupprivate:1; unsigned omp_allocate:1; /* Mentioned in OACC DECLARE. */ @@ -1488,6 +1491,7 @@ enum OMP_LIST_TASK_REDUCTION, OMP_LIST_DEVICE_RESIDENT, OMP_LIST_LINK, + OMP_LIST_LOCAL, OMP_LIST_USE_DEVICE, OMP_LIST_CACHE, OMP_LIST_IS_DEVICE_PTR, @@ -1614,6 +1618,14 @@ enum gfc_omp_bind_type OMP_BIND_THREAD }; +enum gfc_omp_fallback +{ + OMP_FALLBACK_NONE, + OMP_FALLBACK_ABORT, + OMP_FALLBACK_DEFAULT_MEM, + OMP_FALLBACK_NULL +}; + typedef struct gfc_omp_assumptions { int n_absent, n_contains; @@ -1649,6 +1661,7 @@ typedef struct gfc_omp_clauses struct gfc_expr *detach; struct gfc_expr *depobj; struct gfc_expr *dist_chunk_size; + struct gfc_expr *dyn_groupprivate; struct gfc_expr *message; struct gfc_expr *novariants; struct gfc_expr *nocontext; @@ -1681,6 +1694,7 @@ typedef struct gfc_omp_clauses ENUM_BITFIELD (gfc_omp_at_type) at:2; ENUM_BITFIELD (gfc_omp_severity_type) severity:2; ENUM_BITFIELD (gfc_omp_sched_kind) dist_sched_kind:3; + ENUM_BITFIELD (gfc_omp_fallback) fallback:2; /* OpenACC. */ struct gfc_expr *async_expr; @@ -1958,6 +1972,7 @@ typedef struct gfc_symbol /* List of PDT parameter expressions */ struct gfc_actual_arglist *param_list; + struct gfc_symbol *template_sym; struct gfc_expr *value; /* Parameter/Initializer value */ gfc_array_spec *as; @@ -2117,6 +2132,8 @@ typedef struct gfc_common_head char use_assoc, saved, threadprivate; unsigned char omp_declare_target : 1; unsigned char omp_declare_target_link : 1; + unsigned char omp_declare_target_local : 1; + unsigned char omp_groupprivate : 1; ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2; /* Provide sufficient space to hold "symbol.symbol.eq.1234567890". */ char name[2*GFC_MAX_SYMBOL_LEN + 1 + 14 + 1]; @@ -3716,6 +3733,9 @@ bool gfc_add_threadprivate (symbol_attribute *, const char *, locus *); bool gfc_add_omp_declare_target (symbol_attribute *, const char *, locus *); bool gfc_add_omp_declare_target_link (symbol_attribute *, const char *, locus *); +bool gfc_add_omp_declare_target_local (symbol_attribute *, const char *, + locus *); +bool gfc_add_omp_groupprivate (symbol_attribute *, const char *, locus *); bool gfc_add_target (symbol_attribute *, locus *); bool gfc_add_dummy (symbol_attribute *, const char *, locus *); bool gfc_add_generic (symbol_attribute *, const char *, locus *); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index fa66bc4783dd..0f7572b25188 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -2535,10 +2535,6 @@ For compatibility, GNU Fortran supports a default exponent of zero in real constants with @option{-fdec}. For example, @code{9e} would be interpreted as @code{9e0}, rather than an error. -@menu -* Unsigned integers:: -@end menu - @node Unsigned integers @subsection Unsigned integers @cindex Unsigned integers diff --git a/gcc/fortran/lang.opt.urls b/gcc/fortran/lang.opt.urls index 742b9b9c07ca..cdb0ba8195d8 100644 --- a/gcc/fortran/lang.opt.urls +++ b/gcc/fortran/lang.opt.urls @@ -17,7 +17,7 @@ H UrlSuffix(gcc/Preprocessor-Options.html#index-H) LangUrlSuffix_D(gdc/Code-Generation.html#index-H) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-H) I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) J LangUrlSuffix_D(gdc/Directory-Options.html#index-J) @@ -425,7 +425,7 @@ fcoarray= LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcoarray) fcheck= -LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcheck) +LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcheck) LangUrlSuffix_Algol68(ga68/Runtime-options.html#index-fcheck) fsecond-underscore LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fsecond-underscore) diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 410361c4bd1c..314be6baa92e 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -174,6 +174,7 @@ match gfc_match_omp_do_simd (void); match gfc_match_omp_loop (void); match gfc_match_omp_error (void); match gfc_match_omp_flush (void); +match gfc_match_omp_groupprivate (void); match gfc_match_omp_interop (void); match gfc_match_omp_masked (void); match gfc_match_omp_masked_taskloop (void); diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index c489decec8dc..262f72b8e7c3 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -2092,7 +2092,8 @@ enum ab_attribute AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE, AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, - AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, + AB_OMP_DECLARE_TARGET_LINK, AB_OMP_DECLARE_TARGET_LOCAL, + AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, AB_PDT_COMP, AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ, @@ -2102,7 +2103,7 @@ enum ab_attribute AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL, AB_OMP_REQ_MEM_ORDER_ACQUIRE, AB_OMP_REQ_MEM_ORDER_RELEASE, AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST, - AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY + AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY, AB_OMP_GROUPPRIVATE }; static const mstring attr_bits[] = @@ -2166,6 +2167,8 @@ static const mstring attr_bits[] = minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT), minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK), minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK), + minit ("OMP_DECLARE_TARGET_LOCAL", AB_OMP_DECLARE_TARGET_LOCAL), + minit ("OMP_GROUPPRIVATE", AB_OMP_GROUPPRIVATE), minit ("PDT_KIND", AB_PDT_KIND), minit ("PDT_LEN", AB_PDT_LEN), minit ("PDT_TYPE", AB_PDT_TYPE), @@ -2399,6 +2402,10 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits); if (attr->omp_declare_target_link) MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits); + if (attr->omp_declare_target_local) + MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LOCAL, attr_bits); + if (attr->omp_groupprivate) + MIO_NAME (ab_attribute) (AB_OMP_GROUPPRIVATE, attr_bits); if (attr->pdt_kind) MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits); if (attr->pdt_len) @@ -2654,6 +2661,12 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_OMP_DECLARE_TARGET_LINK: attr->omp_declare_target_link = 1; break; + case AB_OMP_DECLARE_TARGET_LOCAL: + attr->omp_declare_target_local = 1; + break; + case AB_OMP_GROUPPRIVATE: + attr->omp_groupprivate = 1; + break; case AB_ARRAY_OUTER_DEPENDENCY: attr->array_outer_dependency =1; break; @@ -5268,6 +5281,8 @@ load_commons (void) if (flags & 2) p->threadprivate = 1; p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3); + if ((flags >> 4) & 1) + p->omp_groupprivate = 1; p->use_assoc = 1; /* Get whether this was a bind(c) common or not. */ @@ -6191,6 +6206,7 @@ write_common_0 (gfc_symtree *st, bool this_module) if (p->threadprivate) flags |= 2; flags |= p->omp_device_type << 2; + flags |= p->omp_groupprivate << 4; mio_integer (&flags); /* Write out whether the common block is bind(c) or not. */ diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 81d624b7b54a..e847c1c0c084 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -84,6 +84,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { /* {"flatten", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLATTEN}, */ {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH}, /* {"fuse", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSE}, */ + {"groupprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_GROUPPRIVATE}, /* {"interchange", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTERCHANGE}, */ {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP}, @@ -195,6 +196,7 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) gfc_free_expr (c->num_teams_lower); gfc_free_expr (c->num_teams_upper); gfc_free_expr (c->device); + gfc_free_expr (c->dyn_groupprivate); gfc_free_expr (c->thread_limit); gfc_free_expr (c->dist_chunk_size); gfc_free_expr (c->grainsize); @@ -1172,6 +1174,8 @@ enum omp_mask2 OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */ OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */ OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */ + OMP_CLAUSE_LOCAL, /* OpenMP 6.0 */ + OMP_CLAUSE_DYN_GROUPPRIVATE, /* OpenMP 6.1 */ /* This must come last. */ OMP_MASK2_LAST }; @@ -3096,6 +3100,22 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, else continue; } + if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE) + && gfc_match_dupl_check (!c->dyn_groupprivate, + "dyn_groupprivate", true) == MATCH_YES) + { + if (gfc_match ("fallback ( abort ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_ABORT; + else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_DEFAULT_MEM; + else if (gfc_match ("fallback ( null ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_NULL; + if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES) + return MATCH_ERROR; + if (gfc_match (" )") != MATCH_YES) + goto error; + continue; + } break; case 'e': if ((mask & OMP_CLAUSE_ENTER)) @@ -3567,6 +3587,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, &c->lists[OMP_LIST_LINK]) == MATCH_YES)) continue; + if ((mask & OMP_CLAUSE_LOCAL) + && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL]) + == MATCH_YES)) + continue; break; case 'm': if ((mask & OMP_CLAUSE_MAP) @@ -5064,7 +5088,8 @@ gfc_match_oacc_routine (void) | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \ | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \ - | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS) + | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \ + | OMP_CLAUSE_DYN_GROUPPRIVATE) #define OMP_TARGET_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) @@ -5092,7 +5117,7 @@ gfc_match_oacc_routine (void) (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD) #define OMP_DECLARE_TARGET_CLAUSES \ (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \ - | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT) + | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL) #define OMP_ATOMIC_CLAUSES \ (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \ | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \ @@ -6113,7 +6138,7 @@ gfc_match_omp_declare_target (void) gfc_buffer_error (false); static const int to_enter_link_lists[] - = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK }; + = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL }; for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) && (list = to_enter_link_lists[listn], true); ++listn) for (n = c->lists[list]; n; n = n->next) @@ -6122,6 +6147,8 @@ gfc_match_omp_declare_target (void) else if (n->u.common->head) n->u.common->head->mark = 0; + if (c->device_type == OMP_DEVICE_TYPE_UNSET) + c->device_type = OMP_DEVICE_TYPE_ANY; for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) && (list = to_enter_link_lists[listn], true); ++listn) for (n = c->lists[list]; n; n = n->next) @@ -6130,105 +6157,161 @@ gfc_match_omp_declare_target (void) if (n->sym->attr.in_common) gfc_error_now ("OMP DECLARE TARGET variable at %L is an " "element of a COMMON block", &n->where); + else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL) + gfc_error_now ("List item %qs at %L not appear in the %qs clause " + "as it was previously specified in a GROUPPRIVATE " + "directive", n->sym->name, &n->where, + list == OMP_LIST_LINK + ? "link" : list == OMP_LIST_TO ? "to" : "enter"); else if (n->sym->mark) gfc_error_now ("Variable at %L mentioned multiple times in " "clauses of the same OMP DECLARE TARGET directive", &n->where); - else if (n->sym->attr.omp_declare_target - && n->sym->attr.omp_declare_target_link - && list != OMP_LIST_LINK) + else if ((n->sym->attr.omp_declare_target_link + || n->sym->attr.omp_declare_target_local) + && list != OMP_LIST_LINK + && list != OMP_LIST_LOCAL) gfc_error_now ("OMP DECLARE TARGET variable at %L previously " - "mentioned in LINK clause and later in %s clause", - &n->where, list == OMP_LIST_TO ? "TO" : "ENTER"); + "mentioned in %s clause and later in %s clause", + &n->where, + n->sym->attr.omp_declare_target_link ? "LINK" + : "LOCAL", + list == OMP_LIST_TO ? "TO" : "ENTER"); else if (n->sym->attr.omp_declare_target - && !n->sym->attr.omp_declare_target_link - && list == OMP_LIST_LINK) + && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL)) gfc_error_now ("OMP DECLARE TARGET variable at %L previously " "mentioned in TO or ENTER clause and later in " - "LINK clause", &n->where); - else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, - &n->sym->declared_at)) + "%s clause", &n->where, + list == OMP_LIST_LINK ? "LINK" : "LOCAL"); + else { + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, + &n->sym->declared_at); if (list == OMP_LIST_LINK) gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name, &n->sym->declared_at); + if (list == OMP_LIST_LOCAL) + gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name, + &n->sym->declared_at); + } + if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && n->sym->attr.omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + if (n->sym->attr.omp_groupprivate) + gfc_error_now ("List item %qs at %L set in previous OMP " + "GROUPPRIVATE directive to the different " + "DEVICE_TYPE %qs", n->sym->name, &n->where, dt); + else + gfc_error_now ("List item %qs at %L set in previous OMP " + "DECLARE TARGET directive to the different " + "DEVICE_TYPE %qs", n->sym->name, &n->where, dt); } - if (c->device_type != OMP_DEVICE_TYPE_UNSET) - { - if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && n->sym->attr.omp_device_type != c->device_type) - gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " - "TARGET directive to a different DEVICE_TYPE", - n->sym->name, &n->where); - n->sym->attr.omp_device_type = c->device_type; - } - if (c->indirect) + n->sym->attr.omp_device_type = c->device_type; + if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY) { - if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_ANY) - gfc_error_now ("DEVICE_TYPE must be ANY when used with " - "INDIRECT at %L", &n->where); - n->sym->attr.omp_declare_target_indirect = c->indirect; + gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT " + "at %L", &n->where); + c->indirect = 0; } - + n->sym->attr.omp_declare_target_indirect = c->indirect; + if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST) + gfc_error_now ("List item %qs at %L set with NOHOST specified may " + "not appear in a LINK clause", n->sym->name, + &n->where); n->sym->mark = 1; } - else if (n->u.common->omp_declare_target - && n->u.common->omp_declare_target_link - && list != OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in LINK clause and later in %s clause", - &n->where, list == OMP_LIST_TO ? "TO" : "ENTER"); - else if (n->u.common->omp_declare_target - && !n->u.common->omp_declare_target_link - && list == OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in TO or ENTER clause and later in " - "LINK clause", &n->where); - else if (n->u.common->head && n->u.common->head->mark) - gfc_error_now ("COMMON at %L mentioned multiple times in " - "clauses of the same OMP DECLARE TARGET directive", - &n->where); - else - { - n->u.common->omp_declare_target = 1; - n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK); + else /* common block */ + { + if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL) + gfc_error_now ("Common block % at %L not appear in the %qs " + "clause as it was previously specified in a " + "GROUPPRIVATE directive", + n->u.common->name, &n->where, + list == OMP_LIST_LINK + ? "link" : list == OMP_LIST_TO ? "to" : "enter"); + else if (n->u.common->head && n->u.common->head->mark) + gfc_error_now ("Common block % at %L mentioned multiple " + "times in clauses of the same OMP DECLARE TARGET " + "directive", n->u.common->name, &n->where); + else if ((n->u.common->omp_declare_target_link + || n->u.common->omp_declare_target_local) + && list != OMP_LIST_LINK + && list != OMP_LIST_LOCAL) + gfc_error_now ("Common block % at %L previously mentioned " + "in %s clause and later in %s clause", + n->u.common->name, &n->where, + n->u.common->omp_declare_target_link ? "LINK" + : "LOCAL", + list == OMP_LIST_TO ? "TO" : "ENTER"); + else if (n->u.common->omp_declare_target + && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL)) + gfc_error_now ("Common block % at %L previously mentioned " + "in TO or ENTER clause and later in %s clause", + n->u.common->name, &n->where, + list == OMP_LIST_LINK ? "LINK" : "LOCAL"); if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET && n->u.common->omp_device_type != c->device_type) - gfc_error_now ("COMMON at %L set in previous OMP DECLARE " - "TARGET directive to a different DEVICE_TYPE", - &n->where); + { + const char *dt = "any"; + if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + if (n->u.common->omp_groupprivate) + gfc_error_now ("Common block % at %L set in previous OMP " + "GROUPPRIVATE directive to the different " + "DEVICE_TYPE %qs", n->u.common->name, &n->where, + dt); + else + gfc_error_now ("Common block % at %L set in previous OMP " + "DECLARE TARGET directive to the different " + "DEVICE_TYPE %qs", n->u.common->name, &n->where, + dt); + } n->u.common->omp_device_type = c->device_type; + if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY) + { + gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT " + "at %L", &n->where); + c->indirect = 0; + } + if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST) + gfc_error_now ("Common block % at %L set with NOHOST " + "specified may not appear in a LINK clause", + n->u.common->name, &n->where); + + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + n->u.common->omp_declare_target = 1; + if (list == OMP_LIST_LINK) + n->u.common->omp_declare_target_link = 1; + if (list == OMP_LIST_LOCAL) + n->u.common->omp_declare_target_local = 1; + for (s = n->u.common->head; s; s = s->common_next) { s->mark = 1; - if (gfc_add_omp_declare_target (&s->attr, s->name, - &s->declared_at)) - { - if (list == OMP_LIST_LINK) - gfc_add_omp_declare_target_link (&s->attr, s->name, - &s->declared_at); - } - if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && s->attr.omp_device_type != c->device_type) - gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" - " TARGET directive to a different DEVICE_TYPE", - s->name, &n->where); + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + gfc_add_omp_declare_target (&s->attr, s->name, &n->where); + if (list == OMP_LIST_LINK) + gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where); + if (list == OMP_LIST_LOCAL) + gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where); s->attr.omp_device_type = c->device_type; - - if (c->indirect - && s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && s->attr.omp_device_type != OMP_DEVICE_TYPE_ANY) - gfc_error_now ("DEVICE_TYPE must be ANY when used with " - "INDIRECT at %L", &n->where); s->attr.omp_declare_target_indirect = c->indirect; } } if ((c->device_type || c->indirect) && !c->lists[OMP_LIST_ENTER] && !c->lists[OMP_LIST_TO] - && !c->lists[OMP_LIST_LINK]) + && !c->lists[OMP_LIST_LINK] + && !c->lists[OMP_LIST_LOCAL]) gfc_warning_now (OPT_Wopenmp, "OMP DECLARE TARGET directive at %L with only " "DEVICE_TYPE or INDIRECT clauses is ignored", @@ -7108,32 +7191,44 @@ gfc_match_omp_metadirective (void) return match_omp_metadirective (false); } -match -gfc_match_omp_threadprivate (void) +/* Match 'omp threadprivate' or 'omp groupprivate'. */ +static match +gfc_match_omp_thread_group_private (bool is_groupprivate) { locus old_loc; char n[GFC_MAX_SYMBOL_LEN+1]; gfc_symbol *sym; match m; gfc_symtree *st; + struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; }; + auto_vec syms; old_loc = gfc_current_locus; - m = gfc_match (" ("); + m = gfc_match (" ( "); if (m != MATCH_YES) return m; for (;;) { + locus sym_loc = gfc_current_locus; m = gfc_match_symbol (&sym, 0); switch (m) { case MATCH_YES: if (sym->attr.in_common) - gfc_error_now ("Threadprivate variable at %C is an element of " - "a COMMON block"); - else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) + gfc_error_now ("%qs variable at %L is an element of a COMMON block", + is_groupprivate ? "groupprivate" : "threadprivate", + &sym_loc); + else if (!is_groupprivate + && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc)) goto cleanup; + else if (is_groupprivate) + { + if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc)) + goto cleanup; + syms.safe_push ({sym, nullptr, sym_loc}); + } goto next_item; case MATCH_NO: break; @@ -7150,12 +7245,20 @@ gfc_match_omp_threadprivate (void) st = gfc_find_symtree (gfc_current_ns->common_root, n); if (st == NULL) { - gfc_error ("COMMON block /%s/ not found at %C", n); + gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc); goto cleanup; } - st->n.common->threadprivate = 1; + syms.safe_push ({nullptr, st->n.common, sym_loc}); + if (is_groupprivate) + st->n.common->omp_groupprivate = 1; + else + st->n.common->threadprivate = 1; for (sym = st->n.common->head; sym; sym = sym->common_next) - if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) + if (!is_groupprivate + && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc)) + goto cleanup; + else if (is_groupprivate + && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc)) goto cleanup; next_item: @@ -7165,16 +7268,89 @@ gfc_match_omp_threadprivate (void) goto syntax; } + if (is_groupprivate) + { + gfc_omp_clauses *c; + m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE)); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (c->device_type == OMP_DEVICE_TYPE_UNSET) + c->device_type = OMP_DEVICE_TYPE_ANY; + + for (size_t i = 0; i < syms.length (); i++) + if (syms[i].sym) + { + sym_loc_t &n = syms[i]; + if (n.sym->attr.in_common) + gfc_error_now ("Variable %qs at %L is an element of a COMMON " + "block", n.sym->name, &n.loc); + else if (n.sym->attr.omp_declare_target + || n.sym->attr.omp_declare_target_link) + gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET " + "with the LOCAL clause, but it has been specified" + " with a different clause before", + n.sym->name, &n.loc); + if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && n.sym->attr.omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " + "TARGET directive to the different DEVICE_TYPE %qs", + n.sym->name, &n.loc, dt); + } + gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name, + &n.loc); + n.sym->attr.omp_device_type = c->device_type; + } + else /* Common block. */ + { + sym_loc_t &n = syms[i]; + if (n.com->omp_declare_target + || n.com->omp_declare_target_link) + gfc_error_now ("List item % at %L implies OMP DECLARE " + "TARGET with the LOCAL clause, but it has been " + "specified with a different clause before", + n.com->name, &n.loc); + if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET + && n.com->omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" + " TARGET directive to the different DEVICE_TYPE " + "%qs", n.com->name, &n.loc, dt); + } + n.com->omp_declare_target_local = 1; + n.com->omp_device_type = c->device_type; + for (gfc_symbol *s = n.com->head; s; s = s->common_next) + { + gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc); + s->attr.omp_device_type = c->device_type; + } + } + free (c); + } + if (gfc_match_omp_eos () != MATCH_YES) { - gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C"); + gfc_error ("Unexpected junk after OMP %s at %C", + is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE"); goto cleanup; } return MATCH_YES; syntax: - gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C"); + gfc_error ("Syntax error in !$OMP %s list at %C", + is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE"); cleanup: gfc_current_locus = old_loc; @@ -7182,6 +7358,20 @@ gfc_match_omp_threadprivate (void) } +match +gfc_match_omp_groupprivate (void) +{ + return gfc_match_omp_thread_group_private (true); +} + + +match +gfc_match_omp_threadprivate (void) +{ + return gfc_match_omp_thread_group_private (false); +} + + match gfc_match_omp_parallel (void) { @@ -8492,7 +8682,8 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all || (n->sym->ns->proc_name && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM - || n->sym->ns->proc_name->attr.flavor == FL_MODULE))) + || n->sym->ns->proc_name->attr.flavor == FL_MODULE + || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA))) { bool com = n->sym->attr.in_common; if (!n->u2.allocator) @@ -8506,6 +8697,30 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) &n->u2.allocator->where, com ? "/" : "", com ? n->sym->common_head->name : n->sym->name, com ? "/" : "", &n->where); + /* Only local static variables might use omp_cgroup_mem_alloc (6), + omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */ + else if ((!ns->proc_name + || ns->proc_name->attr.flavor == FL_PROGRAM + || ns->proc_name->attr.flavor == FL_BLOCK_DATA + || ns->proc_name->attr.flavor == FL_MODULE + || com) + && mpz_cmp_si (n->u2.allocator->value.integer, + 6 /* cgroup */) >= 0 + && mpz_cmp_si (n->u2.allocator->value.integer, + 8 /* thread */) <= 0) + { + const char *alloc_name[] = {"omp_cgroup_mem_alloc", + "omp_pteam_mem_alloc", + "omp_thread_mem_alloc" }; + gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, " + "used for list item %<%s%s%s%> at %L, may only be used" + " for local static variables", + alloc_name[mpz_get_ui (n->u2.allocator->value.integer) + - 6 /* cgroup */], &n->u2.allocator->where, + com ? "/" : "", + com ? n->sym->common_head->name : n->sym->name, + com ? "/" : "", &n->where); + } while (n->sym->attr.in_common && n->next && n->next->sym && n->sym->common_head == n->next->sym->common_head) n = n->next; @@ -8554,7 +8769,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "TO", "FROM", "INCLUSIVE", "EXCLUSIVE", "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/, "IN_REDUCTION", "TASK_REDUCTION", - "DEVICE_RESIDENT", "LINK", "USE_DEVICE", + "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE", "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER", "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" }; @@ -8761,6 +8976,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, } if (omp_clauses->num_threads) resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS"); + if (omp_clauses->dyn_groupprivate) + resolve_positive_int_expr (omp_clauses->dyn_groupprivate, + "DYN_GROUPPRIVATE"); if (omp_clauses->chunk_size) { gfc_expr *expr = omp_clauses->chunk_size; diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index e4d65200f3ab..df8570bad289 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -1195,6 +1195,9 @@ decode_omp_directive (void) case 'f': matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); break; + case 'g': + matchdo ("groupprivate", gfc_match_omp_groupprivate, ST_OMP_GROUPPRIVATE); + break; case 'i': matcho ("interop", gfc_match_omp_interop, ST_OMP_INTEROP); break; @@ -1990,7 +1993,8 @@ next_statement (void) #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \ case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \ - case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE + case ST_OMP_REQUIRES: case ST_OMP_GROUPPRIVATE: \ + case ST_OACC_ROUTINE: case ST_OACC_DECLARE /* OpenMP statements that are followed by a structured block. */ @@ -2909,6 +2913,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel) case ST_OMP_FLUSH: p = "!$OMP FLUSH"; break; + case ST_OMP_GROUPPRIVATE: + p = "!$OMP GROUPPRIVATE"; + break; case ST_OMP_INTEROP: p = "!$OMP INTEROP"; break; @@ -4437,6 +4444,8 @@ parse_spec (gfc_statement st) case ST_EQUIVALENCE: case ST_IMPLICIT: case ST_IMPLICIT_NONE: + case ST_OMP_ALLOCATE: + case ST_OMP_GROUPPRIVATE: case ST_OMP_THREADPRIVATE: case ST_PARAMETER: case ST_STRUCTURE_DECL: diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 2390858424e2..9f3ce1d2ad61 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -15836,7 +15836,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) static bool gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) { - gfc_finalizer* list; + gfc_finalizer *list, *pdt_finalizers = NULL; gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ bool result = true; bool seen_scalar = false; @@ -15866,6 +15866,41 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) return true; } + /* If a PDT has finalizers, the pdt_type's f2k_derived is a copy of that of + the template. If the finalizers field has the same value, it needs to be + supplied with finalizers of the same pdt_type. */ + if (derived->attr.pdt_type + && derived->template_sym + && derived->template_sym->f2k_derived + && (pdt_finalizers = derived->template_sym->f2k_derived->finalizers) + && derived->f2k_derived->finalizers == pdt_finalizers) + { + gfc_finalizer *tmp = NULL; + derived->f2k_derived->finalizers = NULL; + prev_link = &derived->f2k_derived->finalizers; + for (list = pdt_finalizers; list; list = list->next) + { + gfc_formal_arglist *args = gfc_sym_get_dummy_args (list->proc_sym); + if (args->sym + && args->sym->ts.type == BT_DERIVED + && args->sym->ts.u.derived + && !strcmp (args->sym->ts.u.derived->name, derived->name)) + { + tmp = gfc_get_finalizer (); + *tmp = *list; + tmp->next = NULL; + if (*prev_link) + { + (*prev_link)->next = tmp; + prev_link = &tmp; + } + else + *prev_link = tmp; + list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym); + } + } + } + /* Walk over the list of finalizer-procedures, check them, and if any one does not fit in with the standard's definition, print an error and remove it from the list. */ @@ -15922,7 +15957,8 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) } /* This argument must be of our type. */ - if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) + if (!derived->attr.pdt_template + && (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)) { gfc_error ("Argument of FINAL procedure at %L must be of type %qs", &arg->declared_at, derived->name); @@ -15977,7 +16013,7 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) /* Argument list might be empty; that is an error signalled earlier, but we nevertheless continued resolving. */ dummy_args = gfc_sym_get_dummy_args (i->proc_sym); - if (dummy_args) + if (dummy_args && !derived->attr.pdt_template) { gfc_symbol* i_arg = dummy_args->sym; const int i_rank = (i_arg->as ? i_arg->as->rank : 0); @@ -16025,9 +16061,13 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) " rank finalizer has been declared", derived->name, &derived->declared_at); - vtab = gfc_find_derived_vtab (derived); - c = vtab->ts.u.derived->components->next->next->next->next->next; - gfc_set_sym_referenced (c->initializer->symtree->n.sym); + if (!derived->attr.pdt_template) + { + vtab = gfc_find_derived_vtab (derived); + c = vtab->ts.u.derived->components->next->next->next->next->next; + if (c && c->initializer && c->initializer->symtree && c->initializer->symtree->n.sym) + gfc_set_sym_referenced (c->initializer->symtree->n.sym); + } if (finalizable) *finalizable = true; @@ -18674,17 +18714,30 @@ resolve_symbol (gfc_symbol *sym) } /* Check threadprivate restrictions. */ - if (sym->attr.threadprivate + if ((sym->attr.threadprivate || sym->attr.omp_groupprivate) && !(sym->attr.save || sym->attr.data || sym->attr.in_common) && !(sym->ns->save_all && !sym->attr.automatic) && sym->module == NULL && (sym->ns->proc_name == NULL || (sym->ns->proc_name->attr.flavor != FL_MODULE && !sym->ns->proc_name->attr.is_main_program))) - gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + { + if (sym->attr.threadprivate) + gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + else + gfc_error ("OpenMP groupprivate variable %qs at %L must have the SAVE " + "attribute", sym->name, &sym->declared_at); + } + + if (sym->attr.omp_groupprivate && sym->value) + gfc_error ("!$OMP GROUPPRIVATE variable %qs at %L must not have an " + "initializer", sym->name, &sym->declared_at); /* Check omp declare target restrictions. */ - if (sym->attr.omp_declare_target + if ((sym->attr.omp_declare_target + || sym->attr.omp_declare_target_link + || sym->attr.omp_declare_target_local) + && !sym->attr.omp_groupprivate /* already warned. */ && sym->attr.flavor == FL_VARIABLE && !sym->attr.save && !(sym->ns->save_all && !sym->attr.automatic) diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index b4d3ed6394db..62925c028e6c 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -458,8 +458,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC", *pdt_len = "LEN", *pdt_kind = "KIND"; static const char *threadprivate = "THREADPRIVATE"; + static const char *omp_groupprivate = "OpenMP GROUPPRIVATE"; static const char *omp_declare_target = "OMP DECLARE TARGET"; static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK"; + static const char *omp_declare_target_local = "OMP DECLARE TARGET LOCAL"; static const char *oacc_declare_copyin = "OACC DECLARE COPYIN"; static const char *oacc_declare_create = "OACC DECLARE CREATE"; static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR"; @@ -553,8 +555,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (dummy, entry); conf (dummy, intrinsic); conf (dummy, threadprivate); + conf (dummy, omp_groupprivate); conf (dummy, omp_declare_target); conf (dummy, omp_declare_target_link); + conf (dummy, omp_declare_target_local); conf (pointer, target); conf (pointer, intrinsic); conf (pointer, elemental); @@ -604,8 +608,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (in_equivalence, entry); conf (in_equivalence, allocatable); conf (in_equivalence, threadprivate); + conf (in_equivalence, omp_groupprivate); conf (in_equivalence, omp_declare_target); conf (in_equivalence, omp_declare_target_link); + conf (in_equivalence, omp_declare_target_local); conf (in_equivalence, oacc_declare_create); conf (in_equivalence, oacc_declare_copyin); conf (in_equivalence, oacc_declare_deviceptr); @@ -616,6 +622,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (entry, result); conf (generic, result); conf (generic, omp_declare_target); + conf (generic, omp_declare_target_local); conf (generic, omp_declare_target_link); conf (function, subroutine); @@ -661,8 +668,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointee, in_common); conf (cray_pointee, in_equivalence); conf (cray_pointee, threadprivate); + conf (cray_pointee, omp_groupprivate); conf (cray_pointee, omp_declare_target); conf (cray_pointee, omp_declare_target_link); + conf (cray_pointee, omp_declare_target_local); conf (cray_pointee, oacc_declare_create); conf (cray_pointee, oacc_declare_copyin); conf (cray_pointee, oacc_declare_deviceptr); @@ -720,9 +729,11 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (proc_pointer, abstract) conf (proc_pointer, omp_declare_target) + conf (proc_pointer, omp_declare_target_local) conf (proc_pointer, omp_declare_target_link) conf (entry, omp_declare_target) + conf (entry, omp_declare_target_local) conf (entry, omp_declare_target_link) conf (entry, oacc_declare_create) conf (entry, oacc_declare_copyin) @@ -782,8 +793,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (omp_declare_target); conf2 (omp_declare_target_link); + conf2 (omp_declare_target_local); conf2 (oacc_declare_create); conf2 (oacc_declare_copyin); conf2 (oacc_declare_deviceptr); @@ -828,7 +841,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (dimension); conf2 (function); if (!attr->proc_pointer) - conf2 (threadprivate); + { + conf2 (threadprivate); + conf2 (omp_groupprivate); + } } /* Procedure pointers in COMMON blocks are allowed in F03, @@ -836,6 +852,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008)) conf2 (in_common); + conf2 (omp_declare_target_local); conf2 (omp_declare_target_link); switch (attr->proc) @@ -852,6 +869,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) case PROC_DUMMY: conf2 (result); conf2 (threadprivate); + conf2 (omp_groupprivate); break; default: @@ -872,8 +890,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (result); conf2 (omp_declare_target); + conf2 (omp_declare_target_local); conf2 (omp_declare_target_link); conf2 (oacc_declare_create); conf2 (oacc_declare_copyin); @@ -905,6 +925,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (volatile_); conf2 (asynchronous); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (value); conf2 (codimension); conf2 (result); @@ -1406,6 +1427,25 @@ gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) } +bool +gfc_add_omp_groupprivate (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_groupprivate) + { + duplicate_attr ("OpenMP GROUPPRIVATE", where); + return false; + } + + attr->omp_groupprivate = true; + return gfc_check_conflict (attr, name, where); +} + + bool gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) { @@ -1456,6 +1496,22 @@ gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name, } +bool +gfc_add_omp_declare_target_local (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_declare_target_local) + return true; + + attr->omp_declare_target_local = 1; + return gfc_check_conflict (attr, name, where); +} + + bool gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name, locus *where) @@ -2110,6 +2166,9 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) goto fail; if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where)) goto fail; + if (src->omp_groupprivate + && !gfc_add_omp_groupprivate (dest, NULL, where)) + goto fail; if (src->threadprivate && !gfc_add_threadprivate (dest, NULL, where)) goto fail; @@ -2119,6 +2178,9 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) if (src->omp_declare_target_link && !gfc_add_omp_declare_target_link (dest, NULL, where)) goto fail; + if (src->omp_declare_target_local + && !gfc_add_omp_declare_target_local (dest, NULL, where)) + goto fail; if (src->oacc_declare_create && !gfc_add_oacc_declare_create (dest, NULL, where)) goto fail; @@ -3225,7 +3287,21 @@ gfc_free_symbol (gfc_symbol *&sym) gfc_free_formal_arglist (sym->formal); - gfc_free_namespace (sym->f2k_derived); + /* The pdt_type f2k_derived namespaces are copies of that of the pdt_template + and are only made if there are finalizers. The complete list of finalizers + is kept by the pdt_template and are freed with its f2k_derived. */ + if (!sym->attr.pdt_type) + gfc_free_namespace (sym->f2k_derived); + else if (sym->f2k_derived && sym->f2k_derived->finalizers) + { + gfc_finalizer *p, *q = NULL; + for (p = sym->f2k_derived->finalizers; p; p = q) + { + q = p->next; + free (p); + } + free (sym->f2k_derived); + } set_symbol_common_block (sym, NULL); diff --git a/gcc/fortran/trans-common.cc b/gcc/fortran/trans-common.cc index 135d3047a154..6439a1530c63 100644 --- a/gcc/fortran/trans-common.cc +++ b/gcc/fortran/trans-common.cc @@ -488,6 +488,27 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) } omp_clauses = c; } + /* Also check trans-decl.cc when updating/removing the following; + also update f95.c's gfc_gnu_attributes. + For the warning, see also OpenMP spec issue 4663. */ + if (com->omp_groupprivate && com->threadprivate) + { + /* Unset this flag; implicit 'declare target local(...)' remains. */ + com->omp_groupprivate = 0; + gfc_warning (OPT_Wopenmp, + "Ignoring the % attribute for " + "% common block % declared at %L", + com->name, &com->where); + } + if (com->omp_groupprivate) + gfc_error ("Sorry, OMP GROUPPRIVATE not implemented, used by common " + "block % declared at %L", com->name, &com->where); + else if (com->omp_declare_target_local) + /* Use 'else if' as groupprivate implies 'local'. */ + gfc_error ("Sorry, OMP DECLARE TARGET with LOCAL clause not implemented" + ", used by common block % declared at %L", + com->name, &com->where); + if (com->omp_declare_target_link) DECL_ATTRIBUTES (decl) = tree_cons (get_identifier ("omp declare target link"), @@ -497,10 +518,12 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) = tree_cons (get_identifier ("omp declare target"), omp_clauses, DECL_ATTRIBUTES (decl)); - if (com->omp_declare_target_link || com->omp_declare_target) + if (com->omp_declare_target_link || com->omp_declare_target + /* FIXME: || com->omp_declare_target_local */) { - /* Add to offload_vars; get_create does so for omp_declare_target, - omp_declare_target_link requires manual work. */ + /* Add to offload_vars; get_create does so for omp_declare_target + and omp_declare_target_local, omp_declare_target_link requires + manual work. */ gcc_assert (symtab_node::get (decl) == 0); symtab_node *node = symtab_node::get_create (decl); if (node != NULL && com->omp_declare_target_link) @@ -1045,8 +1068,10 @@ accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e) dummy_symbol->generic |= attr.generic; dummy_symbol->automatic |= attr.automatic; dummy_symbol->threadprivate |= attr.threadprivate; + dummy_symbol->omp_groupprivate |= attr.omp_groupprivate; dummy_symbol->omp_declare_target |= attr.omp_declare_target; dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link; + dummy_symbol->omp_declare_target_local |= attr.omp_declare_target_local; dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin; dummy_symbol->oacc_declare_create |= attr.oacc_declare_create; dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr; diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 419de2c63cf2..2164b37e4cb2 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -1560,7 +1560,11 @@ add_attributes_to_decl (tree *decl_p, const gfc_symbol *sym) clauses = c; } - if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET) + /* FIXME: 'declare_target_link' permits both any and host, but + will fail if one sets OMP_CLAUSE_DEVICE_TYPE_KIND. */ + if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && !sym_attr.omp_declare_target_link + && !sym_attr.omp_declare_target_indirect /* implies 'any' */) { tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); switch (sym_attr.omp_device_type) @@ -1581,6 +1585,26 @@ add_attributes_to_decl (tree *decl_p, const gfc_symbol *sym) clauses = c; } + /* Also check trans-common.cc when updating/removing the following; + also update f95.c's gfc_gnu_attributes. + For the warning, see also OpenMP spec issue 4663. */ + if (sym_attr.omp_groupprivate && sym_attr.threadprivate) + { + /* Unset this flag; implicit 'declare target local(...)' remains. */ + sym_attr.omp_groupprivate = 0; + gfc_warning (OPT_Wopenmp, + "Ignoring the % attribute for " + "% variable %qs declared at %L", + sym->name, &sym->declared_at); + } + if (sym_attr.omp_groupprivate) + gfc_error ("Sorry, OMP GROUPPRIVATE not implemented, " + "used by %qs declared at %L", sym->name, &sym->declared_at); + else if (sym_attr.omp_declare_target_local) + /* Use 'else if' as groupprivate implies 'local'. */ + gfc_error ("Sorry, OMP DECLARE TARGET with LOCAL clause not implemented, " + "used by %qs declared at %L", sym->name, &sym->declared_at); + bool has_declare = true; if (sym_attr.omp_declare_target_link || sym_attr.oacc_declare_link) diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 69a70d7138cf..c0a8ed927d9d 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -4180,7 +4180,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree type = TREE_TYPE (decl); if (n->sym->ts.type == BT_CHARACTER && n->sym->ts.deferred - && n->sym->attr.omp_declare_target + && (n->sym->attr.omp_declare_target + || n->sym->attr.omp_declare_target_link + || n->sym->attr.omp_declare_target_local) && (always_modifier || n->sym->attr.pointer) && op != EXEC_OMP_TARGET_EXIT_DATA && n->u.map.op != OMP_MAP_DELETE @@ -5263,6 +5265,25 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } + if (clauses->dyn_groupprivate) + { + sorry_at (gfc_get_location (&where), "% clause"); +#if 0 /* FIXME: Handle it, including 'fallback(abort/default_mem/null)' */ + tree dyn_groupprivate; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->dyn_groupprivate); + gfc_add_block_to_block (block, &se.pre); + dyn_groupprivate = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (gfc_get_location (&where), + OMP_CLAUSE_DYN_GROUPPRIVATE); + OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); +#endif + } + chunk_size = NULL_TREE; if (clauses->chunk_size) { diff --git a/gcc/gcc.cc b/gcc/gcc.cc index fa46387e59a6..b5d0f759f144 100644 --- a/gcc/gcc.cc +++ b/gcc/gcc.cc @@ -4651,11 +4651,13 @@ driver_handle_option (struct gcc_options *opts, case OPT_static_libgfortran: case OPT_static_libquadmath: case OPT_static_libphobos: + case OPT_static_libga68: case OPT_static_libgm2: case OPT_static_libstdc__: /* These are always valid; gcc.cc itself understands the first two gfortranspec.cc understands -static-libgfortran, libgfortran.spec handles -static-libquadmath, + a68spec.cc understands -static-libga68, d-spec.cc understands -static-libphobos, gm2spec.cc understands -static-libgm2, and g++spec.cc understands -static-libstdc++. */ diff --git a/gcc/generic-match-head.cc b/gcc/generic-match-head.cc index ea4a958686db..1a9b490f2ee9 100644 --- a/gcc/generic-match-head.cc +++ b/gcc/generic-match-head.cc @@ -203,3 +203,9 @@ bitwise_inverted_equal_p (tree expr1, tree expr2, bool &wascmp) } return false; } + +static inline gimple * +gimple_match_ctx (tree) +{ + return NULL; +} diff --git a/gcc/gimple-lower-bitint.cc b/gcc/gimple-lower-bitint.cc index 28802e3b4aaa..f699b8ec3af9 100644 --- a/gcc/gimple-lower-bitint.cc +++ b/gcc/gimple-lower-bitint.cc @@ -630,6 +630,8 @@ bitint_large_huge::limb_access (tree type, tree var, tree idx, bool write_p, | ENCODE_QUAL_ADDR_SPACE (as)); tree ptype = build_pointer_type (strip_array_types (TREE_TYPE (var))); unsigned HOST_WIDE_INT off = tree_to_uhwi (idx) * m_limb_size; + if (bitint_big_endian) + off += m_limb_size - tree_to_uhwi (TYPE_SIZE_UNIT (ltype)); ret = build2 (MEM_REF, ltype, build_fold_addr_expr (var), build_int_cst (ptype, off)); @@ -641,12 +643,14 @@ bitint_large_huge::limb_access (tree type, tree var, tree idx, bool write_p, if (as != TYPE_ADDR_SPACE (ltype)) ltype = build_qualified_type (ltype, TYPE_QUALS (ltype) | ENCODE_QUAL_ADDR_SPACE (as)); + unsigned HOST_WIDE_INT off = tree_to_uhwi (idx) * m_limb_size; + if (bitint_big_endian) + off += m_limb_size - tree_to_uhwi (TYPE_SIZE_UNIT (ltype)); ret = build2 (MEM_REF, ltype, unshare_expr (TREE_OPERAND (var, 0)), size_binop (PLUS_EXPR, TREE_OPERAND (var, 1), build_int_cst (TREE_TYPE (TREE_OPERAND (var, 1)), - tree_to_uhwi (idx) - * m_limb_size))); + off))); TREE_THIS_VOLATILE (ret) = TREE_THIS_VOLATILE (var); TREE_SIDE_EFFECTS (ret) = TREE_SIDE_EFFECTS (var); TREE_THIS_NOTRAP (ret) = TREE_THIS_NOTRAP (var); diff --git a/gcc/gimple-match-head.cc b/gcc/gimple-match-head.cc index 6b3c5febbea7..895d390455d3 100644 --- a/gcc/gimple-match-head.cc +++ b/gcc/gimple-match-head.cc @@ -507,3 +507,31 @@ match_cond_with_binary_phi (gphi *phi, tree *true_arg, tree *false_arg) return cond; } + +/* If OP is a SSA_NAME with SSA_NAME_DEF_STMT in the IL, return that + stmt, otherwise NULL. For use in range_of_expr calls. */ + +static inline gimple * +gimple_match_ctx (tree op) +{ + if (TREE_CODE (op) == SSA_NAME + && SSA_NAME_DEF_STMT (op) + && gimple_bb (SSA_NAME_DEF_STMT (op))) + return SSA_NAME_DEF_STMT (op); + return NULL; +} + +/* Helper to shorten range queries in match.pd. R is the range to + be queried, OP tree on which it should be queried and CTX is some + capture on which gimple_match_ctx should be called, or NULL for + global range. */ + +static inline bool +gimple_match_range_of_expr (vrange &r, tree op, tree ctx = NULL_TREE) +{ + if (!get_range_query (cfun)->range_of_expr (r, op, + ctx ? gimple_match_ctx (ctx) + : NULL)) + return false; + return !r.undefined_p (); +} diff --git a/gcc/go/ChangeLog b/gcc/go/ChangeLog index 02105c074005..c270b531e202 100644 --- a/gcc/go/ChangeLog +++ b/gcc/go/ChangeLog @@ -1,3 +1,7 @@ +2025-11-30 Andrew Pinski + + * lang.opt.urls: Regenerate. + 2025-11-20 Rainer Orth * gospec.cc (lang_specific_driver) [TARGET_SOLARIS]: Replace diff --git a/gcc/go/lang.opt.urls b/gcc/go/lang.opt.urls index 051f7060d870..4b93c4919acc 100644 --- a/gcc/go/lang.opt.urls +++ b/gcc/go/lang.opt.urls @@ -1,7 +1,7 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/go/lang.opt and generated HTML I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) L UrlSuffix(gcc/Directory-Options.html#index-L) LangUrlSuffix_D(gdc/Directory-Options.html#index-L) diff --git a/gcc/json.h b/gcc/json.h index c53715ecb2ca..90b6c601f809 100644 --- a/gcc/json.h +++ b/gcc/json.h @@ -189,6 +189,9 @@ class object : public value public: ~object (); + typedef hash_map > map_t; + enum kind get_kind () const final override { return JSON_OBJECT; } void print (pretty_printer *pp, bool formatted) const final override; std::unique_ptr clone () const final override; @@ -214,6 +217,7 @@ class object : public value } value *get (const char *key) const; + const map_t &get_map () const { return m_map; } void set_string (const char *key, const char *utf8_value); void set_integer (const char *key, long v); @@ -243,8 +247,6 @@ class object : public value std::unique_ptr clone_as_object () const; private: - typedef hash_map > map_t; map_t m_map; /* Keep track of order in which keys were inserted. */ @@ -497,6 +499,26 @@ is_a_helper ::test (const json::value *jv) return jv->get_kind () == json::JSON_STRING; } +template <> +template <> +inline bool +is_a_helper::test (json::value *jv) +{ + return (jv->get_kind () == json::JSON_TRUE + || jv->get_kind () == json::JSON_FALSE + || jv->get_kind () == json::JSON_NULL); +} + +template <> +template <> +inline bool +is_a_helper::test (const json::value *jv) +{ + return (jv->get_kind () == json::JSON_TRUE + || jv->get_kind () == json::JSON_FALSE + || jv->get_kind () == json::JSON_NULL); +} + #if CHECKING_P namespace selftest { diff --git a/gcc/lto/ChangeLog b/gcc/lto/ChangeLog index 4adfd9ebfa29..ff9e2e809724 100644 --- a/gcc/lto/ChangeLog +++ b/gcc/lto/ChangeLog @@ -1,3 +1,8 @@ +2025-11-25 Siddhesh Poyarekar + + PR lto/122515 + * lto-common.cc (lto_read_section_data): Avoid using SSIZE_MAX. + 2025-11-13 Michal Jires PR lto/122603 diff --git a/gcc/m2/ChangeLog b/gcc/m2/ChangeLog index 737ab124dc1e..3d2a34f66e79 100644 --- a/gcc/m2/ChangeLog +++ b/gcc/m2/ChangeLog @@ -1,3 +1,7 @@ +2025-11-30 Andrew Pinski + + * lang.opt.urls: Regenerate. + 2025-11-02 Gaius Mulley PR modula2/122499 diff --git a/gcc/m2/lang.opt.urls b/gcc/m2/lang.opt.urls index 1abc1685ea32..f7751fe4a3c8 100644 --- a/gcc/m2/lang.opt.urls +++ b/gcc/m2/lang.opt.urls @@ -38,7 +38,7 @@ UrlSuffix(gcc/Preprocessor-Options.html#index-D-1) ; duplicate: 'gcc/Overall-Options.html#index-E' I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) L UrlSuffix(gcc/Directory-Options.html#index-L) LangUrlSuffix_D(gdc/Directory-Options.html#index-L) diff --git a/gcc/match.pd b/gcc/match.pd index 36d8f2f72750..f164ec591008 100644 --- a/gcc/match.pd +++ b/gcc/match.pd @@ -648,7 +648,7 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) /* Similar to above, but there could be an extra add/sub between successive multuiplications. */ (simplify - (mult (plus:s (mult:s@4 @0 INTEGER_CST@1) INTEGER_CST@2) INTEGER_CST@3) + (mult (plus:s@5 (mult:s@4 @0 INTEGER_CST@1) INTEGER_CST@2) INTEGER_CST@3) (with { bool overflowed = true; wi::overflow_type ovf1, ovf2; @@ -661,8 +661,8 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) #if GIMPLE int_range_max vr0; if (ovf1 == wi::OVF_NONE && ovf2 == wi::OVF_NONE - && get_global_range_query ()->range_of_expr (vr0, @4) - && !vr0.varying_p () && !vr0.undefined_p ()) + && gimple_match_range_of_expr (vr0, @4, @5) + && !vr0.varying_p ()) { wide_int wmin0 = vr0.lower_bound (); wide_int wmax0 = vr0.upper_bound (); @@ -688,7 +688,7 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) /* Similar to above, but a multiplication between successive additions. */ (simplify - (plus (mult:s (plus:s @0 INTEGER_CST@1) INTEGER_CST@2) INTEGER_CST@3) + (plus (mult:s (plus:s@4 @0 INTEGER_CST@1) INTEGER_CST@2) INTEGER_CST@3) (with { bool overflowed = true; wi::overflow_type ovf1; @@ -702,8 +702,8 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) #if GIMPLE int_range_max vr0; if (ovf1 == wi::OVF_NONE && ovf2 == wi::OVF_NONE - && get_global_range_query ()->range_of_expr (vr0, @0) - && !vr0.varying_p () && !vr0.undefined_p ()) + && gimple_match_range_of_expr (vr0, @0, @4) + && !vr0.varying_p ()) { wide_int wmin0 = vr0.lower_bound (); wide_int wmax0 = vr0.upper_bound (); @@ -918,7 +918,7 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) /* X % -Y is the same as X % Y. */ (simplify - (trunc_mod @0 (convert? (negate @1))) + (trunc_mod @0 (convert? (negate@2 @1))) (if (INTEGRAL_TYPE_P (type) && !TYPE_UNSIGNED (type) && !TYPE_OVERFLOW_TRAPS (type) @@ -928,7 +928,8 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) INT_MIN % -(-1) into invalid INT_MIN % -1. */ && (expr_not_equal_to (@0, wi::to_wide (TYPE_MIN_VALUE (type))) || expr_not_equal_to (@1, wi::minus_one (TYPE_PRECISION - (TREE_TYPE (@1)))))) + (TREE_TYPE (@1))), + gimple_match_ctx (@2)))) (trunc_mod @0 (convert @1)))) /* X - (X / Y) * Y is the same as X % Y. */ @@ -1016,15 +1017,15 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) (for div (trunc_div ceil_div floor_div round_div exact_div) /* Simplify (t * u) / u -> t. */ (simplify - (div (mult:c @0 @1) @1) + (div (mult:c@2 @0 @1) @1) (if (ANY_INTEGRAL_TYPE_P (type)) (if (TYPE_OVERFLOW_UNDEFINED (type) && !TYPE_OVERFLOW_SANITIZED (type)) @0 #if GIMPLE (with {int_range_max vr0, vr1;} (if (INTEGRAL_TYPE_P (type) - && get_range_query (cfun)->range_of_expr (vr0, @0) - && get_range_query (cfun)->range_of_expr (vr1, @1) + && gimple_match_range_of_expr (vr0, @0, @2) + && gimple_match_range_of_expr (vr1, @1, @2) && range_op_handler (MULT_EXPR).overflow_free_p (vr0, vr1)) @0)) #endif @@ -1032,30 +1033,30 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) #if GIMPLE /* Simplify (t * u) / v -> t * (u / v) if u is multiple of v. */ (simplify - (div (mult @0 INTEGER_CST@1) INTEGER_CST@2) + (div (mult@3 @0 INTEGER_CST@1) INTEGER_CST@2) (if (INTEGRAL_TYPE_P (type) && wi::multiple_of_p (wi::to_widest (@1), wi::to_widest (@2), SIGNED)) (if (TYPE_OVERFLOW_UNDEFINED (type) && !TYPE_OVERFLOW_SANITIZED (type)) (mult @0 (div! @1 @2)) (with {int_range_max vr0, vr1;} - (if (get_range_query (cfun)->range_of_expr (vr0, @0) - && get_range_query (cfun)->range_of_expr (vr1, @1) + (if (gimple_match_range_of_expr (vr0, @0, @3) + && gimple_match_range_of_expr (vr1, @1) && range_op_handler (MULT_EXPR).overflow_free_p (vr0, vr1)) (mult @0 (div! @1 @2)))) ))) #endif /* Simplify (t * u) / (t * v) -> (u / v) if u is multiple of v. */ (simplify - (div (mult @0 INTEGER_CST@1) (mult @0 INTEGER_CST@2)) + (div (mult@3 @0 INTEGER_CST@1) (mult @0 INTEGER_CST@2)) (if (INTEGRAL_TYPE_P (type) && wi::multiple_of_p (wi::to_widest (@1), wi::to_widest (@2), SIGNED)) (if (TYPE_OVERFLOW_UNDEFINED (type) && !TYPE_OVERFLOW_SANITIZED (type)) (div @1 @2) #if GIMPLE (with {int_range_max vr0, vr1, vr2;} - (if (get_range_query (cfun)->range_of_expr (vr0, @0) - && get_range_query (cfun)->range_of_expr (vr1, @1) - && get_range_query (cfun)->range_of_expr (vr2, @2) + (if (gimple_match_range_of_expr (vr0, @0, @3) + && gimple_match_range_of_expr (vr1, @1) + && gimple_match_range_of_expr (vr2, @2) && range_op_handler (MULT_EXPR).overflow_free_p (vr0, vr1) && range_op_handler (MULT_EXPR).overflow_free_p (vr0, vr2)) (div @1 @2))) @@ -1069,16 +1070,15 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) (div (plus:c@4 @0 (mult:c@3 @1 @2)) @2) (with {int_range_max vr0, vr1, vr2, vr3, vr4;} (if (INTEGRAL_TYPE_P (type) - && get_range_query (cfun)->range_of_expr (vr1, @1) - && get_range_query (cfun)->range_of_expr (vr2, @2) + && gimple_match_range_of_expr (vr1, @1, @3) + && gimple_match_range_of_expr (vr2, @2, @3) /* "N*M" doesn't overflow. */ && range_op_handler (MULT_EXPR).overflow_free_p (vr1, vr2) - && get_range_query (cfun)->range_of_expr (vr0, @0) - && get_range_query (cfun)->range_of_expr (vr3, @3) + && gimple_match_range_of_expr (vr0, @0, @4) + && gimple_match_range_of_expr (vr3, @3, @4) /* "X+(N*M)" doesn't overflow. */ && range_op_handler (PLUS_EXPR).overflow_free_p (vr0, vr3) - && get_range_query (cfun)->range_of_expr (vr4, @4) - && !vr4.undefined_p () + && gimple_match_range_of_expr (vr4, @4) /* "X+N*M" is not with opposite sign as "X". */ && (TYPE_UNSIGNED (type) || (vr0.nonnegative_p () && vr4.nonnegative_p ()) @@ -1090,16 +1090,15 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) (div (minus@4 @0 (mult:c@3 @1 @2)) @2) (with {int_range_max vr0, vr1, vr2, vr3, vr4;} (if (INTEGRAL_TYPE_P (type) - && get_range_query (cfun)->range_of_expr (vr1, @1) - && get_range_query (cfun)->range_of_expr (vr2, @2) + && gimple_match_range_of_expr (vr1, @1, @3) + && gimple_match_range_of_expr (vr2, @2, @3) /* "N * M" doesn't overflow. */ && range_op_handler (MULT_EXPR).overflow_free_p (vr1, vr2) - && get_range_query (cfun)->range_of_expr (vr0, @0) - && get_range_query (cfun)->range_of_expr (vr3, @3) + && gimple_match_range_of_expr (vr0, @0, @4) + && gimple_match_range_of_expr (vr3, @3, @4) /* "X - (N*M)" doesn't overflow. */ && range_op_handler (MINUS_EXPR).overflow_free_p (vr0, vr3) - && get_range_query (cfun)->range_of_expr (vr4, @4) - && !vr4.undefined_p () + && gimple_match_range_of_expr (vr4, @4) /* "X-N*M" is not with opposite sign as "X". */ && (TYPE_UNSIGNED (type) || (vr0.nonnegative_p () && vr4.nonnegative_p ()) @@ -1124,12 +1123,12 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) int_range_max vr0, vr1, vr3; } (if (INTEGRAL_TYPE_P (type) - && get_range_query (cfun)->range_of_expr (vr0, @0)) + && gimple_match_range_of_expr (vr0, @0, @3)) (if (exact_mod (c) - && get_range_query (cfun)->range_of_expr (vr1, @1) + && gimple_match_range_of_expr (vr1, @1) /* "X+C" doesn't overflow. */ && range_op_handler (PLUS_EXPR).overflow_free_p (vr0, vr1) - && get_range_query (cfun)->range_of_expr (vr3, @3) + && gimple_match_range_of_expr (vr3, @3) && !vr3.undefined_p () /* "X+C" and "X" are not of opposite sign. */ && (TYPE_UNSIGNED (type) @@ -1339,37 +1338,39 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) (if (INTEGRAL_TYPE_P (type)) (rshift (op @0 @2) @1)))) -/* (y << x) == x -> 0 when y != 0. */ -(simplify - (eq:c (nop_convert1? (lshift @0 @1)) (nop_convert2? @1)) - (if (INTEGRAL_TYPE_P (TREE_TYPE (@1)) - && tree_expr_nonzero_p (@0)) - { build_zero_cst (type); })) - -/* (y << x) {<,<=} x -> 0 when y > 0. */ -(for cmp (lt le) - (simplify - (cmp:c (nop_convert1? (lshift @0 @1)) (nop_convert2? @1)) - (if (INTEGRAL_TYPE_P (TREE_TYPE (@1)) - && tree_expr_nonzero_p (@0) - && tree_expr_nonnegative_p (@0)) - { build_zero_cst (type); }))) - -/* (y << x) != x -> 1 when y != 0. */ -(simplify - (ne:c (nop_convert1? (lshift @0 @1)) (nop_convert2? @1)) - (if (INTEGRAL_TYPE_P (TREE_TYPE (@1)) +/* (y << x) == x -> false and (y << x) != x -> true when y != 0. */ +(for cmp (eq ne) + (simplify + (cmp:c (nop_convert1? (lshift @0 @1)) (convert2? @1)) + (if (INTEGRAL_TYPE_P (TREE_TYPE (@0)) && tree_expr_nonzero_p (@0)) - { build_one_cst (type); })) + { constant_boolean_node (cmp != EQ_EXPR, type); }))) -/* (y << x) {>,>=} x -> 1 when y > 0. */ -(for cmp (gt ge) - (simplify - (cmp:c (nop_convert1? (lshift @0 @1)) (nop_convert2? @1)) - (if (INTEGRAL_TYPE_P (TREE_TYPE (@1)) - && tree_expr_nonzero_p (@0) - && tree_expr_nonnegative_p (@0)) - { build_one_cst (type); }))) +#if GIMPLE +/* (y << x) {<,<=} x -> false and (y << x) {>,>=} x -> true when y != 0 + and (y << x) >> x == y and for signed comparison (y << x) >= 0. */ +(for cmp (gt ge lt le) + (simplify + (cmp:c (nop_convert1?@3 (lshift@2 @0 @1)) (convert2? @1)) + (if (INTEGRAL_TYPE_P (TREE_TYPE (@0))) + (with { bool ok = false; + int_range_max vr0, vr1; + if (gimple_match_range_of_expr (vr0, @0, @2) + && !vr0.varying_p () + && gimple_match_range_of_expr (vr1, @1, @2) + && !vr1.varying_p () + && !vr0.contains_p (wi::zero (TYPE_PRECISION (TREE_TYPE (@0))))) + { + unsigned lz = wi::clz (vr0.get_nonzero_bits ()); + if (!wi::neg_p (vr1.upper_bound (), TYPE_SIGN (TREE_TYPE (@1))) + && wi::ltu_p (vr1.upper_bound (), + wi::uhwi (lz + TYPE_UNSIGNED (TREE_TYPE (@3)), + TYPE_PRECISION (TREE_TYPE (@1))))) + ok = true; + } } + (if (ok) + { constant_boolean_node (cmp == GT_EXPR || cmp == GE_EXPR, type); }))))) +#endif /* Fold (1 << (C - x)) where C = precision(type) - 1 into ((1 << C) >> x). */ @@ -3793,6 +3794,25 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) bool c2_is_type_precision_p = tree_to_uhwi (@2) == prec; } (if (c2_is_type_precision_p))))) + (match (unsigned_integer_sat_mul @0 @1) + /* SAT_U_MUL (X, Y) = { + WT x = (WT)a * (WT)b; + NT max = -1; + bool overflow_p = x > (WT)max; + return -(NT)(overflow_p) | (NT)x; + } while WT is uint128_t, uint64_t, uint32_t, uint16_t, + and T is uint64_t, uint32_t, uint16_t, uint8_t. */ + (bit_ior:c (negate (convert (gt @3 INTEGER_CST@2))) + (convert (usmul_widen_mult@3 @0 @1))) + (if (types_match (type, @0, @1)) + (with + { + unsigned prec = TYPE_PRECISION (type); + unsigned widen_prec = TYPE_PRECISION (TREE_TYPE (@3)); + wide_int max = wi::mask (prec, false, widen_prec); + bool c2_is_max_p = wi::eq_p (wi::to_wide (@2), max); + } + (if (c2_is_max_p))))) ) /* The boundary condition for case 10: IMM = 1: @@ -4432,7 +4452,7 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) /* ((T)(A)) + CST -> (T)(A + CST) */ #if GIMPLE (simplify - (plus (convert:s SSA_NAME@0) INTEGER_CST@1) + (plus (convert:s@2 SSA_NAME@0) INTEGER_CST@1) (if (TREE_CODE (TREE_TYPE (@0)) == INTEGER_TYPE && TREE_CODE (type) == INTEGER_TYPE && TYPE_PRECISION (type) > TYPE_PRECISION (TREE_TYPE (@0)) @@ -4450,8 +4470,7 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) TYPE_SIGN (inner_type)); int_range_max vr; - if (get_global_range_query ()->range_of_expr (vr, @0) - && !vr.varying_p () && !vr.undefined_p ()) + if (gimple_match_range_of_expr (vr, @0, @2) && !vr.varying_p ()) { wide_int wmin0 = vr.lower_bound (); wide_int wmax0 = vr.upper_bound (); @@ -4676,7 +4695,8 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) || TYPE_OVERFLOW_WRAPS (type) || (INTEGRAL_TYPE_P (type) && tree_expr_nonzero_p (@0) - && expr_not_equal_to (@0, wi::minus_one (TYPE_PRECISION (type))))) + && expr_not_equal_to (@0, wi::minus_one (TYPE_PRECISION (type)), + gimple_match_ctx (@3)))) (if (single_use (@3) || single_use (@4)) /* If @1 +- @2 is constant require a hard single-use on either original operand (but not on both). */ @@ -4696,16 +4716,19 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) || (INTEGRAL_TYPE_P (type) && ((tree_expr_nonzero_p (@0) && expr_not_equal_to (@0, - wi::minus_one (TYPE_PRECISION (type)))) + wi::minus_one (TYPE_PRECISION (type)), + gimple_match_ctx (@3))) || (plusminus == PLUS_EXPR ? expr_not_equal_to (@2, - wi::max_value (TYPE_PRECISION (type), SIGNED)) + wi::max_value (TYPE_PRECISION (type), SIGNED), + gimple_match_ctx (@3)) /* Let's ignore the @0 -1 and @2 min case. */ : (expr_not_equal_to (@2, - wi::min_value (TYPE_PRECISION (type), SIGNED)) + wi::min_value (TYPE_PRECISION (type), SIGNED), + gimple_match_ctx (@3)) && expr_not_equal_to (@2, wi::min_value (TYPE_PRECISION (type), SIGNED) - + 1)))))) + + 1, gimple_match_ctx (@3))))))) && single_use (@3)) (mult (plusminus { build_one_cst (type); } @2) @0))) (simplify @@ -4720,11 +4743,13 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) && ((tree_expr_nonzero_p (@0) && (plusminus == MINUS_EXPR || expr_not_equal_to (@0, - wi::minus_one (TYPE_PRECISION (type))))) + wi::minus_one (TYPE_PRECISION (type)), + gimple_match_ctx (@3)))) || expr_not_equal_to (@2, (plusminus == PLUS_EXPR ? wi::max_value (TYPE_PRECISION (type), SIGNED) - : wi::min_value (TYPE_PRECISION (type), SIGNED)))))) + : wi::min_value (TYPE_PRECISION (type), SIGNED)), + gimple_match_ctx (@3))))) && single_use (@3)) (mult (plusminus @2 { build_one_cst (type); }) @0))))) /* (A * B) + (-C) -> (B - C/A) * A, if C is a multiple of A. */ @@ -5325,7 +5350,8 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) (if (prec == wi::to_wide (@1)) (switch (if (expr_not_equal_to (@2, wi::uhwi (prec, - TYPE_PRECISION (TREE_TYPE (@2))))) + TYPE_PRECISION (TREE_TYPE (@2))), + gimple_match_ctx (@3))) (orotate @0 @2)) (if (single_use (@3) && pow2p_hwi (prec) @@ -6521,15 +6547,14 @@ DEFINE_INT_AND_FLOAT_ROUND_FN (RINT) This was originally done by two_value_replacement in phiopt (PR 88676). */ (for eqne (ne eq) (simplify - (cond (eqne SSA_NAME@0 INTEGER_CST@1) INTEGER_CST@2 INTEGER_CST@3) + (cond (eqne@4 SSA_NAME@0 INTEGER_CST@1) INTEGER_CST@2 INTEGER_CST@3) (if (INTEGRAL_TYPE_P (TREE_TYPE (@0)) && INTEGRAL_TYPE_P (type) && (wi::to_widest (@2) + 1 == wi::to_widest (@3) || wi::to_widest (@2) == wi::to_widest (@3) + 1)) (with { int_range_max r; - get_range_query (cfun)->range_of_expr (r, @0); - if (r.undefined_p ()) + if (!gimple_match_range_of_expr (r, @0, @4)) r.set_varying (TREE_TYPE (@0)); wide_int min = r.lower_bound (); diff --git a/gcc/omp-low.cc b/gcc/omp-low.cc index d36756e33a5a..6fd685cdecd3 100644 --- a/gcc/omp-low.cc +++ b/gcc/omp-low.cc @@ -13240,7 +13240,20 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx) unsigned HOST_WIDE_INT tkind2; switch (OMP_CLAUSE_CODE (c)) { - case OMP_CLAUSE_MAP: tkind2 = OMP_CLAUSE_MAP_KIND (c); break; + case OMP_CLAUSE_MAP: + tkind2 = OMP_CLAUSE_MAP_KIND (c); + if (OMP_CLAUSE_MAP_RUNTIME_IMPLICIT_P (c) + && (((tkind2 & GOMP_MAP_FLAG_SPECIAL_BITS) + & ~GOMP_MAP_IMPLICIT) + == 0)) + { + /* If this is an implicit map, and the GOMP_MAP_IMPLICIT + bits are not interfered by other special bit + encodings, then turn the GOMP_IMPLICIT_BIT flag on + for the runtime to see. */ + tkind2 |= GOMP_MAP_IMPLICIT; + } + break; case OMP_CLAUSE_FIRSTPRIVATE: tkind2 = GOMP_MAP_TO; break; case OMP_CLAUSE_TO: tkind2 = GOMP_MAP_TO; break; case OMP_CLAUSE_FROM: tkind2 = GOMP_MAP_FROM; break; diff --git a/gcc/optabs.cc b/gcc/optabs.cc index 10989a29c514..183ad910fcd7 100644 --- a/gcc/optabs.cc +++ b/gcc/optabs.cc @@ -4854,13 +4854,15 @@ emit_cmp_and_jump_insns (rtx x, rtx y, enum rtx_code comparison, rtx size, gimple *mask_def = NULL; tree rhs1 = gimple_assign_rhs1 (def_stmt); tree rhs2 = gimple_assign_rhs2 (def_stmt); - if ((mask_def = get_gimple_for_ssa_name (rhs1)) + if (TREE_CODE (rhs1) == SSA_NAME + && (mask_def = get_gimple_for_ssa_name (rhs1)) && is_gimple_assign (mask_def) && TREE_CODE_CLASS (gimple_assign_rhs_code (mask_def))) masked_op = rhs2; - else if ((mask_def = get_gimple_for_ssa_name (rhs2)) - && is_gimple_assign (mask_def) - && TREE_CODE_CLASS (gimple_assign_rhs_code (mask_def))) + else if (TREE_CODE (rhs2) == SSA_NAME + && (mask_def = get_gimple_for_ssa_name (rhs2)) + && is_gimple_assign (mask_def) + && TREE_CODE_CLASS (gimple_assign_rhs_code (mask_def))) masked_op = rhs1; if (masked_op) @@ -4890,20 +4892,24 @@ emit_cmp_and_jump_insns (rtx x, rtx y, enum rtx_code comparison, rtx size, len_bias = gimple_call_arg (call, 4); tree arg0 = gimple_call_arg (call, 0); - def_stmt = get_gimple_for_ssa_name (arg0); + if (TREE_CODE (arg0) == SSA_NAME) + def_stmt = get_gimple_for_ssa_name (arg0); } } enum insn_code icode; - if (is_gimple_assign (def_stmt) + if (def_stmt + && is_gimple_assign (def_stmt) && TREE_CODE_CLASS (gimple_assign_rhs_code (def_stmt)) == tcc_comparison) { class expand_operand ops[5]; rtx_insn *tmp = NULL; start_sequence (); - rtx op0c = expand_normal (gimple_assign_rhs1 (def_stmt)); - rtx op1c = expand_normal (gimple_assign_rhs2 (def_stmt)); + tree t_op0 = gimple_assign_rhs1 (def_stmt); + tree t_op1 = gimple_assign_rhs2 (def_stmt); + rtx op0c = expand_normal (t_op0); + rtx op1c = expand_normal (t_op1); machine_mode mode2 = GET_MODE (op0c); int nops = masked_op ? 3 : (len_op ? 5 : 2); @@ -4929,7 +4935,7 @@ emit_cmp_and_jump_insns (rtx x, rtx y, enum rtx_code comparison, rtx size, GET_MODE (len_bias_rtx)); } - int unsignedp2 = TYPE_UNSIGNED (TREE_TYPE (val)); + int unsignedp2 = TYPE_UNSIGNED (TREE_TYPE (t_op0)); auto inner_code = gimple_assign_rhs_code (def_stmt); rtx test2 = NULL_RTX; diff --git a/gcc/range-op.cc b/gcc/range-op.cc index 82a994b4ca55..fb7d4742bb6d 100644 --- a/gcc/range-op.cc +++ b/gcc/range-op.cc @@ -3848,9 +3848,12 @@ operator_bitwise_and::op1_range (irange &r, tree type, // extraneous values thats are not convered by the mask. wide_int op1_value = lhs_bm.value () & ~op1_mask; irange_bitmask op1_bm (op1_value, op1_mask); - // INtersect this mask with anything already known about the value. - op1_bm.intersect (r.get_bitmask ()); - r.update_bitmask (op1_bm); + // Intersect this mask with anything already known about the value. + // A return valueof false indicated the bitmask is an UNDEFINED range. + if (op1_bm.intersect (r.get_bitmask ())) + r.update_bitmask (op1_bm); + else + r.set_undefined (); return true; } diff --git a/gcc/regenerate-opt-urls.py b/gcc/regenerate-opt-urls.py index 2daa1d603f06..bda91905aceb 100755 --- a/gcc/regenerate-opt-urls.py +++ b/gcc/regenerate-opt-urls.py @@ -361,7 +361,8 @@ def write_url_file(index, optfile, dstfile): PER_LANGUAGE_OPTION_INDEXES = [ ('gcc/Option-Index.html', None), ('gdc/Option-Index.html', 'D'), - ('gfortran/Option-Index.html', 'Fortran') + ('gfortran/Option-Index.html', 'Fortran'), + ('ga68/Option-Index.html', 'Algol68'), ] def main(args): diff --git a/gcc/rust/ChangeLog b/gcc/rust/ChangeLog index e2d7fb86e3f0..ec4e2793ccc3 100644 --- a/gcc/rust/ChangeLog +++ b/gcc/rust/ChangeLog @@ -1,3 +1,121 @@ +2025-11-30 Andrew Pinski + + * lang.opt.urls: Regenerate. + +2025-11-27 Jakub Jelinek + + * lex/rust-lex.cc (rust_input_source_test): Cast char8_t string + literals to (const char *) to make it compilable with C++20. Use + char16_t or char32_t character literals instead of ordinary + character literals or wide character literals in expected + initializers. + +2025-11-27 Arthur Cohen + + * typecheck/rust-tyty-subst.h: Remove now useless inclusion. + * typecheck/rust-tyty.h (class TypeBoundPredicate): New, moved from rust-tyty-bounds.h + (class TypeBoundsMappings): Likewise. + * typecheck/rust-tyty-bounds.h: Removed. + +2025-11-25 Lúcio Boari Fleury + + * parse/rust-parse-impl.h: Add early exit condition to parsing loop. + +2025-11-25 Philip Herron + + * ast/rust-ast.cc (TraitItemType::as_string): add generic params + * ast/rust-ast.h: remove old comment + * ast/rust-item.h: add generic params to associated type + * ast/rust-type.h: remove old comment + * hir/rust-ast-lower-implitem.cc (ASTLowerTraitItem::visit): hir lowering for gat's + * hir/tree/rust-hir-item.cc (TraitItemType::TraitItemType): gat's on TraitItemType + (TraitItemType::operator=): preserve generic params + * hir/tree/rust-hir-item.h: likewise + * hir/tree/rust-hir.cc (TraitItemType::as_string): likewise + * parse/rust-parse-impl.h (Parser::parse_trait_type): hit the < and parse params + * typecheck/rust-hir-type-check-implitem.cc (TypeCheckImplItemWithTrait::visit): typecheck + * typecheck/rust-tyty.cc (BaseType::has_substitutions_defined): dont destructure + +2025-11-25 Lucas Ly Ba + + * expand/rust-derive.cc (DeriveVisitor::derive): + Add check and error. + +2025-11-25 Lucas Ly Ba + + * hir/rust-ast-lower-base.cc (ASTLoweringBase::handle_doc_item_attribute): Make error. + +2025-11-25 Yap Zhi Heng + + * backend/rust-compile-expr.cc (compile_float_literal): Add is_negative + check to compile negative float literals properly. + * backend/rust-compile-pattern.cc (CompilePatternCheckExpr::visit(RangePattern)): + Minor optimization to E0579 checks to reduce memory copy. + +2025-11-25 Owen Avery + + * checks/errors/feature/rust-feature-gate.cc + (FeatureGate::gate): Handle removal of Feature::create. + (FeatureGate::visit): Refer to AUTO_TRAITS as + OPTIN_BUILTIN_TRAITS. + * checks/errors/feature/rust-feature.cc (Feature::create): + Remove. + (Feature::feature_list): New static member variable. + (Feature::name_hash_map): Use "rust-feature-defs.h" to define. + (Feature::lookup): New member function definition. + * checks/errors/feature/rust-feature.h (Feature::State): Add + comments. + (Feature::Name): Use "rust-feature-defs.h" to define. + (Feature::as_string): Make const. + (Feature::name): Likewise. + (Feature::state): Likewise. + (Feature::issue): Likewise. + (Feature::description): Remove member function declaration. + (Feature::create): Remove static member function declaration. + (Feature::lookup): New member function declarations. + (Feature::Feature): Adjust arguments. + (Feature::m_rustc_since): Rename to... + (Feature::m_rust_since): ...here. + (Feature::m_description): Remove. + (Feature::m_reason): New member variable. + (Feature::feature_list): New static member variable. + * checks/errors/feature/rust-feature-defs.h: New file. + * checks/errors/feature/contrib/parse.y: New file. + * checks/errors/feature/contrib/scan.l: New file. + * checks/errors/feature/contrib/.gitignore: New file. + * checks/errors/feature/contrib/Makefile: New file. + * checks/errors/feature/contrib/fetch: New file. + * checks/errors/feature/contrib/regen: New file. + * checks/errors/feature/contrib/copyright-stub.h: New file. + * checks/errors/feature/contrib/README: New file. + +2025-11-25 Lucas Ly Ba + + * ast/rust-ast.cc (Attribute::check_cfg_predicate): Make error when attribute has no input. + +2025-11-25 Owen Avery + + * backend/rust-compile-expr.cc (CompileExpr::visit): Implicitly + convert LocalVariable to pointer to Bvariable. + * rust-backend.h (local_variable): Return LocalVariable. + (parameter_variable): Likewise. + (static_chain_variable): Likewise. + (temporary_variable): Likewise. + * rust-gcc.cc (local_variable): Likewise. + (parameter_variable): Likewise. + (static_chain_variable): Likewise. + (temporary_variable): Likewise. + (LocalVariable::get_tree): New function. + (LocalVariable::error_variable): Likewise. + * rust-gcc.h (class LocalVariable): New class. + +2025-11-25 lenny.chiadmi-delage + + * expand/rust-macro-expand.cc (transcribe_expression): Check if + parser didn't fail. + (transcribe_type): Likewise. + (transcribe_pattern): Likewise. + 2025-11-17 Philip Herron * typecheck/rust-hir-type-check-implitem.cc (TypeCheckImplItemWithTrait::visit): null guard diff --git a/gcc/rust/lang.opt.urls b/gcc/rust/lang.opt.urls index 33a54b4dea79..09cfede81436 100644 --- a/gcc/rust/lang.opt.urls +++ b/gcc/rust/lang.opt.urls @@ -1,7 +1,7 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/rust/lang.opt and generated HTML I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) L UrlSuffix(gcc/Directory-Options.html#index-L) LangUrlSuffix_D(gdc/Directory-Options.html#index-L) diff --git a/gcc/rust/lex/rust-lex.cc b/gcc/rust/lex/rust-lex.cc index 214161fcca61..a99b5ed1a348 100644 --- a/gcc/rust/lex/rust-lex.cc +++ b/gcc/rust/lex/rust-lex.cc @@ -2639,37 +2639,37 @@ void rust_input_source_test () { // ASCII - std::string src = u8"_abcde\tXYZ\v\f"; - std::vector expected - = {'_', 'a', 'b', 'c', 'd', 'e', '\t', 'X', 'Y', 'Z', '\v', '\f'}; + std::string src = (const char *) u8"_abcde\tXYZ\v\f"; + std::vector expected = {u'_', u'a', u'b', u'c', u'd', u'e', + u'\t', u'X', u'Y', u'Z', u'\v', u'\f'}; test_buffer_input_source (src, expected); // BOM - src = u8"\xef\xbb\xbfOK"; - expected = {'O', 'K'}; + src = (const char *) u8"\xef\xbb\xbfOK"; + expected = {u'O', u'K'}; test_buffer_input_source (src, expected); // Russian - src = u8"приве́т"; - expected = {L'п', - L'р', - L'и', - L'в', + src = (const char *) u8"приве́т"; + expected = {u'п', + u'р', + u'и', + u'в', 0x0435 /* CYRILLIC SMALL LETTER IE е */, 0x301 /* COMBINING ACUTE ACCENT ́ */, - L'т'}; + u'т'}; test_buffer_input_source (src, expected); - src = u8"❤️🦀"; + src = (const char *) u8"❤️🦀"; expected = {0x2764 /* HEAVY BLACK HEART */, - 0xfe0f /* VARIATION SELECTOR-16 */, L'🦀'}; + 0xfe0f /* VARIATION SELECTOR-16 */, U'🦀'}; test_buffer_input_source (src, expected); - src = u8"こんにちは"; - expected = {L'こ', L'ん', L'に', L'ち', L'は'}; + src = (const char *) u8"こんにちは"; + expected = {u'こ', u'ん', u'に', u'ち', u'は'}; test_file_input_source (src, expected); - src = u8"👮‍♂👩‍⚕"; + src = (const char *) u8"👮‍♂👩‍⚕"; expected = {0x1f46e /* POLICE OFFICER */, 0x200d /* ZERO WIDTH JOINER */, 0x2642 /* MALE SIGN */, 0x1f469 /* WOMAN */, diff --git a/gcc/rust/typecheck/rust-tyty-bounds.h b/gcc/rust/typecheck/rust-tyty-bounds.h deleted file mode 100644 index 6392af1fed4f..000000000000 --- a/gcc/rust/typecheck/rust-tyty-bounds.h +++ /dev/null @@ -1,66 +0,0 @@ -// Copyright (C) 2020-2025 Free Software Foundation, Inc. - -// This file is part of GCC. - -// GCC is free software; you can redistribute it and/or modify it under -// the terms of the GNU General Public License as published by the Free -// Software Foundation; either version 3, or (at your option) any later -// version. - -// GCC is distributed in the hope that it will be useful, but WITHOUT ANY -// WARRANTY; without even the implied warranty of MERCHANTABILITY or -// FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -// for more details. - -// You should have received a copy of the GNU General Public License -// along with GCC; see the file COPYING3. If not see -// . - -#ifndef RUST_TYTY_BOUNDS_H -#define RUST_TYTY_BOUNDS_H - -#include "rust-location.h" -#include "rust-mapping-common.h" - -namespace Rust { - -namespace Resolver { -class TraitReference; -class TraitItemReference; -class AssociatedImplTrait; -} // namespace Resolver - -namespace TyTy { - -class BaseType; -class TypeBoundPredicate; -class TypeBoundsMappings -{ -protected: - TypeBoundsMappings (std::vector specified_bounds); - -public: - std::vector &get_specified_bounds (); - - const std::vector &get_specified_bounds () const; - - TypeBoundPredicate lookup_predicate (DefId id); - - size_t num_specified_bounds () const; - - std::string raw_bounds_as_string () const; - - std::string bounds_as_string () const; - - std::string raw_bounds_as_name () const; - -protected: - void add_bound (TypeBoundPredicate predicate); - - std::vector specified_bounds; -}; - -} // namespace TyTy -} // namespace Rust - -#endif // RUST_TYTY_BOUNDS_H diff --git a/gcc/rust/typecheck/rust-tyty-subst.h b/gcc/rust/typecheck/rust-tyty-subst.h index c1bc96a7f8a5..d09e180147a1 100644 --- a/gcc/rust/typecheck/rust-tyty-subst.h +++ b/gcc/rust/typecheck/rust-tyty-subst.h @@ -22,7 +22,6 @@ #include "rust-system.h" #include "rust-location.h" #include "rust-hir-full-decls.h" -#include "rust-tyty-bounds.h" #include "rust-tyty-region.h" #include "rust-ast.h" #include "optional.h" diff --git a/gcc/rust/typecheck/rust-tyty.h b/gcc/rust/typecheck/rust-tyty.h index ed3cd76807cd..50f6347e33f7 100644 --- a/gcc/rust/typecheck/rust-tyty.h +++ b/gcc/rust/typecheck/rust-tyty.h @@ -24,7 +24,6 @@ #include "rust-common.h" #include "rust-identifier.h" #include "rust-abi.h" -#include "rust-tyty-bounds.h" #include "rust-tyty-util.h" #include "rust-tyty-subst.h" #include "rust-tyty-region.h" @@ -92,6 +91,127 @@ class TypeKindFormat class TyVisitor; class TyConstVisitor; class BaseConstType; + +class TypeBoundPredicate : public SubstitutionRef +{ +public: + TypeBoundPredicate (const Resolver::TraitReference &trait_reference, + BoundPolarity polarity, location_t locus); + + TypeBoundPredicate (DefId reference, + std::vector substitutions, + BoundPolarity polarity, location_t locus); + + TypeBoundPredicate (const TypeBoundPredicate &other); + + virtual ~TypeBoundPredicate () {} + + TypeBoundPredicate &operator= (const TypeBoundPredicate &other); + + static TypeBoundPredicate error (); + + std::string as_string () const; + + std::string as_name () const; + + const Resolver::TraitReference *get () const; + + location_t get_locus () const { return locus; } + + std::string get_name () const; + + // check that this is object-safe see: + // https://doc.rust-lang.org/reference/items/traits.html#object-safety + bool is_object_safe (bool emit_error, location_t locus) const; + + void apply_generic_arguments (HIR::GenericArgs *generic_args, + bool has_associated_self, bool is_super_trait); + + void apply_argument_mappings (SubstitutionArgumentMappings &arguments, + bool is_super_trait); + + bool contains_item (const std::string &search) const; + + tl::optional + lookup_associated_item (const std::string &search) const; + + tl::optional + lookup_associated_item (const Resolver::TraitItemReference *ref) const; + + // WARNING THIS WILL ALWAYS RETURN NULLPTR + BaseType * + handle_substitions (SubstitutionArgumentMappings &mappings) override final; + + bool is_error () const; + + bool requires_generic_args () const; + + bool contains_associated_types () const; + + DefId get_id () const { return reference; } + + BoundPolarity get_polarity () const { return polarity; } + + std::vector get_associated_type_items (); + + size_t get_num_associated_bindings () const override final; + + TypeBoundPredicateItem + lookup_associated_type (const std::string &search) override final; + + bool is_equal (const TypeBoundPredicate &other) const; + + bool validate_type_implements_super_traits (TyTy::BaseType &self, + HIR::Type &impl_type, + HIR::Type &trait) const; + + bool validate_type_implements_this (TyTy::BaseType &self, + HIR::Type &impl_type, + HIR::Type &trait) const; + +private: + struct mark_is_error + { + }; + + TypeBoundPredicate (mark_is_error); + + void get_trait_hierachy ( + std::function callback) const; + + DefId reference; + location_t locus; + bool error_flag; + BoundPolarity polarity; + std::vector super_traits; +}; + +class TypeBoundsMappings +{ +protected: + TypeBoundsMappings (std::vector specified_bounds); + +public: + std::vector &get_specified_bounds (); + + const std::vector &get_specified_bounds () const; + + TypeBoundPredicate lookup_predicate (DefId id); + + size_t num_specified_bounds () const; + + std::string raw_bounds_as_string () const; + + std::string bounds_as_string () const; + + std::string raw_bounds_as_name () const; + +protected: + void add_bound (TypeBoundPredicate predicate); + + std::vector specified_bounds; +}; + class BaseType : public TypeBoundsMappings { public: @@ -671,100 +791,6 @@ class TupleType : public BaseType std::vector fields; }; -class TypeBoundPredicate : public SubstitutionRef -{ -public: - TypeBoundPredicate (const Resolver::TraitReference &trait_reference, - BoundPolarity polarity, location_t locus); - - TypeBoundPredicate (DefId reference, - std::vector substitutions, - BoundPolarity polarity, location_t locus); - - TypeBoundPredicate (const TypeBoundPredicate &other); - - virtual ~TypeBoundPredicate () {} - - TypeBoundPredicate &operator= (const TypeBoundPredicate &other); - - static TypeBoundPredicate error (); - - std::string as_string () const; - - std::string as_name () const; - - const Resolver::TraitReference *get () const; - - location_t get_locus () const { return locus; } - - std::string get_name () const; - - // check that this is object-safe see: - // https://doc.rust-lang.org/reference/items/traits.html#object-safety - bool is_object_safe (bool emit_error, location_t locus) const; - - void apply_generic_arguments (HIR::GenericArgs *generic_args, - bool has_associated_self, bool is_super_trait); - - void apply_argument_mappings (SubstitutionArgumentMappings &arguments, - bool is_super_trait); - - bool contains_item (const std::string &search) const; - - tl::optional - lookup_associated_item (const std::string &search) const; - - tl::optional - lookup_associated_item (const Resolver::TraitItemReference *ref) const; - - // WARNING THIS WILL ALWAYS RETURN NULLPTR - BaseType * - handle_substitions (SubstitutionArgumentMappings &mappings) override final; - - bool is_error () const; - - bool requires_generic_args () const; - - bool contains_associated_types () const; - - DefId get_id () const { return reference; } - - BoundPolarity get_polarity () const { return polarity; } - - std::vector get_associated_type_items (); - - size_t get_num_associated_bindings () const override final; - - TypeBoundPredicateItem - lookup_associated_type (const std::string &search) override final; - - bool is_equal (const TypeBoundPredicate &other) const; - - bool validate_type_implements_super_traits (TyTy::BaseType &self, - HIR::Type &impl_type, - HIR::Type &trait) const; - - bool validate_type_implements_this (TyTy::BaseType &self, - HIR::Type &impl_type, - HIR::Type &trait) const; - -private: - struct mark_is_error - { - }; - - TypeBoundPredicate (mark_is_error); - - void get_trait_hierachy ( - std::function callback) const; - - DefId reference; - location_t locus; - bool error_flag; - BoundPolarity polarity; - std::vector super_traits; -}; - class TypeBoundPredicateItem { public: diff --git a/gcc/simplify-rtx.cc b/gcc/simplify-rtx.cc index 86baeb06ad48..3aaabdc9b055 100644 --- a/gcc/simplify-rtx.cc +++ b/gcc/simplify-rtx.cc @@ -4193,6 +4193,13 @@ simplify_context::simplify_binary_operation_1 (rtx_code code, and no precision is lost. */ if (SUBREG_P (op0) && subreg_lowpart_p (op0) && GET_CODE (XEXP (op0, 0)) == LSHIFTRT + /* simplify_subreg asserts the object being accessed is not + VOIDmode or BLKmode. We may have a REG_EQUAL note which + is not simplified and the source operand is a constant, + and thus VOIDmode. Guard against that. */ + && GET_MODE (XEXP (XEXP (op0, 0), 0)) != VOIDmode + && GET_MODE (XEXP (XEXP (op0, 0), 0)) != BLKmode + && !CONST_INT_P (XEXP (XEXP (op0, 0), 0)) && CONST_INT_P (XEXP (XEXP (op0, 0), 1)) && INTVAL (XEXP (XEXP (op0, 0), 1)) >= 0 && INTVAL (XEXP (XEXP (op0, 0), 1)) < HOST_BITS_PER_WIDE_INT diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7ec9f42ea3a9..47dbf0ffb821 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,1263 @@ +2025-11-30 Kugan Vivekanandarajah + + * gcc.dg/vect/tsvc/vect-tsvc-s293.c: Remove xfail. + * gcc.target/aarch64/vect-ld1r-compile.c: Add + -fno-tree-loop-distribute-patterns to prevent memset detection. + +2025-11-30 Jose E. Marchesi + + PR fortran/122923 + * gfortran.dg/ISO_Fortran_binding_17.f90: Recognize language + list in warning regexp. + * gfortran.dg/c-interop/allocate-errors.f90: Likewise. + * gfortran.dg/c-interop/establish-errors.f90: Likewise. + * gfortran.dg/c-interop/pr113338.f90: Likewise. + * gfortran.dg/c-interop/section-errors.f90: Likewise. + * gfortran.dg/c-interop/select-errors.f90: Likewise. + * gfortran.dg/c-interop/setpointer-errors.f90: Likewise. + +2025-11-30 Jakub Jelinek + + PR c++/122465 + * g++.dg/cpp0x/pr122465.C: New test. + +2025-11-30 Tamar Christina + + PR tree-optimization/115120 + PR tree-optimization/119577 + PR tree-optimization/119860 + * gcc.dg/vect/vect-early-break_39.c: Update. + * gcc.dg/vect/vect-early-break_139.c: New testcase. + * gcc.target/aarch64/sve/peel_ind_10.c: Update. + * gcc.target/aarch64/sve/peel_ind_11.c: Update. + * gcc.target/aarch64/sve/peel_ind_12.c: Update. + * gcc.target/aarch64/sve/peel_ind_5.c: Update. + * gcc.target/aarch64/sve/peel_ind_6.c: Update. + * gcc.target/aarch64/sve/peel_ind_7.c: Update. + * gcc.target/aarch64/sve/peel_ind_9.c: Update. + * gcc.target/aarch64/sve/pr119351.c + +2025-11-30 Jose E. Marchesi + + * algol68/compile/mcgt-1.3b.a68: New file. + * algol68/compile/mcgt-7.1.3a-bis.a68: Likewise. + * algol68/compile/mcgt-7.1.3a.a68: Likewise. + * algol68/execute/mcgt/execute.exp: Likewise. + * algol68/execute/mcgt/mcgt-1.3a.a68: Likewise. + * algol68/execute/mcgt/mcgt-1.3c.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.2.1a.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.2.2a.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.2.3a.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.3a.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.3b.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.3c.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.3e.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.4.2a.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.4.2b.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.4.2c.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.4.3a.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.6a.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.6b.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.7d.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.7e.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.8a.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.8b.a68: Likewise. + * algol68/execute/mcgt/mcgt-2.9.1a.a68: Likewise. + * algol68/execute/mcgt/mcgt-3.5.1a.a68: Likewise. + * algol68/execute/mcgt/mcgt-3.5d.a68: Likewise. + * algol68/execute/mcgt/mcgt-3.7.2a.a68: Likewise. + * algol68/execute/mcgt/mcgt-3.8.2a.a68: Likewise. + * algol68/execute/mcgt/mcgt-3.9.1b.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.1.2a.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.1.3a.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.1.6a.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.1.6b.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.1.6c.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.2.6a.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.2.6b.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.2.6d.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.3.1a.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.3.1b.a68: Likewise. + * algol68/execute/mcgt/mcgt-4.3.2a.a68: Likewise. + * algol68/execute/mcgt/mcgt-5.1.2a.a68: Likewise. + * algol68/execute/mcgt/mcgt-5.1.3a.a68: Likewise. + * algol68/execute/mcgt/mcgt-5.1.3c.a68: Likewise. + * algol68/execute/mcgt/mcgt-5.1.5a.a68: Likewise. + * algol68/execute/mcgt/mcgt-6.2.2a.a68: Likewise. + * algol68/execute/mcgt/mcgt-6.2.2b.a68: Likewise. + * algol68/execute/mcgt/mcgt-6.2.2c.a68: Likewise. + * algol68/execute/mcgt/mcgt-7.1.1a.a68: Likewise. + * algol68/execute/mcgt/mcgt-7.1.1b.a68: Likewise. + * algol68/execute/mcgt/mcgt-7.1.3a.a68: Likewise. + * algol68/execute/mcgt/mcgt-7.3.2a.a68: Likewise. + * algol68/execute/mcgt/mcgt-7.3.6a.a68: Likewise. + * algol68/execute/mcgt/mcgt-7.3.6b.a68: Likewise. + * algol68/execute/mcgt/mcgt-7.5.3a.a68: Likewise. + +2025-11-30 Jose E. Marchesi + + * algol68/README.mcts: New file. + +2025-11-30 Jose E. Marchesi + + * algol68/compile/a68includes/goodbye-supper.a68 + * algol68/compile/a68includes/goodbye.a68: Likewise. + * algol68/compile/a68includes/hello-supper.a68: Likewise. + * algol68/compile/a68includes/hello.a68: Likewise. + * algol68/compile/actual-bounds-expected-1.a68: Likewise. + * algol68/compile/actual-bounds-expected-2.a68: Likewise. + * algol68/compile/actual-bounds-expected-3.a68: Likewise. + * algol68/compile/balancing-1.a68: Likewise. + * algol68/compile/bold-nestable-comment-1.a68: Likewise. + * algol68/compile/bold-taggle-1.a68: Likewise. + * algol68/compile/brief-nestable-comment-1.a68: Likewise. + * algol68/compile/brief-nestable-comment-2.a68: Likewise. + * algol68/compile/char-break-1.a68: Likewise. + * algol68/compile/compile.exp: Likewise. + * algol68/compile/conditional-clause-1.a68: Likewise. + * algol68/compile/error-bold-taggle-1.a68: Likewise. + * algol68/compile/error-coercion-1.a68: Likewise. + * algol68/compile/error-coercion-2.a68: Likewise. + * algol68/compile/error-coercion-flex-1.a68: Likewise. + * algol68/compile/error-conformance-clause-1.a68: Likewise. + * algol68/compile/error-contraction-1.a68: Likewise. + * algol68/compile/error-contraction-2.a68: Likewise. + * algol68/compile/error-incestuous-union-1.a68: Likewise. + * algol68/compile/error-label-after-decl-1.a68: Likewise. + * algol68/compile/error-nestable-comments-1.a68: Likewise. + * algol68/compile/error-nested-comment-1.a68: Likewise. + * algol68/compile/error-no-bounds-allowed-1.a68: Likewise. + * algol68/compile/error-string-break-1.a68: Likewise. + * algol68/compile/error-string-break-2.a68: Likewise. + * algol68/compile/error-string-break-3.a68: Likewise. + * algol68/compile/error-string-break-4.a68: Likewise. + * algol68/compile/error-string-break-5.a68: Likewise. + * algol68/compile/error-string-break-6.a68: Likewise. + * algol68/compile/error-string-break-7.a68: Likewise. + * algol68/compile/error-supper-1.a68: Likewise. + * algol68/compile/error-supper-2.a68: Likewise. + * algol68/compile/error-supper-3.a68: Likewise. + * algol68/compile/error-supper-4.a68: Likewise. + * algol68/compile/error-supper-5.a68: Likewise. + * algol68/compile/error-supper-6.a68: Likewise. + * algol68/compile/error-underscore-in-mode-1.a68: Likewise. + * algol68/compile/error-underscore-in-tag-1.a68: Likewise. + * algol68/compile/error-upper-1.a68: Likewise. + * algol68/compile/error-widening-1.a68: Likewise. + * algol68/compile/error-widening-2.a68: Likewise. + * algol68/compile/error-widening-3.a68: Likewise. + * algol68/compile/error-widening-4.a68: Likewise. + * algol68/compile/error-widening-5.a68: Likewise. + * algol68/compile/error-widening-6.a68: Likewise. + * algol68/compile/error-widening-7.a68: Likewise. + * algol68/compile/error-widening-8.a68: Likewise. + * algol68/compile/error-widening-9.a68: Likewise. + * algol68/compile/hidden-operators-1.a68: Likewise. + * algol68/compile/implicit-widening-1.a68: Likewise. + * algol68/compile/include-supper.a68: Likewise. + * algol68/compile/include.a68: Likewise. + * algol68/compile/labeled-unit-1.a68: Likewise. + * algol68/compile/nested-comment-1.a68: Likewise. + * algol68/compile/nested-comment-2.a68: Likewise. + * algol68/compile/operators-firmly-related.a68: Likewise. + * algol68/compile/recursive-modes-1.a68: Likewise. + * algol68/compile/recursive-modes-2.a68: Likewise. + * algol68/compile/serial-clause-jump-1.a68: Likewise. + * algol68/compile/snobol.a68: Likewise. + * algol68/compile/supper-1.a68: Likewise. + * algol68/compile/supper-10.a68: Likewise. + * algol68/compile/supper-11.a68: Likewise. + * algol68/compile/supper-12.a68: Likewise. + * algol68/compile/supper-13.a68: Likewise. + * algol68/compile/supper-2.a68: Likewise. + * algol68/compile/supper-3.a68: Likewise. + * algol68/compile/supper-4.a68: Likewise. + * algol68/compile/supper-5.a68: Likewise. + * algol68/compile/supper-6.a68: Likewise. + * algol68/compile/supper-7.a68: Likewise. + * algol68/compile/supper-8.a68: Likewise. + * algol68/compile/supper-9.a68: Likewise. + * algol68/compile/uniting-1.a68: Likewise. + * algol68/compile/upper-1.a68: Likewise. + * algol68/compile/warning-scope-1.a68: Likewise. + * algol68/compile/warning-scope-2.a68: Likewise. + * algol68/compile/warning-scope-3.a68: Likewise. + * algol68/compile/warning-scope-4.a68: Likewise. + * algol68/compile/warning-scope-5.a68: Likewise. + * algol68/compile/warning-scope-6.a68: Likewise. + * algol68/compile/warning-scope-7.a68: Likewise. + * algol68/compile/warning-voiding-1.a68: Likewise. + * algol68/compile/warning-voiding-2.a68: Likewise. + * algol68/compile/error-compile-unknown-tag-1.a68: New file. + * algol68/compile/error-def-1.a68: New file. + * algol68/compile/error-mode-stropping-1.a68: New file. + * algol68/compile/error-mode-stropping-10.a68: New file. + * algol68/compile/error-mode-stropping-11.a68: New file. + * algol68/compile/error-mode-stropping-12.a68: New file. + * algol68/compile/error-mode-stropping-13.a68: New file. + * algol68/compile/error-mode-stropping-14.a68: New file. + * algol68/compile/error-mode-stropping-15.a68: New file. + * algol68/compile/error-mode-stropping-16.a68: New file. + * algol68/compile/error-mode-stropping-17.a68: New file. + * algol68/compile/error-mode-stropping-2.a68: New file. + * algol68/compile/error-mode-stropping-3.a68: New file. + * algol68/compile/error-mode-stropping-4.a68: New file. + * algol68/compile/error-mode-stropping-5.a68: New file. + * algol68/compile/error-mode-stropping-6.a68: New file. + * algol68/compile/error-mode-stropping-8.a68: New file. + * algol68/compile/error-mode-stropping-9.a68: New file. + * algol68/compile/error-module-coercions-1.a68: New file. + * algol68/compile/error-module-not-found-1.a68: New file. + * algol68/compile/error-module-ranges-1.a68: New file. + * algol68/compile/error-pragmat-1.a68: New file. + * algol68/compile/error-pragmat-access-1.a68: New file. + * algol68/compile/error-pragmat-access-2.a68: New file. + * algol68/compile/error-pub-loc-1.a68: New file. + * algol68/compile/error-pub-out-of-def-1.a68: New file. + * algol68/compile/error-pub-out-of-def-2.a68: New file. + * algol68/compile/error-string-break-8.a68: New file. + * algol68/compile/error-stropping-5.a68: New file. + * algol68/compile/error-stropping-6.a68: New file. + * algol68/compile/error-stropping-keyword-1.a68: New file. + * algol68/compile/error-stropping-keyword-2.a68: New file. + * algol68/compile/error-stropping-keyword-3.a68: New file. + * algol68/compile/error-stropping-keyword-4.a68: New file. + * algol68/compile/error-vacuum-1.a68: New file. + * algol68/compile/error-vacuum-2.a68: New file. + * algol68/compile/error-vacuum-3.a68: New file. + * algol68/compile/module-1.a68: New file. + * algol68/compile/module-2.a68: New file. + * algol68/compile/module-extracts-1.a68: New file. + * algol68/compile/module-mode-exports-1.a68: New file. + * algol68/compile/module-mode-exports-2.a68: New file. + * algol68/compile/module-mode-exports-3.a68: New file. + * algol68/compile/module-mode-exports-4.a68: New file. + * algol68/compile/module-mode-exports-5.a68: New file. + * algol68/compile/module-mode-exports-6.a68: New file. + * algol68/compile/module-mode-exports-7.a68: New file. + * algol68/compile/module-mode-exports-8.a68: New file. + * algol68/compile/module-mode-exports-9.a68: New file. + * algol68/compile/module-pub-1.a68: New file. + * algol68/compile/module-pub-mangling-1.a68: New file. + * algol68/compile/module-pub-mangling-10.a68: New file. + * algol68/compile/module-pub-mangling-11.a68: New file. + * algol68/compile/module-pub-mangling-12.a68: New file. + * algol68/compile/module-pub-mangling-13.a68: New file. + * algol68/compile/module-pub-mangling-14.a68: New file. + * algol68/compile/module-pub-mangling-15.a68: New file. + * algol68/compile/module-pub-mangling-16.a68: New file. + * algol68/compile/module-pub-mangling-17.a68: New file. + * algol68/compile/module-pub-mangling-18.a68: New file. + * algol68/compile/module-pub-mangling-19.a68: New file. + * algol68/compile/module-pub-mangling-2.a68: New file. + * algol68/compile/module-pub-mangling-20.a68: New file. + * algol68/compile/module-pub-mangling-21.a68: New file. + * algol68/compile/module-pub-mangling-22.a68: New file. + * algol68/compile/module-pub-mangling-3.a68: New file. + * algol68/compile/module-pub-mangling-4.a68: New file. + * algol68/compile/module-pub-mangling-5.a68: New file. + * algol68/compile/module-pub-mangling-6.a68: New file. + * algol68/compile/module-pub-mangling-7.a68: New file. + * algol68/compile/module-pub-mangling-8.a68: New file. + * algol68/compile/module-pub-mangling-9.a68: New file. + * algol68/compile/module-top-down-1.a68: New file. + * algol68/compile/modules/compile.exp: New file. + * algol68/compile/modules/module1.a68: New file. + * algol68/compile/modules/module2.a68: New file. + * algol68/compile/modules/module3.a68: New file. + * algol68/compile/modules/module4.a68: New file. + * algol68/compile/modules/module5.a68: New file. + * algol68/compile/modules/module6.a68: New file. + * algol68/compile/modules/module7.a68: New file. + * algol68/compile/modules/module8.a68: New file. + * algol68/compile/modules/module9.a68: New file. + * algol68/compile/modules/program-7.a68: New file. + * algol68/compile/modules/program-8.a68: New file. + * algol68/compile/modules/program-9.a68: New file. + * algol68/compile/modules/program-error-no-prio-1.a68: New file. + * algol68/compile/modules/program-error-outside-access-1.a68: New file. + * algol68/compile/modules/program-module-accesses-module-1.a68: New file. + * algol68/compile/modules/program-proc-arg-order-1.a68: New file. + * algol68/compile/warning-hidding-1.a68: New file. + * algol68/compile/warning-hidding-2.a68: New file. + * algol68/compile/warning-hidding-3.a68: New file. + * algol68/compile/warning-hidding-4.a68: New file. + * algol68/compile/warning-hidding-5.a68: New file. + * algol68/compile/warning-hidding-6.a68: New file. + * algol68/compile/warning-hidding-7.a68: New file. + * algol68/compile/warning-module-hidding-1.a68: New file. + * algol68/compile/warning-pub-loc-1.a68: New file. + +2025-11-30 Jose E. Marchesi + + * algol68/execute/loop-7.a68: New file. + * algol68/execute/loop-8.a68: Likewise. + * algol68/execute/loop-9.a68: Likewise. + * algol68/execute/loop-overflow-underflow.a68: Likewise. + * algol68/execute/lt-int-1.a68: Likewise. + * algol68/execute/lt-string-stride-1.a68: Likewise. + * algol68/execute/lwb-1.a68: Likewise. + * algol68/execute/minus-int-1.a68: Likewise. + * algol68/execute/minusab-1.a68: Likewise. + * algol68/execute/minusab-2.a68: Likewise. + * algol68/execute/minusab-3.a68: Likewise. + * algol68/execute/minusab-4.a68: Likewise. + * algol68/execute/mod-int-1.a68: Likewise. + * algol68/execute/modab-1.a68: Likewise. + * algol68/execute/modab-2.a68: Likewise. + * algol68/execute/mode-indication-1.a68: Likewise. + * algol68/execute/mult-char-1.a68: Likewise. + * algol68/execute/mult-int-1.a68: Likewise. + * algol68/execute/mult-string-1.a68: Likewise. + * algol68/execute/mult-string-2.a68: Likewise. + * algol68/execute/mult-string-3.a68: Likewise. + * algol68/execute/mult-string-4.a68: Likewise. + * algol68/execute/multab-1.a68: Likewise. + * algol68/execute/multab-2.a68: Likewise. + * algol68/execute/multab-3.a68: Likewise. + * algol68/execute/mutual-recursion-1.a68: Likewise. + * algol68/execute/ne-bits-1.a68: Likewise. + * algol68/execute/ne-char-char-1.a68: Likewise. + * algol68/execute/ne-int-1.a68: Likewise. + * algol68/execute/ne-string-1.a68: Likewise. + * algol68/execute/neg-int-1.a68: Likewise. + * algol68/execute/not-bits-1.a68: Likewise. + * algol68/execute/odd-1.a68: Likewise. + * algol68/execute/op-1.a68: Likewise. + * algol68/execute/op-2.a68: Likewise. + * algol68/execute/op-3.a68: Likewise. + * algol68/execute/operator-declaration-1.a68: Likewise. + * algol68/execute/or-bits-1.a68: Likewise. + * algol68/execute/orf-1.a68: Likewise. + * algol68/execute/over-int-1.a68: Likewise. + * algol68/execute/overab-1.a68: Likewise. + * algol68/execute/overab-2.a68: Likewise. + * algol68/execute/particular-program-1.a68: Likewise. + * algol68/execute/plus-char-1.a68: Likewise. + * algol68/execute/plus-int-1.a68: Likewise. + * algol68/execute/plus-string-1.a68: Likewise. + * algol68/execute/plus-string-2.a68: Likewise. + * algol68/execute/plus-string-stride-1.a68: Likewise. + * algol68/execute/plusab-1.a68: Likewise. + * algol68/execute/plusab-2.a68: Likewise. + * algol68/execute/plusab-3.a68: Likewise. + * algol68/execute/plusab-4.a68: Likewise. + * algol68/execute/plusab-string-1.a68: Likewise. + * algol68/execute/plusto-char-1.a68: Likewise. + * algol68/execute/plusto-string-1.a68: Likewise. + * algol68/execute/posix-argc-argv-1.a68: Likewise. + * algol68/execute/posix-fopen-1.a68: Likewise. + * algol68/execute/posix-fputc-fputs-1.a68: Likewise. + * algol68/execute/posix-getenv-1.a68: Likewise. + * algol68/execute/posix-perror-1.a68: Likewise. + * algol68/execute/posix-putchar-1.a68: Likewise. + * algol68/execute/posix-stdinouterr-1.a68: Likewise. + * algol68/execute/posix-strerror-1.a68: Likewise. + * algol68/execute/posix-stride-1.a68: Likewise. + * algol68/execute/pow-int-1.a68: Likewise. + * algol68/execute/pow-real-1.a68: Likewise. + * algol68/execute/proc-1.a68: Likewise. + * algol68/execute/proc-10.a68: Likewise. + * algol68/execute/proc-12.a68: Likewise. + * algol68/execute/proc-13.a68: Likewise. + * algol68/execute/proc-14.a68: Likewise. + * algol68/execute/proc-15.a68: Likewise. + * algol68/execute/proc-16.a68: Likewise. + * algol68/execute/proc-17.a68: Likewise. + * algol68/execute/proc-18.a68: Likewise. + * algol68/execute/proc-19.a68: Likewise. + * algol68/execute/proc-2.a68: Likewise. + * algol68/execute/proc-20.a68: Likewise. + * algol68/execute/proc-21.a68: Likewise. + * algol68/execute/proc-22.a68: Likewise. + * algol68/execute/proc-23.a68: Likewise. + * algol68/execute/proc-25.a68: Likewise. + * algol68/execute/proc-26.a68: Likewise. + * algol68/execute/proc-27.a68: Likewise. + * algol68/execute/proc-28.a68: Likewise. + * algol68/execute/proc-29.a68: Likewise. + * algol68/execute/proc-3.a68: Likewise. + * algol68/execute/proc-4.a68: Likewise. + * algol68/execute/proc-5.a68: Likewise. + * algol68/execute/proc-6.a68: Likewise. + * algol68/execute/proc-7.a68: Likewise. + * algol68/execute/proc-8.a68: Likewise. + * algol68/execute/procedured-goto-1.a68: Likewise. + * algol68/execute/quine.a68: Likewise. + * algol68/execute/random-1.a68: Likewise. + * algol68/execute/re-im-1.a68: Likewise. + * algol68/execute/rela-string-1.a68: Likewise. + * algol68/execute/repr-1.a68: Likewise. + * algol68/execute/round-1.a68: Likewise. + * algol68/execute/row-display-1.a68: Likewise. + * algol68/execute/row-display-2.a68: Likewise. + * algol68/execute/row-display-3.a68: Likewise. + * algol68/execute/row-display-4.a68: Likewise. + * algol68/execute/row-display-5.a68: Likewise. + * algol68/execute/rowing-1.a68: Likewise. + * algol68/execute/rowing-10.a68: Likewise. + * algol68/execute/rowing-11.a68: Likewise. + * algol68/execute/rowing-12.a68: Likewise. + * algol68/execute/rowing-13.a68: Likewise. + * algol68/execute/rowing-2.a68: Likewise. + * algol68/execute/rowing-3.a68: Likewise. + * algol68/execute/rowing-4.a68: Likewise. + * algol68/execute/rowing-5.a68: Likewise. + * algol68/execute/rowing-6.a68: Likewise. + * algol68/execute/rowing-7.a68: Likewise. + * algol68/execute/rowing-8.a68: Likewise. + * algol68/execute/rowing-9.a68: Likewise. + * algol68/execute/selection-1.a68: Likewise. + * algol68/execute/selection-2.a68: Likewise. + * algol68/execute/selection-3.a68: Likewise. + * algol68/execute/selection-4.a68: Likewise. + * algol68/execute/selection-5.a68: Likewise. + * algol68/execute/selection-multiple-1.a68: Likewise. + * algol68/execute/selection-multiple-2.a68: Likewise. + * algol68/execute/serial-clause-1.a68: Likewise. + * algol68/execute/serial-clause-10.a68: Likewise. + * algol68/execute/serial-clause-2.a68: Likewise. + * algol68/execute/serial-clause-3.a68: Likewise. + * algol68/execute/serial-clause-4.a68: Likewise. + * algol68/execute/serial-clause-5.a68: Likewise. + * algol68/execute/serial-clause-6.a68: Likewise. + * algol68/execute/serial-clause-7.a68: Likewise. + * algol68/execute/serial-clause-8.a68: Likewise. + * algol68/execute/serial-clause-9.a68: Likewise. + * algol68/execute/serial-dsa-1.a68: Likewise. + * algol68/execute/serial-dsa-2.a68: Likewise. + * algol68/execute/serial-dsa-3.a68: Likewise. + * algol68/execute/serial-dsa-4.a68: Likewise. + * algol68/execute/serial-dsa-5.a68: Likewise. + * algol68/execute/serial-dsa-6.a68: Likewise. + * algol68/execute/sign-int-1.a68: Likewise. + * algol68/execute/sign-real-1.a68: Likewise. + * algol68/execute/sin-1.a68: Likewise. + * algol68/execute/skip-1.a68: Likewise. + * algol68/execute/skip-2.a68: Likewise. + * algol68/execute/skip-struct-1.a68: Likewise. + * algol68/execute/slice-indexing-1.a68: Likewise. + * algol68/execute/slice-indexing-2.a68: Likewise. + * algol68/execute/slice-indexing-3.a68: Likewise. + * algol68/execute/slice-indexing-4.a68: Likewise. + * algol68/execute/slice-indexing-5.a68: Likewise. + * algol68/execute/slice-indexing-6.a68: Likewise. + * algol68/execute/slice-indexing-7.a68: Likewise. + * algol68/execute/sqrt-1.a68: Likewise. + * algol68/execute/string-1.a68: Likewise. + * algol68/execute/string-2.a68: Likewise. + * algol68/execute/string-4.a68: Likewise. + * algol68/execute/string-break-1.a68: Likewise. + * algol68/execute/struct-self-1.a68: Likewise. + * algol68/execute/struct-self-2.a68: Likewise. + * algol68/execute/struct-self-3.a68: Likewise. + * algol68/execute/structure-display-1.a68: Likewise. + * algol68/execute/structure-display-2.a68: Likewise. + * algol68/execute/structure-display-3.a68: Likewise. + * algol68/execute/structure-display-4.a68: Likewise. + * algol68/execute/structure-display-5.a68: Likewise. + * algol68/execute/tan-1.a68: Likewise. + * algol68/execute/timesab-string-1.a68: Likewise. + * algol68/execute/trimmer-1.a68: Likewise. + * algol68/execute/trimmer-10.a68: Likewise. + * algol68/execute/trimmer-2.a68: Likewise. + * algol68/execute/trimmer-3.a68: Likewise. + * algol68/execute/trimmer-4.a68: Likewise. + * algol68/execute/trimmer-5.a68: Likewise. + * algol68/execute/trimmer-6.a68: Likewise. + * algol68/execute/trimmer-7.a68: Likewise. + * algol68/execute/trimmer-8.a68: Likewise. + * algol68/execute/trimmer-9.a68: Likewise. + * algol68/execute/trimmer-matrix-1.a68: Likewise. + * algol68/execute/trimmer-matrix-2.a68: Likewise. + * algol68/execute/trimmer-matrix-3.a68: Likewise. + * algol68/execute/trimmer-matrix-4.a68: Likewise. + * algol68/execute/trimmer-matrix-5.a68: Likewise. + * algol68/execute/trimmer-matrix-6.a68: Likewise. + * algol68/execute/trimmer-name-1.a68: Likewise. + * algol68/execute/undefined-1.a68: Likewise. + * algol68/execute/undefined-2.a68: Likewise. + * algol68/execute/undefined-3.a68: Likewise. + * algol68/execute/undefined-4.a68: Likewise. + * algol68/execute/undefined-5.a68: Likewise. + * algol68/execute/uniting-1.a68: Likewise. + * algol68/execute/uniting-2.a68: Likewise. + * algol68/execute/uniting-3.a68: Likewise. + * algol68/execute/uniting-4.a68: Likewise. + * algol68/execute/up-down-bits-1.a68: Likewise. + * algol68/execute/upb-1.a68: Likewise. + * algol68/execute/vacuum-1.a68: Likewise. + * algol68/execute/variable-declaration-1.a68: Likewise. + * algol68/execute/variable-declaration-2.a68: Likewise. + * algol68/execute/variable-declaration-3.a68: Likewise. + * algol68/execute/variable-declaration-4.a68: Likewise. + * algol68/execute/variable-declaration-5.a68: Likewise. + * algol68/execute/variable-declaration-6.a68: Likewise. + * algol68/execute/variable-declaration-heap-1.a68: Likewise. + * algol68/execute/variable-declaration-heap-2.a68: Likewise. + * algol68/execute/variable-declaration-multiple-1.a68: Likewise. + * algol68/execute/variable-declaration-multiple-2.a68: Likewise. + * algol68/execute/variable-declaration-multiple-3.a68: Likewise. + * algol68/execute/variable-declaration-multiple-4.a68: Likewise. + * algol68/execute/variable-declaration-multiple-5.a68: Likewise. + * algol68/execute/variable-declaration-multiple-6.a68: Likewise. + * algol68/execute/variable-declaration-multiple-7.a68: Likewise. + * algol68/execute/variable-declaration-multiple-8.a68: Likewise. + * algol68/execute/variable-declaration-multiple-9.a68: Likewise. + * algol68/execute/voiding-1.a68: Likewise. + * algol68/execute/widening-1.a68: Likewise. + * algol68/execute/widening-2.a68: Likewise. + * algol68/execute/widening-bits-1.a68: Likewise. + * algol68/execute/widening-bits-2.a68: Likewise. + * algol68/execute/widening-bits-3.a68: Likewise. + * algol68/execute/xor-bits-1.a68: Likewise. + * algol68/execute/environment-enquiries-8.a68: Likewise. + * algol68/execute/modules/README: New file. + * algol68/execute/modules/execute.exp: New file. + * algol68/execute/modules/module1.a68: New file. + * algol68/execute/modules/module10.a68: New file. + * algol68/execute/modules/module11.a68: New file. + * algol68/execute/modules/module12.a68: New file. + * algol68/execute/modules/module13.a68: New file. + * algol68/execute/modules/module14.a68: New file. + * algol68/execute/modules/module15.a68: New file. + * algol68/execute/modules/module16.a68: New file. + * algol68/execute/modules/module17.a68: New file. + * algol68/execute/modules/module3.a68: New file. + * algol68/execute/modules/module4.a68: New file. + * algol68/execute/modules/module5.a68: New file. + * algol68/execute/modules/module6.a68: New file. + * algol68/execute/modules/module7.a68: New file. + * algol68/execute/modules/module8.a68: New file. + * algol68/execute/modules/module9.a68: New file. + * algol68/execute/modules/program-1.a68: New file. + * algol68/execute/modules/program-10.a68: New file. + * algol68/execute/modules/program-11.a68: New file. + * algol68/execute/modules/program-12.a68: New file. + * algol68/execute/modules/program-15.a68: New file. + * algol68/execute/modules/program-16.a68: New file. + * algol68/execute/modules/program-17.a68: New file. + * algol68/execute/modules/program-2.a68: New file. + * algol68/execute/modules/program-3.a68: New file. + * algol68/execute/modules/program-4.a68: New file. + * algol68/execute/modules/program-5.a68: New file. + * algol68/execute/modules/program-6.a68: New file. + * algol68/execute/modules/program-7.a68: New file. + * algol68/execute/modules/program-8.a68: New file. + * algol68/execute/posix-lseek.a68: New file. + +2025-11-30 Jose E. Marchesi + + * algol68/execute/abs-bits-1.a68: New file. + * algol68/execute/abs-bool-1.a68: Likewise. + * algol68/execute/abs-char-1.a68: Likewise. + * algol68/execute/abs-int-1.a68: Likewise. + * algol68/execute/abs-int-negative-1.a68: Likewise. + * algol68/execute/abs-int-negative-gnu-1.a68: Likewise. + * algol68/execute/acos-1.a68: Likewise. + * algol68/execute/affirm-int-1.a68: Likewise. + * algol68/execute/and-bits-1.a68: Likewise. + * algol68/execute/andf-1.a68: Likewise. + * algol68/execute/ascription-1.a68: Likewise. + * algol68/execute/asin-1.a68: Likewise. + * algol68/execute/assert-1.a68: Likewise. + * algol68/execute/assignation-char-1.a68: Likewise. + * algol68/execute/assignation-int-1.a68: Likewise. + * algol68/execute/assignation-int-2.a68: Likewise. + * algol68/execute/assignation-int-3.a68: Likewise. + * algol68/execute/assignation-int-4.a68: Likewise. + * algol68/execute/assignation-int-5.a68: Likewise. + * algol68/execute/assignation-multiple-1.a68: Likewise. + * algol68/execute/assignation-multiple-2.a68: Likewise. + * algol68/execute/assignation-struct-1.a68: Likewise. + * algol68/execute/assignation-struct-2.a68: Likewise. + * algol68/execute/atan-1.a68: Likewise. + * algol68/execute/balancing-1.a68: Likewise. + * algol68/execute/balancing-rows-1.a68: Likewise. + * algol68/execute/bin-1.a68: Likewise. + * algol68/execute/bin-negative-1.a68: Likewise. + * algol68/execute/bin-negative-gnu-1.a68: Likewise. + * algol68/execute/boolops-1.a68: Likewise. + * algol68/execute/call-1.a68: Likewise. + * algol68/execute/call-2.a68: Likewise. + * algol68/execute/case-clause-1.a68: Likewise. + * algol68/execute/case-clause-2.a68: Likewise. + * algol68/execute/case-clause-3.a68: Likewise. + * algol68/execute/case-clause-4.a68: Likewise. + * algol68/execute/closed-clause-1.a68: Likewise. + * algol68/execute/closed-clause-2.a68: Likewise. + * algol68/execute/collateral-clause-1.a68: Likewise. + * algol68/execute/collateral-clause-2.a68: Likewise. + * algol68/execute/collateral-clause-3.a68: Likewise. + * algol68/execute/collateral-clause-4.a68: Likewise. + * algol68/execute/collateral-clause-5.a68: Likewise. + * algol68/execute/collateral-clause-6.a68: Likewise. + * algol68/execute/completer-1.a68: Likewise. + * algol68/execute/completer-10.a68: Likewise. + * algol68/execute/completer-2.a68: Likewise. + * algol68/execute/completer-3.a68: Likewise. + * algol68/execute/completer-4.a68: Likewise. + * algol68/execute/completer-5.a68: Likewise. + * algol68/execute/completer-6.a68: Likewise. + * algol68/execute/completer-7.a68: Likewise. + * algol68/execute/completer-8.a68: Likewise. + * algol68/execute/completer-9.a68: Likewise. + * algol68/execute/cond-clause-1.a68: Likewise. + * algol68/execute/cond-clause-2.a68: Likewise. + * algol68/execute/cond-clause-3.a68: Likewise. + * algol68/execute/cond-clause-4.a68: Likewise. + * algol68/execute/cond-clause-5.a68: Likewise. + * algol68/execute/cond-clause-6.a68: Likewise. + * algol68/execute/cond-clause-7.a68: Likewise. + * algol68/execute/cond-clause-8.a68: Likewise. + * algol68/execute/cond-clause-9.a68: Likewise. + * algol68/execute/conformity-clause-1.a68: Likewise. + * algol68/execute/conformity-clause-2.a68: Likewise. + * algol68/execute/conformity-clause-3.a68: Likewise. + * algol68/execute/conformity-clause-4.a68: Likewise. + * algol68/execute/conformity-clause-5.a68: Likewise. + * algol68/execute/conformity-clause-6.a68: Likewise. + * algol68/execute/conformity-clause-7.a68: Likewise. + * algol68/execute/conformity-clause-8.a68: Likewise. + * algol68/execute/conformity-clause-9.a68: Likewise. + * algol68/execute/conj-1.a68: Likewise. + * algol68/execute/cos-1.a68: Likewise. + * algol68/execute/declarer-1.a68: Likewise. + * algol68/execute/declarer-2.a68: Likewise. + * algol68/execute/deprocedure-1.a68: Likewise. + * algol68/execute/deprocedure-2.a68: Likewise. + * algol68/execute/deref-1.a68: Likewise. + * algol68/execute/deref-2.a68: Likewise. + * algol68/execute/deref-3.a68: Likewise. + * algol68/execute/deref-4.a68: Likewise. + * algol68/execute/deref-5.a68: Likewise. + * algol68/execute/deref-6.a68: Likewise. + * algol68/execute/deref-7.a68: Likewise. + * algol68/execute/deref-8.a68: Likewise. + * algol68/execute/div-int-1.a68: Likewise. + * algol68/execute/divab-real-1.a68: Likewise. + * algol68/execute/elem-bits-1.a68: Likewise. + * algol68/execute/elems-1.a68: Likewise. + * algol68/execute/elems-2.a68: Likewise. + * algol68/execute/entier-1.a68: Likewise. + * algol68/execute/environment-enquiries-1.a68: Likewise. + * algol68/execute/environment-enquiries-2.a68: Likewise. + * algol68/execute/environment-enquiries-3.a68: Likewise. + * algol68/execute/environment-enquiries-4.a68: Likewise. + * algol68/execute/environment-enquiries-5.a68: Likewise. + * algol68/execute/environment-enquiries-6.a68: Likewise. + * algol68/execute/environment-enquiries-7.a68: Likewise. + * algol68/execute/environment-enquiries-8.a68: Likewise. + * algol68/execute/eq-bits-1.a68: Likewise. + * algol68/execute/eq-char-char-1.a68: Likewise. + * algol68/execute/eq-int-1.a68: Likewise. + * algol68/execute/eq-string-1.a68: Likewise. + * algol68/execute/eq-string-stride-1.a68: Likewise. + * algol68/execute/execute.exp: Likewise. + * algol68/execute/factorial-1.a68: Likewise. + * algol68/execute/flat-assignation-1.a68: Likewise. + * algol68/execute/flat-assignation-2.a68: Likewise. + * algol68/execute/flex-1.a68: Likewise. + * algol68/execute/flex-2.a68: Likewise. + * algol68/execute/flex-3.a68: Likewise. + * algol68/execute/flex-4.a68: Likewise. + * algol68/execute/flex-5.a68: Likewise. + * algol68/execute/formula-1.a68: Likewise. + * algol68/execute/formula-2.a68: Likewise. + * algol68/execute/fsize-1.a68: Likewise. + * algol68/execute/ge-int-1.a68: Likewise. + * algol68/execute/ge-string-stride-1.a68: Likewise. + * algol68/execute/gen-flex-1.a68: Likewise. + * algol68/execute/gen-heap-1.a68: Likewise. + * algol68/execute/gen-heap-2.a68: Likewise. + * algol68/execute/gen-heap-3.a68: Likewise. + * algol68/execute/gen-heap-bool-1.a68: Likewise. + * algol68/execute/gen-heap-int-1.a68: Likewise. + * algol68/execute/gen-heap-real-1.a68: Likewise. + * algol68/execute/gen-heap-struct-1.a68: Likewise. + * algol68/execute/gen-heap-struct-2.a68: Likewise. + * algol68/execute/gen-heap-struct-3.a68: Likewise. + * algol68/execute/gen-loc-1.a68: Likewise. + * algol68/execute/gen-loc-2.a68: Likewise. + * algol68/execute/gen-loc-3.a68: Likewise. + * algol68/execute/gen-loc-4.a68: Likewise. + * algol68/execute/gen-multiple-1.a68: Likewise. + * algol68/execute/gen-union-1.a68: Likewise. + * algol68/execute/gen-union-2.a68: Likewise. + * algol68/execute/gen-union-3.a68: Likewise. + * algol68/execute/goto-1.a68: Likewise. + * algol68/execute/goto-2.a68: Likewise. + * algol68/execute/goto-3.a68: Likewise. + * algol68/execute/goto-4.a68: Likewise. + * algol68/execute/goto-5.a68: Likewise. + * algol68/execute/gt-int-1.a68: Likewise. + * algol68/execute/gt-string-stride-1.a68: Likewise. + * algol68/execute/i-1.a68: Likewise. + * algol68/execute/i-2.a68: Likewise. + * algol68/execute/identification-1.a68: Likewise. + * algol68/execute/identification-2.a68: Likewise. + * algol68/execute/identity-declaration-1.a68: Likewise. + * algol68/execute/identity-declaration-2.a68: Likewise. + * algol68/execute/identity-declaration-3.a68: Likewise. + * algol68/execute/identity-declaration-4.a68: Likewise. + * algol68/execute/identity-declaration-5.a68: Likewise. + * algol68/execute/identity-declaration-multiple-1.a68: Likewise. + * algol68/execute/identity-declaration-multiple-2.a68: Likewise. + * algol68/execute/identity-declaration-multiple-3.a68: Likewise. + * algol68/execute/identity-declaration-multiple-5.a68: Likewise. + * algol68/execute/identity-declaration-multiple-empty-1.a68: Likewise. + * algol68/execute/identity-declaration-multiple-empty-2.a68: Likewise. + * algol68/execute/identity-declaration-multiple-empty-3.a68: Likewise. + * algol68/execute/identity-declaration-multiple-empty-4.a68: Likewise. + * algol68/execute/identity-declaration-struct-1.a68: Likewise. + * algol68/execute/infinity-1.a68: Likewise. + * algol68/execute/le-ge-bits-1.a68: Likewise. + * algol68/execute/le-int-1.a68: Likewise. + * algol68/execute/le-string-stride-1.a68: Likewise. + * algol68/execute/leng-shorten-bits-1.a68: Likewise. + * algol68/execute/leng-shorten-ints-1.a68: Likewise. + * algol68/execute/leng-shorten-reals-1.a68: Likewise. + * algol68/execute/lengths-shorths-1.a68: Likewise. + * algol68/execute/lisp-1.a68: Likewise. + * algol68/execute/lisp-2.a68: Likewise. + * algol68/execute/ln-1.a68: Likewise. + * algol68/execute/log-1.a68: Likewise. + * algol68/execute/loop-1.a68: Likewise. + * algol68/execute/loop-10.a68: Likewise. + * algol68/execute/loop-11.a68: Likewise. + * algol68/execute/loop-12.a68: Likewise. + * algol68/execute/loop-13.a68: Likewise. + * algol68/execute/loop-14.a68: Likewise. + * algol68/execute/loop-2.a68: Likewise. + * algol68/execute/loop-3.a68: Likewise. + * algol68/execute/loop-4.a68: Likewise. + * algol68/execute/loop-5.a68: Likewise. + * algol68/execute/loop-6.a68: Likewise. + +2025-11-30 Jose E. Marchesi + + * lib/algol68-dg.exp: New file. + * lib/algol68-torture.exp: Likewise. + * lib/algol68.exp: Likewise. + +2025-11-30 Nathaniel Shead + + PR c++/119864 + * g++.dg/modules/omp-4_a.C: New test. + * g++.dg/modules/omp-4_b.C: New test. + +2025-11-29 Eczbek + Jason Merrill + + PR c++/116952 + * g++.dg/cpp2a/lambda-uneval14.C: Revise incorrect test. + * g++.dg/cpp2a/lambda-uneval29.C: New test. + +2025-11-29 Jakub Jelinek + + PR c++/122758 + * g++.dg/cpp26/erroneous5.C: New test. + * g++.dg/cpp26/erroneous6.C: New test. + +2025-11-28 Richard Biener + + PR tree-optimization/122844 + * gcc.dg/vect/vect-pr122844.c: New testcase. + +2025-11-28 Tobias Burnus + + PR c/122892 + * gfortran.dg/gomp/allocate-15.f90: Use another allocator as + omp_{cgroup,pteam}_mem_alloc is invalid for non-local static vars. + * gfortran.dg/gomp/allocate-7.f90: Likewise. + * gfortran.dg/gomp/allocate-static-3.f90: New test. + +2025-11-28 Jakub Jelinek + + PR c++/119969 + * g++.dg/torture/pr119969.C: New test. + +2025-11-28 Mark Zhuang + + * gcc.target/riscv/predef-smt-1.c: New test. + +2025-11-28 Jakub Jelinek + + PR tree-optimization/122733 + * gcc.dg/match-shift-cmp-4.c: New test. + * gcc.dg/match-shift-cmp-5.c: New test. + +2025-11-28 Tamar Christina + + PR middle-end/122890 + * g++.target/aarch64/pr122890.C: New test. + +2025-11-27 Jakub Jelinek + + PR c/121506 + * gcc.dg/pr121506.c: New test. + +2025-11-27 Matthieu Longo + + * gcc.target/aarch64/build-attributes/build-attribute-define-nok.c: New test. + * gcc.target/aarch64/build-attributes/build-attribute-define-ok.c: New test. + +2025-11-27 Wilco Dijkstra + + * gcc.target/aarch64/ffs.c: Improve test. + +2025-11-27 Andrew Pinski + + * c-c++-common/Wstringop-overflow.c: Xfail, PR 122881. + +2025-11-27 Robin Dapp + + PR tree-optimization/122855 + PR tree-optimization/122850 + * gcc.dg/vect/pr122850.c: New test. + * gcc.dg/vect/pr122855.c: New test. + +2025-11-27 Pan Li + + * gcc.target/riscv/rvv/autovec/pr121959-run-1.c: Update + the reference for run test. + +2025-11-27 Dhruv Chawla + + PR tree-optimization/122733 + * gcc.dg/match-shift-cmp-1.c: Update test to only check + equality. + * gcc.dg/match-shift-cmp-2.c: Likewise. + * gcc.dg/match-shift-cmp-3.c: Likewise. + * gcc.dg/match-shift-cmp-4.c: Removed. + +2025-11-27 Richard Biener + + PR tree-optimization/122885 + * gcc.dg/torture/pr122873.c: New testcase. + +2025-11-26 Jeff Law + + Revert: + 2025-11-26 Zhongyao Chen + + * gcc.target/riscv/predef-profiles-1.c: New test for __riscv_rvi20u64. + * gcc.target/riscv/predef-profiles-2.c: New test for __riscv_rvi20u32. + * gcc.target/riscv/predef-profiles-3.c: New test for __riscv_rva20u64. + * gcc.target/riscv/predef-profiles-4.c: New test for __riscv_rva22u64. + * gcc.target/riscv/predef-profiles-5.c: New test for __riscv_rva23u64. + * gcc.target/riscv/predef-profiles-6.c: New test for __riscv_rva23s64. + * gcc.target/riscv/predef-profiles-7.c: New test for __riscv_rvb23u64. + * gcc.target/riscv/predef-profiles-8.c: New test for __riscv_rvb23s64. + +2025-11-26 Alejandro Colomar + + * gcc.dg/maxof-bitint.c: New test. + * gcc.dg/maxof-bitint575.c: New test. + * gcc.dg/maxof-compile.c: New test. + * gcc.dg/maxof-pedantic-errors.c: New test. + * gcc.dg/maxof-pedantic.c: New test. + +2025-11-26 Jeff Law + + PR rtl-optimization/122735 + * gcc.dg/torture/pr122735.c: New test. + +2025-11-26 Tobias Burnus + + * gfortran.dg/gomp/crayptr2.f90: Move dg-error line. + * gfortran.dg/gomp/declare-target-2.f90: Extend. + * gfortran.dg/gomp/declare-target-4.f90: Update comment, + enable one test. + * gfortran.dg/gomp/declare-target-5.f90: Update dg- wording, + add new test. + * gfortran.dg/gomp/declare-target-indirect-2.f90: Expect + 'device_type(any)' in scan-tree-dump. + * gfortran.dg/gomp/declare-target-6.f90: New test. + * gfortran.dg/gomp/dyn_groupprivate-1.f90: New test. + * gfortran.dg/gomp/dyn_groupprivate-2.f90: New test. + * gfortran.dg/gomp/groupprivate-1.f90: New test. + * gfortran.dg/gomp/groupprivate-2.f90: New test. + * gfortran.dg/gomp/groupprivate-3.f90: New test. + * gfortran.dg/gomp/groupprivate-4.f90: New test. + * gfortran.dg/gomp/groupprivate-5.f90: New test. + * gfortran.dg/gomp/groupprivate-6.f90: New test. + +2025-11-26 Marek Polacek + + PR c++/121325 + * g++.dg/cpp26/pack-indexing18.C: New test. + +2025-11-26 Richard Earnshaw + + PR target/122867 + * gcc.target/arm/cbz-range.c: New test. + +2025-11-26 Tamar Christina + + PR tree-optimization/122861 + * gcc.target/aarch64/sve/vect-early-break-cbranch_10.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_11.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_12.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_13.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_14.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_15.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_9.c: New test. + * gcc.target/aarch64/vect-early-break-cbranch_4.c: New test. + * gcc.target/aarch64/vect-early-break-cbranch_5.c: New test. + +2025-11-26 Jakub Jelinek + + * lib/target-supports.exp: Set cxx_default to c++20 rather than + c++17. + * lib/g++-dg.exp (g++-std-flags): Reorder list to put 20 first + and 17 after 26. + * g++.dg/debug/pr80461.C (bar): Use v = v + 1; instead of ++v;. + * g++.dg/debug/pr94459.C: Add -std=gnu++17 to dg-options. + * g++.dg/diagnostic/virtual-constexpr.C: Remove dg-skip-if, + instead use { c++11 && c++17_down } effective target instead of + c++11. + * g++.dg/guality/pr67192.C: Add -std=gnu++17. + * g++.dg/torture/pr84961-1.C: Likewise. + * g++.dg/torture/pr84961-2.C: Likewise. + * g++.dg/torture/pr51482.C (anim_track_bez_wvect::tangent): Cast + key_class to int before multiplying it by float. + * g++.dg/torture/stackalign/unwind-4.C (foo): Use g_a = g_a + 1; + instead of g_a++;. + * g++.dg/tree-prof/partition1.C (bar): Use l = l + 1; return l; + instead of return ++l;. + * obj-c++.dg/exceptions-3.mm: Add -std=gnu++17. + * obj-c++.dg/exceptions-5.mm: Likewise. + +2025-11-26 Jakub Jelinek + + PR middle-end/122835 + * gcc.dg/torture/pr122835.c: New test. + +2025-11-26 Jakub Jelinek + + PR tree-optimization/119683 + * gcc.dg/tree-ssa/pr119683.c: New test. + +2025-11-26 Richard Biener + + * gcc.dg/vect/vect-simd-clone-22.c: Add -w. + * gcc.dg/vect/vect-simd-clone-23.c: Likewise. + +2025-11-26 Soumya AR + + * gcc.target/aarch64/aarch64-json-tunings/aarch64-json-tunings.exp: New test. + * gcc.target/aarch64/aarch64-json-tunings/boolean-1.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/boolean-1.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/boolean-2.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/boolean-2.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/empty-brackets.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/empty-brackets.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/empty.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/empty.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/enum-1.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/enum-1.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/enum-2.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/enum-2.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/integer-1.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/integer-1.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/integer-2.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/integer-2.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/integer-3.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/integer-3.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/string-1.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/string-1.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/string-2.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/string-2.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/test-all.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/test-all.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/unidentified-key.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/unidentified-key.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/unsigned-1.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/unsigned-1.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/unsigned-2.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/unsigned-2.json: New test. + * gcc.target/aarch64/aarch64-json-tunings/unsigned-3.c: New test. + * gcc.target/aarch64/aarch64-json-tunings/unsigned-3.json: New test. + +2025-11-26 Paul Thomas + + PR fortran/104650 + * gfortran.dg/pdt_70.f03: New test. + +2025-11-26 Dhruv Chawla + + PR middle-end/116815 + * gcc.target/aarch64/pr116815-1.c: New test. + * gcc.target/aarch64/pr116815-2.c: Likewise. + * gcc.target/aarch64/pr116815-3.c: Likewise. + +2025-11-26 Pan Li + + * gcc.target/riscv/sat/sat_arith.h: Add test helper macros. + * gcc.target/riscv/sat/sat_u_mul-8-u16-from-u128.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u16-from-u32.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u16-from-u64.rv32.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u16-from-u64.rv64.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u32-from-u128.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u32-from-u64.rv32.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u32-from-u64.rv64.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u64-from-u128.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u8-from-u128.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u8-from-u16.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u8-from-u32.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u8-from-u64.rv32.c: New test. + * gcc.target/riscv/sat/sat_u_mul-8-u8-from-u64.rv64.c: New test. + * gcc.target/riscv/sat/sat_u_mul-run-8-u16-from-u128.c: New test. + * gcc.target/riscv/sat/sat_u_mul-run-8-u16-from-u32.c: New test. + * gcc.target/riscv/sat/sat_u_mul-run-8-u16-from-u64.c: New test. + * gcc.target/riscv/sat/sat_u_mul-run-8-u32-from-u128.c: New test. + * gcc.target/riscv/sat/sat_u_mul-run-8-u32-from-u64.c: New test. + * gcc.target/riscv/sat/sat_u_mul-run-8-u64-from-u128.c: New test. + * gcc.target/riscv/sat/sat_u_mul-run-8-u8-from-u128.c: New test. + * gcc.target/riscv/sat/sat_u_mul-run-8-u8-from-u16.c: New test. + * gcc.target/riscv/sat/sat_u_mul-run-8-u8-from-u32.c: New test. + * gcc.target/riscv/sat/sat_u_mul-run-8-u8-from-u64.c: New test. + +2025-11-26 Andrew Pinski + + PR tree-optimization/122847 + * gcc.dg/torture/pr122847-1.c: New test. + +2025-11-25 Lúcio Boari Fleury + + * rust/compile/macros/mbe/macro-issue3608.rs: New Test. The test skips an issue at line 11 + +2025-11-25 Philip Herron + + * rust/compile/gat1.rs: New test. + * rust/execute/torture/gat1.rs: New test. + +2025-11-25 Lucas Ly Ba + + * rust/compile/issue-3971.rs: New test. + +2025-11-25 Lucas Ly Ba + + * rust/compile/issue-4226.rs: New test. + +2025-11-25 Yap Zhi Heng + + * rust/compile/e0579-neg-float-fail.rs: New file. + * rust/compile/e0579-neg-float.rs: New file. + +2025-11-25 Lucas Ly Ba + + * rust/compile/issue-4262.rs: New test. + +2025-11-25 lenny.chiadmi-delage + + * rust/compile/issue-4140-1.rs: Fixes test. + * rust/compile/issue-4140-2.rs: Likewise. + +2025-11-25 lenny.chiadmi-delage + + * rust/compile/issue-4140-1.rs: New test. + * rust/compile/issue-4140-2.rs: Likewise. + +2025-11-25 David Malcolm + + * gcc.dg/analyzer/strchr-1.c: Drop include of , and use + __builtin_strchr throughout rather than strchr to avoid const + correctness issues when the header implements strchr with a C23 + const-preserving macro. Drop "const" from two vars. + +2025-11-25 Tamar Christina + + PR target/118974 + * gcc.target/aarch64/sve/pr119351.c: Update codegen. + * gcc.target/aarch64/sve/vect-early-break-cbranch.c: Likewise. + * gcc.target/aarch64/vect-early-break-cbranch.c: Likewise. + * gcc.target/aarch64/sve/vect-early-break-cbranch_2.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_3.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_4.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_5.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_7.c: New test. + * gcc.target/aarch64/sve/vect-early-break-cbranch_8.c: New test. + * gcc.target/aarch64/vect-early-break-cbranch_2.c: New test. + * gcc.target/aarch64/vect-early-break-cbranch_3.c: New test. + +2025-11-25 Nathaniel Shead + + PR c++/122699 + * g++.dg/modules/tpl-friend-21_a.C: New test. + * g++.dg/modules/tpl-friend-21_b.C: New test. + +2025-11-25 Andre Vieira + + * gcc.dg/Wstringop-overflow-47.c: Adjust warnings to allow for 32-bit + stores. + +2025-11-25 Nathaniel Shead + + PR c++/122789 + * g++.dg/modules/concept-12_a.C: New test. + * g++.dg/modules/concept-12_b.C: New test. + +2025-11-25 Jason Merrill + + * g++.dg/modules/compile-std1.C: New test. + * g++.dg/modules/modules.exp: Only run it once. + +2025-11-25 Jakub Jelinek + + PR middle-end/120052 + * c-c++-common/gomp/pr120052.c: New test. + +2025-11-25 Jakub Jelinek + + PR testsuite/119931 + * gcc.dg/vla-1.c (main): Hide x value from optimizers and use it after + the call as well. + +2025-11-25 Rainer Orth + + * g++.dg/DRs/dr2581-1.C (__STDC_ISO_10646__): xfail on non-Linux. + * g++.dg/DRs/dr2581-2.C: Likewise. + (__STDC_VERSION__): Expect error instead of warning on Solaris. + +2025-11-25 Jakub Jelinek + + PR middle-end/120564 + * c-c++-common/gomp/pr120564.c: New test. + +2025-11-25 Rainer Orth + + * gcc.target/i386/pr120936-1.c: Restrict to *-*-linux*. + * gcc.target/i386/pr120936-2.c: Likewise. + * gcc.target/i386/pr120936-4.c: Likewise. + * gcc.target/i386/pr120936-5.c: Likewise. + * gcc.target/i386/pr120936-9.c: Likewise. + * gcc.target/i386/pr120936-11.c: Likewise. + +2025-11-25 Rainer Orth + + * gcc.target/i386/pr120936-3.c: Restrict to *-*-linux*. + * gcc.target/i386/pr120936-6.c: Likewise. + * gcc.target/i386/pr120936-10.c: Likewise. + * gcc.target/i386/pr120936-12.c: Likewise. + +2025-11-25 Rainer Orth + + * lib/target-supports.exp (add_options_for_check_function_bodies): + New proc. + * g++.target/i386/cf_check-3.C: Add dg-add-options + check_function_bodies. + * g++.target/i386/cf_check-4.C: Likewise. + * gcc.target/i386/builtin-copysign-2.c: Likewise. + * gcc.target/i386/builtin-copysign-3.c: Likewise. + * gcc.target/i386/builtin-copysign-4.c: Likewise. + * gcc.target/i386/builtin-copysign-5.c: Likewise. + * gcc.target/i386/builtin-copysign-6.c: Likewise. + * gcc.target/i386/builtin-copysign-7.c: Likewise. + * gcc.target/i386/builtin-copysign-8a.c: Likewise. + * gcc.target/i386/builtin-copysign-8b.c: Likewise. + * gcc.target/i386/builtin-fabs-1.c: Likewise. + * gcc.target/i386/builtin-memmove-10.c: Likewise. + * gcc.target/i386/builtin-memmove-11a.c: Likewise. + * gcc.target/i386/builtin-memmove-11b.c: Likewise. + * gcc.target/i386/builtin-memmove-11c.c: Likewise. + * gcc.target/i386/builtin-memmove-12.c: Likewise. + * gcc.target/i386/builtin-memmove-13.c: Likewise. + * gcc.target/i386/builtin-memmove-14.c: Likewise. + * gcc.target/i386/builtin-memmove-15.c: Likewise. + * gcc.target/i386/builtin-memmove-1a.c: Likewise. + * gcc.target/i386/builtin-memmove-1b.c: Likewise. + * gcc.target/i386/builtin-memmove-1c.c: Likewise. + * gcc.target/i386/builtin-memmove-1d.c: Likewise. + * gcc.target/i386/builtin-memmove-2a.c: Likewise. + * gcc.target/i386/builtin-memmove-2b.c: Likewise. + * gcc.target/i386/builtin-memmove-2c.c: Likewise. + * gcc.target/i386/builtin-memmove-2d.c: Likewise. + * gcc.target/i386/builtin-memmove-3a.c: Likewise. + * gcc.target/i386/builtin-memmove-3b.c: Likewise. + * gcc.target/i386/builtin-memmove-3c.c: Likewise. + * gcc.target/i386/builtin-memmove-4a.c: Likewise. + * gcc.target/i386/builtin-memmove-4b.c: Likewise. + * gcc.target/i386/builtin-memmove-4c.c: Likewise. + * gcc.target/i386/builtin-memmove-5a.c: Likewise. + * gcc.target/i386/builtin-memmove-5b.c: Likewise. + * gcc.target/i386/builtin-memmove-5c.c: Likewise. + * gcc.target/i386/builtin-memmove-6.c: Likewise. + * gcc.target/i386/builtin-memmove-7.c: Likewise. + * gcc.target/i386/builtin-memmove-8.c: Likewise. + * gcc.target/i386/builtin-memmove-9.c: Likewise. + * gcc.target/i386/cf_check-11.c: Likewise. + * gcc.target/i386/cf_check-7.c: Likewise. + * gcc.target/i386/pr120936-1.c: Likewise. + * gcc.target/i386/pr120936-11.c: Likewise. + * gcc.target/i386/pr120936-2.c: Likewise. + * gcc.target/i386/pr120936-4.c: Likewise. + * gcc.target/i386/pr120936-5.c: Likewise. + * gcc.target/i386/pr120936-9.c: Likewise. + * g++.target/i386/memset-pr101366-1.C: Switch to dg-add-options + check_function_bodies. + * g++.target/i386/memset-pr101366-2.C: Likewise. + * g++.target/i386/memset-pr108585-1a.C: Likewise. + * g++.target/i386/memset-pr108585-1b.C: Likewise. + * g++.target/i386/memset-pr118276-1a.C: Likewise. + * g++.target/i386/memset-pr118276-1b.C: Likewise. + * g++.target/i386/memset-pr118276-1c.C: Likewise. + * gcc.target/i386/memcpy-pr120683-1.c: Likewise. + * gcc.target/i386/memcpy-pr120683-2.c: Likewise. + * gcc.target/i386/memcpy-pr120683-3.c: Likewise. + * gcc.target/i386/memcpy-pr120683-4.c: Likewise. + * gcc.target/i386/memcpy-pr120683-5.c: Likewise. + * gcc.target/i386/memcpy-pr120683-6.c: Likewise. + * gcc.target/i386/memcpy-pr120683-7.c: Likewise. + * gcc.target/i386/memcpy-strategy-12.c: Likewise. + * gcc.target/i386/memset-pr120683-1.c: Likewise. + * gcc.target/i386/memset-pr120683-10.c: Likewise. + * gcc.target/i386/memset-pr120683-11.c: Likewise. + * gcc.target/i386/memset-pr120683-12.c: Likewise. + * gcc.target/i386/memset-pr120683-13.c: Likewise. + * gcc.target/i386/memset-pr120683-14.c: Likewise. + * gcc.target/i386/memset-pr120683-15.c: Likewise. + * gcc.target/i386/memset-pr120683-16.c: Likewise. + * gcc.target/i386/memset-pr120683-17.c: Likewise. + * gcc.target/i386/memset-pr120683-18.c: Likewise. + * gcc.target/i386/memset-pr120683-19.c: Likewise. + * gcc.target/i386/memset-pr120683-2.c: Likewise. + * gcc.target/i386/memset-pr120683-20.c: Likewise. + * gcc.target/i386/memset-pr120683-21.c: Likewise. + * gcc.target/i386/memset-pr120683-22.c: Likewise. + * gcc.target/i386/memset-pr120683-23.c: Likewise. + * gcc.target/i386/memset-pr120683-3.c: Likewise. + * gcc.target/i386/memset-pr120683-4.c: Likewise. + * gcc.target/i386/memset-pr120683-5.c: Likewise. + * gcc.target/i386/memset-pr120683-6.c: Likewise. + * gcc.target/i386/memset-pr120683-7.c: Likewise. + * gcc.target/i386/memset-pr120683-8.c: Likewise. + * gcc.target/i386/memset-pr120683-9.c: Likewise. + * gcc.target/i386/memset-pr70308-1a.c: Likewise. + * gcc.target/i386/memset-pr70308-1b.c: Likewise. + * gcc.target/i386/memset-strategy-10.c: Likewise. + * gcc.target/i386/memset-strategy-13.c: Likewise. + * gcc.target/i386/memset-strategy-25.c: Likewise. + * gcc.target/i386/memset-strategy-28.c: Likewise. + * gcc.target/i386/memset-strategy-29.c: Likewise. + * gcc.target/i386/memset-strategy-30.c: Likewise. + * gcc.target/i386/pr111673.c: Likewise. + * gcc.target/i386/pr82142a.c: Likewise. + * gcc.target/i386/pr82142b.c: Likewise. + * gcc.target/i386/pr92080-17.c: Likewise. + +2025-11-25 Rainer Orth + + * gcc.dg/debug/dwarf2/dwarf-btf-decl-tag-1.c + (scan-assembler-times): Switch to brace quotes. + Allow for alternative assembler syntax. + * gcc.dg/debug/dwarf2/dwarf-btf-type-tag-1.c: Likewise. + * gcc.dg/debug/dwarf2/dwarf-btf-type-tag-10.c: Likewise. + * gcc.dg/debug/dwarf2/dwarf-btf-type-tag-2.c: Likewise. + * gcc.dg/debug/dwarf2/dwarf-btf-type-tag-4.c: Likewise. + * gcc.dg/debug/dwarf2/dwarf-btf-type-tag-5.c: Likewise. + 2025-11-24 Robin Dapp * gcc.target/riscv/rvv/autovec/pr121582.c: New test. diff --git a/gcc/testsuite/algol68/README.mcts b/gcc/testsuite/algol68/README.mcts new file mode 100644 index 000000000000..cdf95ce628b2 --- /dev/null +++ b/gcc/testsuite/algol68/README.mcts @@ -0,0 +1,18 @@ +The mcts testsuite is not distributed along with GCC due to unclear +distribution terms of its contents, which have to be clarified with +the CWI. + +In the meanwhile, you can find the testset at: + + https://git.sr.ht/~jemarch/a68-mcts + +In order to install them in the GCC sources, just copy the file and +two directories to the testsuite/algol68 directory, like: + + $ git clone https://git.sr.ht/~jemarch/a68-mcts + $ cd a68-mcts + $ cp README.mcts /path/to/gcc/gcc/testsuite/algol68/ + $ cp -r compile/* /path/to/gcc/gcc/testsuite/algol68/compile/ + $ cp -r execute/* /path/to/gcc/gcc/testsuite/algol68/execute/ + +Then make check-algol68 will include the evil MCTS as well. diff --git a/gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68 b/gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68 new file mode 100644 index 000000000000..c287d6a93091 --- /dev/null +++ b/gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68 @@ -0,0 +1,4 @@ +proc goodbye = (string name) string: +begin string msg := "Goodbye " + name; + msg +end; diff --git a/gcc/testsuite/algol68/compile/a68includes/goodbye.a68 b/gcc/testsuite/algol68/compile/a68includes/goodbye.a68 new file mode 100644 index 000000000000..19c3acc57797 --- /dev/null +++ b/gcc/testsuite/algol68/compile/a68includes/goodbye.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# PR UPPER PR # + +PROC goodbye = (STRING name) STRING: +BEGIN + STRING msg := "Goodbye " + name; + msg +END; diff --git a/gcc/testsuite/algol68/compile/a68includes/hello-supper.a68 b/gcc/testsuite/algol68/compile/a68includes/hello-supper.a68 new file mode 100644 index 000000000000..2af568bcb01c --- /dev/null +++ b/gcc/testsuite/algol68/compile/a68includes/hello-supper.a68 @@ -0,0 +1,5 @@ +proc hello = (string name) string: +begin string msg := "Hello " + name; + msg +end; + diff --git a/gcc/testsuite/algol68/compile/a68includes/hello.a68 b/gcc/testsuite/algol68/compile/a68includes/hello.a68 new file mode 100644 index 000000000000..aa72e282d2c5 --- /dev/null +++ b/gcc/testsuite/algol68/compile/a68includes/hello.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# PR UPPER PR # + +PROC hello = (STRING name) STRING: +BEGIN + STRING msg := "Hello " + name; + msg +END; diff --git a/gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68 b/gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68 new file mode 100644 index 000000000000..58309db74fdd --- /dev/null +++ b/gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT a := (1,2,3); # { dg-error "actual bounds expected" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68 b/gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68 new file mode 100644 index 000000000000..e80e8cb45c08 --- /dev/null +++ b/gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN LOC[]INT a := (1,2,3); # { dg-error "actual bounds expected" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68 b/gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68 new file mode 100644 index 000000000000..26ddd279f056 --- /dev/null +++ b/gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN LOC[]INT a := (1,2,3), # { dg-error "actual bounds expected" } # + b := (4); + SKIP +END diff --git a/gcc/testsuite/algol68/compile/balancing-1.a68 b/gcc/testsuite/algol68/compile/balancing-1.a68 new file mode 100644 index 000000000000..62d1221f675f --- /dev/null +++ b/gcc/testsuite/algol68/compile/balancing-1.a68 @@ -0,0 +1,7 @@ +mode Word = union (void,real), + Rules = union (void,string); + +op LEN = (Word w) int: skip, +LEN = (Rules r) int: skip; + +skip diff --git a/gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68 b/gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68 new file mode 100644 index 000000000000..0820c3d20c20 --- /dev/null +++ b/gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68 @@ -0,0 +1,7 @@ +# { dg-options {-fstropping=upper} } # +# pr UPPER pr # +BEGIN NOTE This is a + NOTE nestable ETON comment in bold style. + ETON + SKIP +END diff --git a/gcc/testsuite/algol68/compile/bold-taggle-1.a68 b/gcc/testsuite/algol68/compile/bold-taggle-1.a68 new file mode 100644 index 000000000000..77ce9e7c2fa3 --- /dev/null +++ b/gcc/testsuite/algol68/compile/bold-taggle-1.a68 @@ -0,0 +1,6 @@ +# { dg-options {-std=gnu68 -fstropping=upper} } # + +BEGIN MODE FOO_BAR = INT; + FOO_BAR foo_bar = 10; + SKIP +END diff --git a/gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68 b/gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68 new file mode 100644 index 000000000000..045b9b56d57f --- /dev/null +++ b/gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68 @@ -0,0 +1,4 @@ +begin { This is a + { nestable } comment in brief style. } + skip +end diff --git a/gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68 b/gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68 new file mode 100644 index 000000000000..a4e5d3ebb878 --- /dev/null +++ b/gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN NOTE This is a + { nestable } comment in brief style. + ETON + SKIP +END diff --git a/gcc/testsuite/algol68/compile/char-break-1.a68 b/gcc/testsuite/algol68/compile/char-break-1.a68 new file mode 100644 index 000000000000..30308b3df4b2 --- /dev/null +++ b/gcc/testsuite/algol68/compile/char-break-1.a68 @@ -0,0 +1,11 @@ +{ Make sure char denotations with string breaks work. } +begin prio % = 9; + op % = (char a) char: a; + assert (ABS %"'n" = 10); + assert (ABS %"'f" = 12); + assert (ABS %"'t" = 9); + assert (ABS %"'r" = 13); + assert (%"'( u0061)" = "a"); + assert (%"'(U00000061 )" = "a"); + assert (%"'(u1234)" = replacement_char) +end diff --git a/gcc/testsuite/algol68/compile/compile.exp b/gcc/testsuite/algol68/compile/compile.exp new file mode 100644 index 000000000000..68fa5fa2625e --- /dev/null +++ b/gcc/testsuite/algol68/compile/compile.exp @@ -0,0 +1,34 @@ +# Copyright (C) 2024 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# Compile tests, no torture testing. +# +# These tests raise errors in the front end; torture testing doesn't apply. + +load_lib algol68-dg.exp + +# Initialize `dg'. +dg-init + +# Main loop. +set saved-dg-do-what-default ${dg-do-what-default} + +set dg-do-what-default "compile" +algol68-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.a68]] "" "" +set dg-do-what-default ${saved-dg-do-what-default} + +# All done. +dg-finish diff --git a/gcc/testsuite/algol68/compile/conditional-clause-1.a68 b/gcc/testsuite/algol68/compile/conditional-clause-1.a68 new file mode 100644 index 000000000000..a727bc21e58a --- /dev/null +++ b/gcc/testsuite/algol68/compile/conditional-clause-1.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN INT i := 26; + IF INT ii = i * 2; ii > 50 THEN + ii + ELIF i = 10 THEN + 100 + FI +END diff --git a/gcc/testsuite/algol68/compile/error-bold-taggle-1.a68 b/gcc/testsuite/algol68/compile/error-bold-taggle-1.a68 new file mode 100644 index 000000000000..d813e55e5ba3 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-bold-taggle-1.a68 @@ -0,0 +1,6 @@ +# { dg-options {-std=algol68 -fstropping=upper} } # + +BEGIN MODE FOO_BAR = INT; # { dg-error "unworthy" } # + FOO_BAR foo_bar = 10; + SKIP +END diff --git a/gcc/testsuite/algol68/compile/error-coercion-1.a68 b/gcc/testsuite/algol68/compile/error-coercion-1.a68 new file mode 100644 index 000000000000..d0e24821f279 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-coercion-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN INT a; + a := "foo" # { dg-error "cannot be coerced" } # +END diff --git a/gcc/testsuite/algol68/compile/error-coercion-2.a68 b/gcc/testsuite/algol68/compile/error-coercion-2.a68 new file mode 100644 index 000000000000..bb8de3064b57 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-coercion-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # + +# This is Example 4.2.6c in McGETTRICK[78]. # +BEGIN []STRUCT([]INT a) r = (1,2,3); # { dg-error "cannot be coerced" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/error-coercion-flex-1.a68 b/gcc/testsuite/algol68/compile/error-coercion-flex-1.a68 new file mode 100644 index 000000000000..c556d703b407 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-coercion-flex-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # + +# Coercing from REF FLEX[]REAL to REF[]REAL is not allowed, since + flexibility shall match # +BEGIN FLEX[1:0] REAL rowvar := SKIP; + REF [] REAL xlm = rowvar; # { dg-error "FLEX.*cannot be coerced" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/error-compile-unknown-tag-1.a68 b/gcc/testsuite/algol68/compile/error-compile-unknown-tag-1.a68 new file mode 100644 index 000000000000..cd69d1a21b44 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-compile-unknown-tag-1.a68 @@ -0,0 +1,8 @@ +module Foo = def pub int idpublic = 10; + int idprivate = 20; + skip + fed, + Bar = def pub int idpublic = 30; + int idprivate = 40; + xxx { dg-error "" } + fed diff --git a/gcc/testsuite/algol68/compile/error-conformance-clause-1.a68 b/gcc/testsuite/algol68/compile/error-conformance-clause-1.a68 new file mode 100644 index 000000000000..e6cb738a2c95 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-conformance-clause-1.a68 @@ -0,0 +1,8 @@ +{ This is an invalid program. } +begin case + if true then "foo" else 10 fi { dg-error "not a united mode" } + in (string): skip, + (int): skip + esac +end + diff --git a/gcc/testsuite/algol68/compile/error-contraction-1.a68 b/gcc/testsuite/algol68/compile/error-contraction-1.a68 new file mode 100644 index 000000000000..f2bce73ff176 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-contraction-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # + +# Contracting mixed collateral variable and constant declarations is + not allowed. +# +(INT foo = 100, bar := 200) # { dg-error "mixed" } # diff --git a/gcc/testsuite/algol68/compile/error-contraction-2.a68 b/gcc/testsuite/algol68/compile/error-contraction-2.a68 new file mode 100644 index 000000000000..2115a4cbfab3 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-contraction-2.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # + +# Contracting mixed collateral variable and constant declarations is + not allowed. # +BEGIN PROC x = VOID: SKIP, + y := VOID: SKIP; # { dg-error "mixed" } # + x +END diff --git a/gcc/testsuite/algol68/compile/error-def-1.a68 b/gcc/testsuite/algol68/compile/error-def-1.a68 new file mode 100644 index 000000000000..6d7cdc87deb1 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-def-1.a68 @@ -0,0 +1,3 @@ +module Foo = +def skip; { dg-error "fed" } + skip diff --git a/gcc/testsuite/algol68/compile/error-incestuous-union-1.a68 b/gcc/testsuite/algol68/compile/error-incestuous-union-1.a68 new file mode 100644 index 000000000000..519cb8a9af1f --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-incestuous-union-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # + +# Union modes shall not contain modes which are firmly related, i.e. + it shall not be possible to coerce from one mode to another in a + firm context. # +BEGIN UNION(INT, REF INT) incestuous; # { dg-error "has firmly related components" } # + incestuous +END diff --git a/gcc/testsuite/algol68/compile/error-label-after-decl-1.a68 b/gcc/testsuite/algol68/compile/error-label-after-decl-1.a68 new file mode 100644 index 000000000000..670f8908af1c --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-label-after-decl-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN GOTO end; + ASSERT(FALSE); +end: 0; + INT i = 10; # { dg-error "declaration cannot follow" } # + i +END diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-1.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-1.a68 new file mode 100644 index 000000000000..7a619d8408f6 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-1.a68 @@ -0,0 +1,3 @@ +begin struct (int i, real r) j; + j := "joo" { dg-error "char.*struct \\(int i, real r\\)" } +end diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-10.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-10.a68 new file mode 100644 index 000000000000..fd70de7df0d2 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-10.a68 @@ -0,0 +1,3 @@ +begin long long int j; + j := "joo" { dg-error "char.*long long int" } +end diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-11.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-11.a68 new file mode 100644 index 000000000000..156d8d39aa64 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-11.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN LONG LONG INT j; + j := "joo" { dg-error "CHAR.*LONG LONG INT" } +END diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-12.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-12.a68 new file mode 100644 index 000000000000..0dda5beb4143 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-12.a68 @@ -0,0 +1,3 @@ +begin short int j; + j := "joo" { dg-error "char.*short int" } +end diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-13.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-13.a68 new file mode 100644 index 000000000000..84cf830e7ecb --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-13.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN SHORT INT j; + j := "joo" { dg-error "CHAR.*SHORT INT" } +END diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-14.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-14.a68 new file mode 100644 index 000000000000..24bda0a6db99 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-14.a68 @@ -0,0 +1,3 @@ +begin short short int j; + j := "joo" { dg-error "char.*short short int" } +end diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-15.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-15.a68 new file mode 100644 index 000000000000..0136fdb4f7bc --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-15.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN SHORT SHORT INT j; + j := "joo" { dg-error "CHAR.*SHORT SHORT INT" } +END diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-16.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-16.a68 new file mode 100644 index 000000000000..82359e52d954 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-16.a68 @@ -0,0 +1,3 @@ +begin flex[1:0]int j; + j := "joo" { dg-error "char.*flex.*int" } +end diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-17.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-17.a68 new file mode 100644 index 000000000000..e733c51c75f3 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-17.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN FLEX[1:0]INT j; + j := "joo" { dg-error "CHAR.*FLEX.*INT" } +END diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-2.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-2.a68 new file mode 100644 index 000000000000..f72b6dd13685 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-2.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRUCT (INT i, REAL r) j; + j := "joo" # { dg-error "CHAR.*STRUCT \\(INT i, REAL r\\)" } # +END diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-3.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-3.a68 new file mode 100644 index 000000000000..eb672c495339 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-3.a68 @@ -0,0 +1,3 @@ +begin union (int,real) j; + j := "joo" { dg-error "char.*union \\( *real *, *int *\\)" } +end diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-4.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-4.a68 new file mode 100644 index 000000000000..42c6ee29b6d7 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-4.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN UNION (INT,REAL) j; + j := "joo" { dg-error "CHAR.*UNION \\( *REAL *, *INT *\\)" } +END diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-5.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-5.a68 new file mode 100644 index 000000000000..0206d19f72f5 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-5.a68 @@ -0,0 +1,3 @@ +begin proc union (int,real) j; + j := "joo" { dg-error "char.*proc union \\( *real *, *int *\\)" } +end diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-6.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-6.a68 new file mode 100644 index 000000000000..5f8404363ddf --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-6.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC UNION (INT,REAL) j; + j := "joo" { dg-error "CHAR.*PROC UNION \\( *REAL *, *INT *\\)" } +END diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-8.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-8.a68 new file mode 100644 index 000000000000..49308860381d --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-8.a68 @@ -0,0 +1,3 @@ +begin long int j; + j := "joo" { dg-error "char.*long int" } +end diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-9.a68 b/gcc/testsuite/algol68/compile/error-mode-stropping-9.a68 new file mode 100644 index 000000000000..dc20eb34a346 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-mode-stropping-9.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN LONG INT j; + j := "joo" { dg-error "CHAR.*LONG INT" } +END diff --git a/gcc/testsuite/algol68/compile/error-module-coercions-1.a68 b/gcc/testsuite/algol68/compile/error-module-coercions-1.a68 new file mode 100644 index 000000000000..460c381299e4 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-module-coercions-1.a68 @@ -0,0 +1,15 @@ +{ This test makes sure mode checks are carried + over the inside of module texts. } +module Foo = def + skip + postlude + int i = "foo"; { dg-error "coerced" } + skip + fed, + Bar = def + int i = 3.14; { dg-error "coerced" } + skip + postlude + skip + fed, + Baz = def skip fed diff --git a/gcc/testsuite/algol68/compile/error-module-not-found-1.a68 b/gcc/testsuite/algol68/compile/error-module-not-found-1.a68 new file mode 100644 index 000000000000..e990c6e22fda --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-module-not-found-1.a68 @@ -0,0 +1,4 @@ +access + Foo { dg-error "cannot find module" } +begin skip end + diff --git a/gcc/testsuite/algol68/compile/error-module-ranges-1.a68 b/gcc/testsuite/algol68/compile/error-module-ranges-1.a68 new file mode 100644 index 000000000000..b377ffba7361 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-module-ranges-1.a68 @@ -0,0 +1,13 @@ +{ Definitions in the def-part of a module text are visible in the + postlude-part, but not the other way around. } + +module Foo = def int i; + x := 20 { dg-error "" } + postlude + i := 10 { this is ok } + fed, + Bar = def int x; + skip + postlude + x := 20 { this is ok } + fed diff --git a/gcc/testsuite/algol68/compile/error-nestable-comments-1.a68 b/gcc/testsuite/algol68/compile/error-nestable-comments-1.a68 new file mode 100644 index 000000000000..df00a1a9970f --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-nestable-comments-1.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +# pr UPPER pr # +BEGIN NOTE This is a + NOTE nestable ETON comment in brief style. + ETON + { Another { comment }. } + NOTE invalid { nesting ETON of comments } # { dg-error "" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/error-nested-comment-1.a68 b/gcc/testsuite/algol68/compile/error-nested-comment-1.a68 new file mode 100644 index 000000000000..3c78f34a51ab --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-nested-comment-1.a68 @@ -0,0 +1,6 @@ +{ The string in nested comment is in one logical line. } +begin + { puts ("{'n { dg-error {} } +"); { this prints foo }} + skip +end diff --git a/gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68 b/gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68 new file mode 100644 index 000000000000..75d66bc17158 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68 @@ -0,0 +1,15 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN [1:10]INT i, + [1:10]STRUCT(REF[]INT i, BOOL j) k, + [1:10]STRUCT([1:10]INT i, BOOL j) l, + [1:10]REF[]INT p; + # formal, so no bounds allowed: # + [1:10]PROC[1:10]INT q, # { dg-error "formal bounds expected" } # + STRUCT(REF[1:10]INT i, BOOLj) m, # { dg-error "virtual bounds expected" } # + [1:10]REF[1:10]INT mn, # { dg-error "virtual bounds expected" } # + PROC([1:10]INT)VOID pp, # { dg-error "formal bounds expected" } # + UNION([1:10] INT, BOOL) nm, # { dg-error "formal bounds expected" } # + [1:10]INT u = (1); # { dg-error "formal bounds expected" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/error-pragmat-1.a68 b/gcc/testsuite/algol68/compile/error-pragmat-1.a68 new file mode 100644 index 000000000000..8c5f1c1d899d --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-pragmat-1.a68 @@ -0,0 +1,8 @@ +{ dg-error "unrecognized pragmat" } pr invalid Foo in "module" pr + +begin prio // = 8; + op (int,int)int // = lala; + proc lala = (int a, b) int: a + b; + proc void jeje = skip; + skip +end diff --git a/gcc/testsuite/algol68/compile/error-pragmat-access-1.a68 b/gcc/testsuite/algol68/compile/error-pragmat-access-1.a68 new file mode 100644 index 000000000000..2eb4ceb7ef51 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-pragmat-access-1.a68 @@ -0,0 +1,8 @@ +pr access Foo in pr { dg-error "expected string" } + +begin prio // = 8; + op (int,int)int // = lala; + proc lala = (int a, b) int: a + b; + proc void jeje = skip; + skip +end diff --git a/gcc/testsuite/algol68/compile/error-pragmat-access-2.a68 b/gcc/testsuite/algol68/compile/error-pragmat-access-2.a68 new file mode 100644 index 000000000000..643fcce07736 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-pragmat-access-2.a68 @@ -0,0 +1,9 @@ +pr access Foo in "lala" pr +pr access Foo in "lele" pr { dg-error "multiple" } + +begin prio // = 8; + op (int,int)int // = lala; + proc lala = (int a, b) int: a + b; + proc void jeje = skip; + skip +end diff --git a/gcc/testsuite/algol68/compile/error-pub-loc-1.a68 b/gcc/testsuite/algol68/compile/error-pub-loc-1.a68 new file mode 100644 index 000000000000..eb174806c445 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-pub-loc-1.a68 @@ -0,0 +1,10 @@ +{ Publicized varifables cannot go on the stack, for obvious reasons. } + +module Foo = +def + pub string xx; + pub heap string yy; + pub loc string zz; { dg-error "" } + loc string vv; + skip +fed diff --git a/gcc/testsuite/algol68/compile/error-pub-out-of-def-1.a68 b/gcc/testsuite/algol68/compile/error-pub-out-of-def-1.a68 new file mode 100644 index 000000000000..372bfbbcfd8c --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-pub-out-of-def-1.a68 @@ -0,0 +1,13 @@ +module Foo = +def pub mode JORL = int; + pub proc plus = (int a, b) int: a + b; + pub proc vplus := (int a, b) int: a + b; + pub loc proc lvplus := (int a, b) int: a + b; + pub heap proc hvplus := (int a, b) int: a + b; + pub prio // = 8; + pub op // = (int a, b) int: a % b; + proc invalid = void: + (pub mode JI = void; { dg-error "" } + skip); + skip +fed diff --git a/gcc/testsuite/algol68/compile/error-pub-out-of-def-2.a68 b/gcc/testsuite/algol68/compile/error-pub-out-of-def-2.a68 new file mode 100644 index 000000000000..d911e3d6d7ce --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-pub-out-of-def-2.a68 @@ -0,0 +1,9 @@ +begin pub mode Jorl = void; { dg-error "" } + pub proc lala = void: skip; { dg-error "" } + pub proc lele := void: skip; { dg-error "" } + begin pub prio + = 4; { dg-error "" } + skip + end; + pub op // = (int a, b) int: a % b; { dg-error "" } + skip +end diff --git a/gcc/testsuite/algol68/compile/error-string-break-1.a68 b/gcc/testsuite/algol68/compile/error-string-break-1.a68 new file mode 100644 index 000000000000..fd8e765ab484 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-string-break-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN puts ("hello '_ world") # { dg-error "invalid string break sequence" } # +END diff --git a/gcc/testsuite/algol68/compile/error-string-break-2.a68 b/gcc/testsuite/algol68/compile/error-string-break-2.a68 new file mode 100644 index 000000000000..465f8f804040 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-string-break-2.a68 @@ -0,0 +1,2 @@ +begin puts ("hello '(U0000) world") # { dg-error "eight" } # +end diff --git a/gcc/testsuite/algol68/compile/error-string-break-3.a68 b/gcc/testsuite/algol68/compile/error-string-break-3.a68 new file mode 100644 index 000000000000..e4cf8f6f1a34 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-string-break-3.a68 @@ -0,0 +1,2 @@ +begin puts ("hello '(u00) world") # { dg-error "four" } # +end diff --git a/gcc/testsuite/algol68/compile/error-string-break-4.a68 b/gcc/testsuite/algol68/compile/error-string-break-4.a68 new file mode 100644 index 000000000000..76adff9b2bc5 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-string-break-4.a68 @@ -0,0 +1,2 @@ +begin puts ("hello '(u) world") # { dg-error "four" } # +end diff --git a/gcc/testsuite/algol68/compile/error-string-break-5.a68 b/gcc/testsuite/algol68/compile/error-string-break-5.a68 new file mode 100644 index 000000000000..c42589fde7cd --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-string-break-5.a68 @@ -0,0 +1,2 @@ +begin puts ("hello '(u0010u0020) world") # { dg-error "" } # +end diff --git a/gcc/testsuite/algol68/compile/error-string-break-6.a68 b/gcc/testsuite/algol68/compile/error-string-break-6.a68 new file mode 100644 index 000000000000..fed7d84b2213 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-string-break-6.a68 @@ -0,0 +1,2 @@ +begin puts ("hello '(u0010'/) world") # { dg-error "" } # +end diff --git a/gcc/testsuite/algol68/compile/error-string-break-7.a68 b/gcc/testsuite/algol68/compile/error-string-break-7.a68 new file mode 100644 index 000000000000..58545e01ce10 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-string-break-7.a68 @@ -0,0 +1,2 @@ +begin puts ("'") # { dg-error "" } # +end diff --git a/gcc/testsuite/algol68/compile/error-string-break-8.a68 b/gcc/testsuite/algol68/compile/error-string-break-8.a68 new file mode 100644 index 000000000000..dbc96e4e57fb --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-string-break-8.a68 @@ -0,0 +1,4 @@ +begin string s = + "'(Uf09f94a5)"; { dg-error "Unicode" } + skip +end diff --git a/gcc/testsuite/algol68/compile/error-stropping-5.a68 b/gcc/testsuite/algol68/compile/error-stropping-5.a68 new file mode 100644 index 000000000000..3190472129a7 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-stropping-5.a68 @@ -0,0 +1,3 @@ +begin int j; + j := "joo" { dg-error "char.*int" } +end diff --git a/gcc/testsuite/algol68/compile/error-stropping-6.a68 b/gcc/testsuite/algol68/compile/error-stropping-6.a68 new file mode 100644 index 000000000000..af6097df7c08 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-stropping-6.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT j; + j := "joo" # { dg-error "CHAR.*INT" } # +END diff --git a/gcc/testsuite/algol68/compile/error-stropping-keyword-1.a68 b/gcc/testsuite/algol68/compile/error-stropping-keyword-1.a68 new file mode 100644 index 000000000000..4bf549f91e31 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-stropping-keyword-1.a68 @@ -0,0 +1,2 @@ +begin for i to 10 skip od { dg-error "do" } +end diff --git a/gcc/testsuite/algol68/compile/error-stropping-keyword-2.a68 b/gcc/testsuite/algol68/compile/error-stropping-keyword-2.a68 new file mode 100644 index 000000000000..a1e616deaeb9 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-stropping-keyword-2.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper" } # +BEGIN FOR i TO 10 SKIP OD # { dg-error "DO" } # +END diff --git a/gcc/testsuite/algol68/compile/error-stropping-keyword-3.a68 b/gcc/testsuite/algol68/compile/error-stropping-keyword-3.a68 new file mode 100644 index 000000000000..d1076e935bd0 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-stropping-keyword-3.a68 @@ -0,0 +1,2 @@ +begin if then 10 else 20 fi { dg-error "if" } +end diff --git a/gcc/testsuite/algol68/compile/error-stropping-keyword-4.a68 b/gcc/testsuite/algol68/compile/error-stropping-keyword-4.a68 new file mode 100644 index 000000000000..92b0b3b58cb9 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-stropping-keyword-4.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper" } # +BEGIN IF THEN 10 ELSE 20 FI # { dg-error "IF" } # +END diff --git a/gcc/testsuite/algol68/compile/error-supper-1.a68 b/gcc/testsuite/algol68/compile/error-supper-1.a68 new file mode 100644 index 000000000000..f2646c41b7b1 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-supper-1.a68 @@ -0,0 +1,3 @@ +# { dg-options {-fstropping=upper} } # + +begin ~ end # { dg-error "" } # diff --git a/gcc/testsuite/algol68/compile/error-supper-2.a68 b/gcc/testsuite/algol68/compile/error-supper-2.a68 new file mode 100644 index 000000000000..f8c6c284b203 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-supper-2.a68 @@ -0,0 +1,5 @@ +# { dg-options {-fstropping=supper} } # + +begin int foo__bar = 10; # { dg-error "unworthy" } # + skip +end diff --git a/gcc/testsuite/algol68/compile/error-supper-3.a68 b/gcc/testsuite/algol68/compile/error-supper-3.a68 new file mode 100644 index 000000000000..a35730ce1f77 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-supper-3.a68 @@ -0,0 +1,5 @@ +# { dg-options {-fstropping=supper} } # + +begin int _bar = 10; # { dg-error "unworthy" } # + skip +end diff --git a/gcc/testsuite/algol68/compile/error-supper-4.a68 b/gcc/testsuite/algol68/compile/error-supper-4.a68 new file mode 100644 index 000000000000..726f80638d6e --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-supper-4.a68 @@ -0,0 +1,5 @@ +{ dg-options {-fstropping=supper} } + +begin int foo bar = 10; { dg-error "" } + skip +end diff --git a/gcc/testsuite/algol68/compile/error-supper-5.a68 b/gcc/testsuite/algol68/compile/error-supper-5.a68 new file mode 100644 index 000000000000..0cf51c519de2 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-supper-5.a68 @@ -0,0 +1,5 @@ +# { dg-options {-fstropping=supper} } # + +begin int foo__ = 10; # { dg-error "unworthy" } # + skip +end diff --git a/gcc/testsuite/algol68/compile/error-supper-6.a68 b/gcc/testsuite/algol68/compile/error-supper-6.a68 new file mode 100644 index 000000000000..c013b4894b38 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-supper-6.a68 @@ -0,0 +1,6 @@ +# { dg-options {-fstropping=supper} } # + +begin mode foo_Invalid = int; # { dg-error "Invalid" } # + foo_Invalid some_int = 10; # { dg-error "Invalid" } # + skip +end diff --git a/gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68 b/gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68 new file mode 100644 index 000000000000..2aa294d1f02c --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # + +# Underscores are unworthy characters if they are not trailing + either a taggle or, in UPPER stropping, a bold word. # +BEGIN INT invalid_tag__; # { dg-error "unworthy character" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68 b/gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68 new file mode 100644 index 000000000000..a5dcb86b6e11 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # + +# Underscores are unworthy characters if they are not trailing a + taggle or, in UPPER stropping, a bold word.. # +BEGIN MODE INVALID_BOLD_WORD__; # { dg-error "unworthy character" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/error-upper-1.a68 b/gcc/testsuite/algol68/compile/error-upper-1.a68 new file mode 100644 index 000000000000..053846972ace --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-upper-1.a68 @@ -0,0 +1,3 @@ +# { dg-options {-fstropping=supper} } # + +BEGIN ~ END # { dg-error "" } # diff --git a/gcc/testsuite/algol68/compile/error-vacuum-1.a68 b/gcc/testsuite/algol68/compile/error-vacuum-1.a68 new file mode 100644 index 000000000000..0e724592e255 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-vacuum-1.a68 @@ -0,0 +1,2 @@ +begin { dg-error "" } +end diff --git a/gcc/testsuite/algol68/compile/error-vacuum-2.a68 b/gcc/testsuite/algol68/compile/error-vacuum-2.a68 new file mode 100644 index 000000000000..fe9716aeef40 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-vacuum-2.a68 @@ -0,0 +1,2 @@ +( { dg-error "" } +) diff --git a/gcc/testsuite/algol68/compile/error-vacuum-3.a68 b/gcc/testsuite/algol68/compile/error-vacuum-3.a68 new file mode 100644 index 000000000000..fc0960027091 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-vacuum-3.a68 @@ -0,0 +1,3 @@ +begin struct(int i, real r) foo = (); { dg-error "" } + skip +end diff --git a/gcc/testsuite/algol68/compile/error-widening-1.a68 b/gcc/testsuite/algol68/compile/error-widening-1.a68 new file mode 100644 index 000000000000..38ea59afb28a --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-widening-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN INT a := 10; + LONG REAL l := a; # { dg-error "coerced" } # + l +END diff --git a/gcc/testsuite/algol68/compile/error-widening-2.a68 b/gcc/testsuite/algol68/compile/error-widening-2.a68 new file mode 100644 index 000000000000..3165d1b71134 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-widening-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN INT a := 10; + LONG INT l := a; # { dg-error "coerced" } # + l +END diff --git a/gcc/testsuite/algol68/compile/error-widening-3.a68 b/gcc/testsuite/algol68/compile/error-widening-3.a68 new file mode 100644 index 000000000000..c4ffb305a62f --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-widening-3.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN INT d := 0; + INT y := 10; + LONG REAL x; + 2 + + (d > 0 | x | # { dg-error "" } # + y + ) +END diff --git a/gcc/testsuite/algol68/compile/error-widening-4.a68 b/gcc/testsuite/algol68/compile/error-widening-4.a68 new file mode 100644 index 000000000000..fa5b2072e171 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-widening-4.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN + INT d := 0; + LONG REAL x; + 2 + + (d > 0 | x | # { dg-error "" } # + 10 + ) +END diff --git a/gcc/testsuite/algol68/compile/error-widening-5.a68 b/gcc/testsuite/algol68/compile/error-widening-5.a68 new file mode 100644 index 000000000000..a6198669c45a --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-widening-5.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN + LONG INT d := 0; # { dg-error "coerced" } # + d +END diff --git a/gcc/testsuite/algol68/compile/error-widening-6.a68 b/gcc/testsuite/algol68/compile/error-widening-6.a68 new file mode 100644 index 000000000000..09512e216781 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-widening-6.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN + LONG LONG INT d := LONG 0; # { dg-error "coerced" } # + d +END diff --git a/gcc/testsuite/algol68/compile/error-widening-7.a68 b/gcc/testsuite/algol68/compile/error-widening-7.a68 new file mode 100644 index 000000000000..093520815837 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-widening-7.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN + LONG REAL d := 3.14; # { dg-error "coerced" } # + d +END diff --git a/gcc/testsuite/algol68/compile/error-widening-8.a68 b/gcc/testsuite/algol68/compile/error-widening-8.a68 new file mode 100644 index 000000000000..098f6c3b6157 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-widening-8.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN + LONG LONG REAL d := LONG 3.14; # { dg-error "coerced" } # + d +END diff --git a/gcc/testsuite/algol68/compile/error-widening-9.a68 b/gcc/testsuite/algol68/compile/error-widening-9.a68 new file mode 100644 index 000000000000..4d092386b610 --- /dev/null +++ b/gcc/testsuite/algol68/compile/error-widening-9.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN + INT d := 0; + LONG LONG REAL x; + 2 + + (d > 0 | x | # { dg-error "" } # + 10 + ) +END diff --git a/gcc/testsuite/algol68/compile/hidden-operators-1.a68 b/gcc/testsuite/algol68/compile/hidden-operators-1.a68 new file mode 100644 index 000000000000..d66242d67a69 --- /dev/null +++ b/gcc/testsuite/algol68/compile/hidden-operators-1.a68 @@ -0,0 +1,11 @@ +{ dg-options {-Whidden-declarations} } + +begin mode Trilean = union (void,bool); + + Trilean unknown = empty; + op NOT = (Trilean a) Trilean: { dg-warning "hides" } + skip; + op AND = (Trilean a,b) Trilean: { dg-warning "hides" } + skip; + skip +end diff --git a/gcc/testsuite/algol68/compile/implicit-widening-1.a68 b/gcc/testsuite/algol68/compile/implicit-widening-1.a68 new file mode 100644 index 000000000000..2fa010c12a76 --- /dev/null +++ b/gcc/testsuite/algol68/compile/implicit-widening-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-Wextensions -fstropping=upper" } # + +# This program shall compile without warning, because + widening from INT to REAL is legal in the strict language, + since they have the same size. # + +BEGIN BOOL cond; + REAL x, y; + y + (cond | x | 10) +END diff --git a/gcc/testsuite/algol68/compile/include-supper.a68 b/gcc/testsuite/algol68/compile/include-supper.a68 new file mode 100644 index 000000000000..af0521be1019 --- /dev/null +++ b/gcc/testsuite/algol68/compile/include-supper.a68 @@ -0,0 +1,16 @@ +{ dg-options "-I$srcdir/algol68/compile/a68includes" } +{ dg-additional-files "$srcdir/algol68/compile/a68includes/hello-supper.a68 $srcdir/algol68/compile/a68includes/goodbye-supper.a68" } + +begin string name := "Algol68 with supper!"; + { Both files are in `./a68includes'. + The first one will be included because we uwed `-I. + The second one will be included because of the relative path. } + pr include "hello-supper.a68" pr + pr include "a68includes/goodbye-supper.a68" pr + + string bye := goodbye(name); + string hi := hello(name); + + puts(hi + "\n"); + puts(bye + "\n") +end diff --git a/gcc/testsuite/algol68/compile/include.a68 b/gcc/testsuite/algol68/compile/include.a68 new file mode 100644 index 000000000000..6f4855b33da9 --- /dev/null +++ b/gcc/testsuite/algol68/compile/include.a68 @@ -0,0 +1,19 @@ +# { dg-options "-I$srcdir/algol68/compile/a68includes -fstropping=upper" } # +# { dg-additional-files "$srcdir/algol68/compile/a68includes/hello.a68 $srcdir/algol68/compile/a68includes/goodbye.a68" } # + +# PR UPPER PR # + +BEGIN STRING name := "Algol68!"; + # Both files are in `./a68includes'. + The first one will be included because we used `-I'. + The second one will be included because of the relative path. + # + PR include "hello.a68" PR + PR include "a68includes/goodbye.a68" PR + + STRING bye := goodbye(name); + STRING hi := hello(name); + + puts(hi + "\n"); + puts(bye + "\n") +END diff --git a/gcc/testsuite/algol68/compile/labeled-unit-1.a68 b/gcc/testsuite/algol68/compile/labeled-unit-1.a68 new file mode 100644 index 000000000000..d3dbd8c40d7d --- /dev/null +++ b/gcc/testsuite/algol68/compile/labeled-unit-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # + +# This tests that the mode of the value yielded by a labeled unit is + the mode of the unit. # +BEGIN 10; +jorl: 20 +END diff --git a/gcc/testsuite/algol68/compile/mcgt-1.3b.a68 b/gcc/testsuite/algol68/compile/mcgt-1.3b.a68 new file mode 100644 index 000000000000..80fc4a1c976f --- /dev/null +++ b/gcc/testsuite/algol68/compile/mcgt-1.3b.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN REAL r := 10.0, circum, area; + circum := 2 * pi * r; area := pi * r * r +END diff --git a/gcc/testsuite/algol68/compile/mcgt-7.1.3a-bis.a68 b/gcc/testsuite/algol68/compile/mcgt-7.1.3a-bis.a68 new file mode 100644 index 000000000000..132f0c57972e --- /dev/null +++ b/gcc/testsuite/algol68/compile/mcgt-7.1.3a-bis.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # + +# Transient references and declarations. # +BEGIN FLEX[4,6]INT p; + # Illegal, cannot remember transient name. # + REF[]INT q2 = p[3,]; # { dg-error "" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/mcgt-7.1.3a.a68 b/gcc/testsuite/algol68/compile/mcgt-7.1.3a.a68 new file mode 100644 index 000000000000..be3f12ac7e3c --- /dev/null +++ b/gcc/testsuite/algol68/compile/mcgt-7.1.3a.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # + +# Transient references and declarations. # +BEGIN FLEX[4,6]INT p; + # Illegal. p cannot be deflexed since it is a REF FLEX. # + REF[,]INT q3 = p; # { dg-error "" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/module-1.a68 b/gcc/testsuite/algol68/compile/module-1.a68 new file mode 100644 index 000000000000..e4f3215cc356 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-1.a68 @@ -0,0 +1,69 @@ +module Argp = +def mode ArgOpt = struct (char name, string long_name, + bool arg_required, proc(string)bool handler); + + proc argp = (int p, [][]ArgOpt opts, + proc(int,string)bool no_opt_handler, + proc(string)void error_handler) void: + begin + proc getopt = (string prefix, string arg) ArgOpt: + begin ArgOpt res, bool found := false; + for i to UPB opts while NOT found + do for j to UPB opts[i] while NOT found + do if arg = long_name of opts[i][j] + OR (arg /= " " AND arg = name of opts[i][j]) + then res := opts[i][j]; found := true + fi + od + od; + (NOT found | error_handler ("unknown option " + prefix + arg)); + res + end; + + bool found_dash_dash := false, + skip_next_opt := false, + continue := true; + + for i from p to argc while continue + do string arg = argv (i); + if skip_next_opt + then skip_next_opt := false + elif arg = "--" AND NOT found_dash_dash + then found_dash_dash := true + elif found_dash_dash OR (UPB arg >= 1 andth arg[1] /= "-") + then continue := no_opt_handler (i + 1, arg) + elif UPB arg > 1 andth arg[2] = "-" + then { Long option. It may have an argument. } + int eqidx = char_in_string (arg, "="); + string optname = (eqidx > 0 | arg[3:eqidx - 1] | arg[3:]), + optarg = (eqidx > 0 AND UPB arg >= (eqidx + 1) | arg[eqidx + 1:]); + ArgOpt opt = getopt ("--", optname); + + if (arg_required of opt) AND optarg = "" + then error_handler ("option --" + arg + " requires an argument") fi; + continue := (handler of opt) (optarg) + else { This is one or more short options. } + for j to UPB arg[2:] + do ArgOpt opt = getopt ("-", arg[j + 1]); + if arg_required of opt + then if i = argc orel (ELEMS argv (i + 1) > 1 andth argv (i + 1)[1] = "-") + then error_handler ("option -" + arg[2+j] + " requires an argument") + fi; + (handler of opt) (argv (i + 1)); + skip_next_opt := true + else continue := (handler of opt) ("") + fi + od + fi + od + end; + + proc char_in_string = (string s, char c) int: + begin int res := 0, bool found := false; + for i to UPB s while NOT found + do (s[i] = c | res := i; found := true) od; + res + end; + + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-2.a68 b/gcc/testsuite/algol68/compile/module-2.a68 new file mode 100644 index 000000000000..74bd23690220 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-2.a68 @@ -0,0 +1,16 @@ +module Foo = def pub int idpublic = 10; + int idprivate = 20; + pub int varpublic := 100; + real varprivate := 3.14; + pub proc lala = (int a, b) int: a + b; + pub proc lele := (int a, b) int: a - b; + skip + fed, + Bar = def pub int idpublic = 30; + int idprivate = 40; + pub int varpublic := 100; + real varprivate := 3.14; + pub proc lala = (int a, b) int: a + b; + pub proc lele := (int a, b) int: a - b; + skip + fed diff --git a/gcc/testsuite/algol68/compile/module-extracts-1.a68 b/gcc/testsuite/algol68/compile/module-extracts-1.a68 new file mode 100644 index 000000000000..c56a1d877c1d --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-extracts-1.a68 @@ -0,0 +1,29 @@ +{ dg-options "-O0 -dA" } + +module Foo = +def pub mode JURL = union (void,int,real); + { dg-final { scan-assembler "mode extract FOO_JURL" } } + pub proc plus = (int a, b) int: a + b; + { dg-final { scan-assembler "identifier extract FOO_plus" } } + pub proc vplus := (int a, b) int: a + b; + { dg-final { scan-assembler "identifier extract FOO_vplus" } } + pub proc lvplus := (int a, b) int: a + b; + { dg-final { scan-assembler "identifier extract FOO_lvplus" } } + pub heap proc hvplus := (int a, b) int: a + b; + { dg-final { scan-assembler "identifier extract FOO_hvplus" } } + pub proc(int,int)int vplus2 = vplus; + { dg-final { scan-assembler "identifier extract FOO_vplus2" } } + pub proc(int,int)int lvplus2 := lvplus; + { dg-final { scan-assembler "identifier extract FOO_lvplus2" } } + pub heap proc(int,int)int hvplus2 := hvplus; + { dg-final { scan-assembler "identifier extract FOO_hvplus2" } } + pub int i; + { dg-final { scan-assembler "identifier extract FOO_i" } } + int k = 10; + { dg-final { scan-assembler-not "identifier extract FOO_k" } } + pub prio // = 8; + { dg-final { scan-assembler "operator extract FOO_s_s_\[0-9\]+" } } + pub op // = (int a, b) int: a % b; + { dg-final { scan-assembler "operator extract FOO_s_s_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-mode-exports-1.a68 b/gcc/testsuite/algol68/compile/module-mode-exports-1.a68 new file mode 100644 index 000000000000..8a4f50ef50cb --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-mode-exports-1.a68 @@ -0,0 +1,21 @@ +{ dg-options "-dA" } + +{ Test for mode table in module definition exports. } + +module Foo = +def pub mode MyInt = int; + pub mode MyLongInt = long int; + pub mode MyLongLongInt = long long int; + pub mode MyShortInt = short int; + pub mode MyShortShortInt = short short int; + skip +fed + +{ GA68_MODE_INT = 2UB } + +{ dg-final { scan-assembler-times "2\[\t ]+\[^0-9\]+int" 5 } } +{ dg-final { scan-assembler-times "\[\t \]+0x2\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0x1\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0xff\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0xfe\[\t \]+\[^\n\]*sizety" 1 } } diff --git a/gcc/testsuite/algol68/compile/module-mode-exports-2.a68 b/gcc/testsuite/algol68/compile/module-mode-exports-2.a68 new file mode 100644 index 000000000000..fb67b3db6a37 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-mode-exports-2.a68 @@ -0,0 +1,17 @@ +{ dg-options "-dA" } + +{ Test for mode table in module definition exports. } + +module Foo = +def pub mode MyReal = real; + pub mode MyLongReal = long real; + pub mode MyLongLongReal = long long real; + skip +fed + +{ GA68_MODE_REAL = 3UB } + +{ dg-final { scan-assembler-times "\[\t \]+0x3\[\t \]+\[^\n\]*real" 3 } } +{ dg-final { scan-assembler-times "\[\t \]+0x2\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0x1\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0\[\t \]+\[^\n\]*sizety" 1 } } diff --git a/gcc/testsuite/algol68/compile/module-mode-exports-3.a68 b/gcc/testsuite/algol68/compile/module-mode-exports-3.a68 new file mode 100644 index 000000000000..b0309032a4f1 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-mode-exports-3.a68 @@ -0,0 +1,12 @@ +{ dg-options "-dA" } + +{ Test for mode table in module definition exports. } + +module Foo = +def pub mode MyString = string; + skip +fed + +{ GA68_MODE_STRING = 14UB } + +{ dg-final { scan-assembler-times "\[\t \]+0xe\[\t \]+\[^\n\]*string" 1 } } diff --git a/gcc/testsuite/algol68/compile/module-mode-exports-4.a68 b/gcc/testsuite/algol68/compile/module-mode-exports-4.a68 new file mode 100644 index 000000000000..9846f19e7df6 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-mode-exports-4.a68 @@ -0,0 +1,12 @@ +{ dg-options "-dA" } + +{ Test for mode table in module definition exports. } + +module Foo = +def pub mode MyChar = char; + skip +fed + +{ GA68_MODE_CHAR = 6UB } + +{ dg-final { scan-assembler-times "\[\t \]+0x6\[\t \]+\[^\n\]*char" 1 } } diff --git a/gcc/testsuite/algol68/compile/module-mode-exports-5.a68 b/gcc/testsuite/algol68/compile/module-mode-exports-5.a68 new file mode 100644 index 000000000000..be4deef2c690 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-mode-exports-5.a68 @@ -0,0 +1,21 @@ +{ dg-options "-dA" } + +{ Test for mode table in module definition exports. } + +module Foo = +def pub mode MyBits = bits; + pub mode MyLongBits = long bits; + pub mode MyLongLongBits = long long bits; + pub mode MyShortBits = short bits; + pub mode MyShortShortBits = short short bits; + skip +fed + +{ GA68_MODE_BITS = 4UB } + +{ dg-final { scan-assembler-times "4\[\t ]+\[^0-9\]+bits" 5 } } +{ dg-final { scan-assembler-times "\[\t \]+0x2\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0x1\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0xff\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0xfe\[\t \]+\[^\n\]*sizety" 1 } } diff --git a/gcc/testsuite/algol68/compile/module-mode-exports-6.a68 b/gcc/testsuite/algol68/compile/module-mode-exports-6.a68 new file mode 100644 index 000000000000..18a7d4fd3edb --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-mode-exports-6.a68 @@ -0,0 +1,15 @@ +{ dg-options "-dA" } + +{ Test for mode table in module definition exports. } + +module Foo = +def pub mode MyBool = bool; + pub mode MyVoid = void; + skip +fed + +{ GA68_MODE_BOOL = 7UB + GA68_MODE_VOID = 1UB } + +{ dg-final { scan-assembler-times "7\[\t ]+\[^0-9\]+bool" 1 } } +{ dg-final { scan-assembler-times "1\[\t ]+\[^0-9\]+void" 1 } } diff --git a/gcc/testsuite/algol68/compile/module-mode-exports-7.a68 b/gcc/testsuite/algol68/compile/module-mode-exports-7.a68 new file mode 100644 index 000000000000..b76085b7681a --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-mode-exports-7.a68 @@ -0,0 +1,13 @@ +{ dg-options "-dA" } + +{ Test for mode table in module definition exports. } + +module Foo = +def pub mode MyName = ref int; + skip +fed + +{ GA68_MODE_NAME = 12UB } + +{ dg-final { scan-assembler-times "0xc\[\t ]+\[^0-9\]+ref" 1 } } +{ dg-final { scan-assembler-times "0x2\[\t ]+\[^0-9\]+int" 1 } } diff --git a/gcc/testsuite/algol68/compile/module-mode-exports-8.a68 b/gcc/testsuite/algol68/compile/module-mode-exports-8.a68 new file mode 100644 index 000000000000..c38502a25bb8 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-mode-exports-8.a68 @@ -0,0 +1,17 @@ +{ dg-options "-dA" } + +{ Test for mode table in module definition exports. } + +module Foo = +def pub mode MyCompl = compl; + pub mode MyLongCompl = long compl; + pub mode MyLongLongCompl = long long compl; + skip +fed + +{ GA68_MODE_CMPL = 8UB } + +{ dg-final { scan-assembler-times "0x8\[\t ]+\[^0-9\]+compl" 3 } } +{ dg-final { scan-assembler-times "\[\t \]+0x2\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0x1\[\t \]+\[^\n\]*sizety" 1 } } +{ dg-final { scan-assembler-times "\[\t \]+0\[\t \]+\[^\n\]*sizety" 1 } } diff --git a/gcc/testsuite/algol68/compile/module-mode-exports-9.a68 b/gcc/testsuite/algol68/compile/module-mode-exports-9.a68 new file mode 100644 index 000000000000..482aab6ea32f --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-mode-exports-9.a68 @@ -0,0 +1,12 @@ +{ dg-options "-dA" } + +{ Test for mode table in module definition exports. } + +module Foo = +def pub mode MyProc = proc void; + skip +fed + +{ GA68_MODE_CMPL = 8UB } + +{ dg-final { scan-assembler-times "0xd\[\t ]+\[^0-9\]+proc" 1 } } diff --git a/gcc/testsuite/algol68/compile/module-pub-1.a68 b/gcc/testsuite/algol68/compile/module-pub-1.a68 new file mode 100644 index 000000000000..a0cf6e9e328f --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-1.a68 @@ -0,0 +1,16 @@ +module Foo = +def pub mode JORL = int, JURL = union (void,int,real); + pub proc plus = (int a, b) int: a + b; + pub proc vplus := (int a, b) int: a + b; + pub proc lvplus := (int a, b) int: a + b; + pub heap proc hvplus := (int a, b) int: a + b; + pub proc(int,int)int vplus2 = vplus; + pub proc(int,int)int lvplus2 := lvplus; + pub heap proc(int,int)int hvplus2 := hvplus; + pub int i, x, y; + pub int k = 10; + pub int j := 20; + pub prio // = 8; + pub op // = (int a, b) int: a % b; + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-1.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-1.a68 new file mode 100644 index 000000000000..3451f46a8ffa --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-1.a68 @@ -0,0 +1,15 @@ +{ dg-options "-O0" } + +module Foo = def pub int foo; { dg-final { scan-assembler "FOO_foo" } } + int bar; { dg-final { scan-assembler "FOO_bar" } } + skip + fed, + Bar = def pub int foo; { dg-final { scan-assembler "BAR_foo" } } + int bar; { dg-final { scan-assembler "BAR_bar" } } + skip + fed + +{ dg-final { scan-assembler "FOO__prelude" } } +{ dg-final { scan-assembler "FOO__postlude" } } +{ dg-final { scan-assembler "BAR__prelude" } } +{ dg-final { scan-assembler "BAR__postlude" } } diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-10.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-10.a68 new file mode 100644 index 000000000000..e427181bf533 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-10.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio + = 9; + op + = (int a, b) int: skip; { dg-final { scan-assembler "FOO_u_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-11.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-11.a68 new file mode 100644 index 000000000000..3ba8b68ade2a --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-11.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio - = 9; + op - = (int a, b) int: skip; { dg-final { scan-assembler "FOO_m_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-12.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-12.a68 new file mode 100644 index 000000000000..9efc781f6447 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-12.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio % = 9; + op % = (int a, b) int: skip; { dg-final { scan-assembler "FOO_p_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-13.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-13.a68 new file mode 100644 index 000000000000..483474776224 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-13.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio ^ = 9; + op ^ = (int a, b) int: skip; { dg-final { scan-assembler "FOO_c_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-14.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-14.a68 new file mode 100644 index 000000000000..60ffc3d90dc9 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-14.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio & = 9; + op & = (int a, b) int: skip; { dg-final { scan-assembler "FOO_a_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-15.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-15.a68 new file mode 100644 index 000000000000..9f70993099d9 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-15.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio ~ = 9; + op ~ = (int a, b) int: skip; { dg-final { scan-assembler "FOO_t_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-16.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-16.a68 new file mode 100644 index 000000000000..a5a7d261e2b2 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-16.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio ! = 9; + op ! = (int a, b) int: skip; { dg-final { scan-assembler "FOO_b_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-17.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-17.a68 new file mode 100644 index 000000000000..1f5b52a9d4a0 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-17.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio ? = 9; + op ? = (int a, b) int: skip; { dg-final { scan-assembler "FOO_q_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-18.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-18.a68 new file mode 100644 index 000000000000..a840b14bf501 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-18.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio > = 9; + op > = (int a, b) int: skip; { dg-final { scan-assembler "FOO_g_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-19.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-19.a68 new file mode 100644 index 000000000000..ffcd1cfc79be --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-19.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio < = 9; + op < = (int a, b) int: skip; { dg-final { scan-assembler "FOO_l_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-2.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-2.a68 new file mode 100644 index 000000000000..79fe3d84cd7d --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-2.a68 @@ -0,0 +1,15 @@ +{ dg-options "-O0" } + +module Foo = def pub struct (int i, real r) foo;{ dg-final { scan-assembler "FOO_foo" } } + struct (int i, real r) bar; { dg-final { scan-assembler "FOO_bar" } } + skip + fed, + Bar = def pub struct (int i, real r) foo;{ dg-final { scan-assembler "BAR_foo" } } + struct (int i, real r) bar; { dg-final { scan-assembler "BAR_bar" } } + skip + fed + +{ dg-final { scan-assembler "FOO__prelude" } } +{ dg-final { scan-assembler "FOO__postlude" } } +{ dg-final { scan-assembler "BAR__prelude" } } +{ dg-final { scan-assembler "BAR__postlude" } } diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-20.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-20.a68 new file mode 100644 index 000000000000..fd435c7e50a7 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-20.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio / = 9; + op / = (int a, b) int: skip; { dg-final { scan-assembler "FOO_s_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-21.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-21.a68 new file mode 100644 index 000000000000..05b2b0a6647d --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-21.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio = = 9; + op = = (int a, b) int: skip; { dg-final { scan-assembler "FOO_e_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-22.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-22.a68 new file mode 100644 index 000000000000..d11e9a8e4c88 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-22.a68 @@ -0,0 +1,10 @@ +{ dg-options "-O0" } + +{ Mangling of monads, nomads and : + Unfortunately we cannot do all of them in a single test. } + +module Foo = +def prio +:= = 9; + op +:= = (int a, b) int: skip; { dg-final { scan-assembler "FOO_u_o_e_\[0-9\]+" } } + skip +fed diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-3.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-3.a68 new file mode 100644 index 000000000000..579cb84eac0e --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-3.a68 @@ -0,0 +1,15 @@ +{ dg-options "-O0" } + +module Foo = def pub int foo = 10; { dg-final { scan-assembler "FOO_foo" } } + int bar = 20; { dg-final { scan-assembler "FOO_bar" } } + skip + fed, + Bar = def pub int foo = 30; { dg-final { scan-assembler "BAR_foo" } } + int bar = 40; { dg-final { scan-assembler "BAR_bar" } } + skip + fed + +{ dg-final { scan-assembler "FOO__prelude" } } +{ dg-final { scan-assembler "FOO__postlude" } } +{ dg-final { scan-assembler "BAR__prelude" } } +{ dg-final { scan-assembler "BAR__postlude" } } diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-4.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-4.a68 new file mode 100644 index 000000000000..4bb53949ba3e --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-4.a68 @@ -0,0 +1,17 @@ +{ dg-options "-O0" } + +{ Procedure variable declarations. } + +module Foo = def pub proc int foo; { dg-final { scan-assembler "FOO_foo" } } + proc int bar := int: skip; { dg-final { scan-assembler "FOO_bar" } } + skip + fed, + Bar = def pub proc int foo; { dg-final { scan-assembler "BAR_foo" } } + proc int bar := foo; { dg-final { scan-assembler "BAR_bar" } } + skip + fed + +{ dg-final { scan-assembler "FOO__prelude" } } +{ dg-final { scan-assembler "FOO__postlude" } } +{ dg-final { scan-assembler "BAR__prelude" } } +{ dg-final { scan-assembler "BAR__postlude" } } diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-5.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-5.a68 new file mode 100644 index 000000000000..be29ee190950 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-5.a68 @@ -0,0 +1,17 @@ +{ dg-options "-O0" } + +{ Procedure identity declarations. } + +module Foo = def pub proc foo = int: skip; { dg-final { scan-assembler "FOO_foo" } } + proc bar = int: skip; { dg-final { scan-assembler "FOO_bar" } } + skip + fed, + Bar = def pub proc foo = int: skip; { dg-final { scan-assembler "BAR_foo" } } + proc bar = int: skip; { dg-final { scan-assembler "BAR_bar" } } + skip + fed + +{ dg-final { scan-assembler "FOO__prelude" } } +{ dg-final { scan-assembler "FOO__postlude" } } +{ dg-final { scan-assembler "BAR__prelude" } } +{ dg-final { scan-assembler "BAR__postlude" } } diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-6.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-6.a68 new file mode 100644 index 000000000000..8ba5333ea845 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-6.a68 @@ -0,0 +1,21 @@ +{ dg-options "-O0" } + +{ Operator brief identity declarations. } + +module Foo = def pub op + = (int a, b) int: a + b; + { dg-final { scan-assembler "FOO_u_" } } + op - = (int a, b) int: a - b; + { dg-final { scan-assembler "FOO_m_" } } + skip + fed, + Bar = def pub op + = (int a, b) int: a + b; + { dg-final { scan-assembler "BAR_u_" } } + op - = (int a, b) int: a - b; + { dg-final { scan-assembler "BAR_m_" } } + skip + fed + +{ dg-final { scan-assembler "FOO__prelude" } } +{ dg-final { scan-assembler "FOO__postlude" } } +{ dg-final { scan-assembler "BAR__prelude" } } +{ dg-final { scan-assembler "BAR__postlude" } } diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-7.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-7.a68 new file mode 100644 index 000000000000..5c62a7987875 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-7.a68 @@ -0,0 +1,19 @@ +{ dg-options "-O0" } + +{ Operator identity declarations. } + +module Foo = +def prio // = 8; + pub op(int,int)int // = lala; + { dg-final { scan-assembler "FOO_s_s_" } } + proc lala = (int a, b) int: a + b; + prio JORL = 8, JURL = 9; + pub op(int,int)int JORL = lala; + { dg-final { scan-assembler "FOO_JORL" } } + op(int,int)int JURL = (int a, b) int: a - b; + { dg-final { scan-assembler "FOO_JORL" } } + skip +fed + +{ dg-final { scan-assembler "FOO__prelude" } } +{ dg-final { scan-assembler "FOO__postlude" } } diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-8.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-8.a68 new file mode 100644 index 000000000000..054befb7c6fa --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-8.a68 @@ -0,0 +1,18 @@ +{ dg-options "-O0" } + +{ Symbols that should _not_ include the module name. } + +module Foo = +def begin string foo = "foo'n"; { dg-final { scan-assembler-not "FOO_foo" } } + proc printfoo = void: puts (foo); { dg-final { scan-assembler-not "FOO_printfoo" } } + printfoo + end; + skip +postlude + int lala; + proc incrlala = void: lala +:= 1; { dg-final { scan-assembler-not "FOO_incrlala" } } + incrlala +fed + +{ dg-final { scan-assembler "FOO__prelude" } } +{ dg-final { scan-assembler "FOO__postlude" } } diff --git a/gcc/testsuite/algol68/compile/module-pub-mangling-9.a68 b/gcc/testsuite/algol68/compile/module-pub-mangling-9.a68 new file mode 100644 index 000000000000..6a6bab1211f2 --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-pub-mangling-9.a68 @@ -0,0 +1,14 @@ +{ dg-options "-O0" } + +{ Operator symbols are numbered so having overloaded symbols in the + module's public range works. } + +module Foo = +def prio // =9; + op // = (int a, b) int: a + b; { dg-final { scan-assembler "FOO_s_s_\[0-9\]+" } } + op // = (real a, b) real: a + b; { dg-final { scan-assembler "FOO_s_s_\[0-9\]+" } } + skip +fed + +{ dg-final { scan-assembler "FOO__prelude" } } +{ dg-final { scan-assembler "FOO__postlude" } } diff --git a/gcc/testsuite/algol68/compile/module-top-down-1.a68 b/gcc/testsuite/algol68/compile/module-top-down-1.a68 new file mode 100644 index 000000000000..3f130c25019c --- /dev/null +++ b/gcc/testsuite/algol68/compile/module-top-down-1.a68 @@ -0,0 +1,14 @@ +{ This test is to check that serial clauses and + enquiry clauses are properly skipped in module texts. } +module Foo = +def int i; + int j = 20; + string ss; + prio // = 8; + op // = (int a, b) int: a + b; + proc ticks = void: to i do puts ("tick'n") od; + i := 5 +postlude + if j > 5 then ticks fi; + (j < 0 | puts ("error'n") | puts ("success'n")) +fed diff --git a/gcc/testsuite/algol68/compile/modules/compile.exp b/gcc/testsuite/algol68/compile/modules/compile.exp new file mode 100644 index 000000000000..af254e8e594d --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/compile.exp @@ -0,0 +1,40 @@ +# Copyright (C) 2024 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# Compile tests, no torture testing. +# +# These tests raise errors in the front end; torture testing doesn't apply. + +load_lib algol68-dg.exp + +# Initialize `dg'. +dg-init + +# The programs need to be able to find the built modules, which are +# left in objdir. + +global MODULES_OPTIONS +set MODULES_OPTIONS "-I $objdir" + +# Main loop. +set saved-dg-do-what-default ${dg-do-what-default} + +set dg-do-what-default "compile" +algol68-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/program*.a68]] "" "" +set dg-do-what-default ${saved-dg-do-what-default} + +# All done. +dg-finish diff --git a/gcc/testsuite/algol68/compile/modules/module1.a68 b/gcc/testsuite/algol68/compile/modules/module1.a68 new file mode 100644 index 000000000000..f49a747033e0 --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/module1.a68 @@ -0,0 +1,9 @@ +module Module1 = +def + pub mode MyInt = int; + pub int beast_number := 666; + pub string who = "jemarch"; + puts ("Hello from module'n") +postlude + puts ("Bye from module'n") +fed diff --git a/gcc/testsuite/algol68/compile/modules/module2.a68 b/gcc/testsuite/algol68/compile/modules/module2.a68 new file mode 100644 index 000000000000..57c68e579b81 --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/module2.a68 @@ -0,0 +1,5 @@ +module Module2 = +def prio // = 9; { Note priority is not publicized. } + pub op // = (int a, b) int: a + b; + skip +fed diff --git a/gcc/testsuite/algol68/compile/modules/module3.a68 b/gcc/testsuite/algol68/compile/modules/module3.a68 new file mode 100644 index 000000000000..143a4693593a --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/module3.a68 @@ -0,0 +1,6 @@ +module Module_3 = +def pub proc foo = (int i, string s) void: skip; + pub mode Jorl = struct (int i, string s); + pub mode Jurl = union (int, string, real); + skip +fed diff --git a/gcc/testsuite/algol68/compile/modules/module4.a68 b/gcc/testsuite/algol68/compile/modules/module4.a68 new file mode 100644 index 000000000000..f0ae6e689b4f --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/module4.a68 @@ -0,0 +1,4 @@ +module Module_4 = +def access Module_3 (foo (10, "foo")); + skip +fed diff --git a/gcc/testsuite/algol68/compile/modules/module5.a68 b/gcc/testsuite/algol68/compile/modules/module5.a68 new file mode 100644 index 000000000000..ebb06fb329af --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/module5.a68 @@ -0,0 +1,6 @@ +module Module_5 = +def + pub mode JSON_Val = union (ref JSON_Elm,int), + JSON_Elm = struct (int lala); + skip +fed diff --git a/gcc/testsuite/algol68/compile/modules/module6.a68 b/gcc/testsuite/algol68/compile/modules/module6.a68 new file mode 100644 index 000000000000..b0fefb5522f0 --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/module6.a68 @@ -0,0 +1,5 @@ +module Module6 = + access Module5 +def pub proc getval = JSON_VAl: skip; + skip +fed diff --git a/gcc/testsuite/algol68/compile/modules/module7.a68 b/gcc/testsuite/algol68/compile/modules/module7.a68 new file mode 100644 index 000000000000..f585171bf277 --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/module7.a68 @@ -0,0 +1,5 @@ +module Module7 = +access Module5, Module6 +def pub JSON_Val val = getval; + skip +fed diff --git a/gcc/testsuite/algol68/compile/modules/module8.a68 b/gcc/testsuite/algol68/compile/modules/module8.a68 new file mode 100644 index 000000000000..8704474436ce --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/module8.a68 @@ -0,0 +1,5 @@ +module Module_8 = +def + pub proc lala = ([]struct (string n, v) arg) void: skip; + skip +fed diff --git a/gcc/testsuite/algol68/compile/modules/module9.a68 b/gcc/testsuite/algol68/compile/modules/module9.a68 new file mode 100644 index 000000000000..55afd6fef75f --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/module9.a68 @@ -0,0 +1,6 @@ +module Module_9 = +def + pub mode Foo = struct (flex[1:0]Event events); + pub mode Event = int; + skip +fed diff --git a/gcc/testsuite/algol68/compile/modules/program-7.a68 b/gcc/testsuite/algol68/compile/modules/program-7.a68 new file mode 100644 index 000000000000..a3cb1bf2a725 --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/program-7.a68 @@ -0,0 +1,3 @@ +{ dg-modules "module5 module6 module7" } + +access Module7 (skip) diff --git a/gcc/testsuite/algol68/compile/modules/program-8.a68 b/gcc/testsuite/algol68/compile/modules/program-8.a68 new file mode 100644 index 000000000000..ba7675503987 --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/program-8.a68 @@ -0,0 +1,3 @@ +{ dg-modules "module8" } + +access Module_8 ( lala ((("foo", "bar"), ("baz", "quux"))) ) diff --git a/gcc/testsuite/algol68/compile/modules/program-9.a68 b/gcc/testsuite/algol68/compile/modules/program-9.a68 new file mode 100644 index 000000000000..585607ae36b6 --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/program-9.a68 @@ -0,0 +1,3 @@ +{ dg-modules "module9" } + +access Module_9 (skip) diff --git a/gcc/testsuite/algol68/compile/modules/program-error-no-prio-1.a68 b/gcc/testsuite/algol68/compile/modules/program-error-no-prio-1.a68 new file mode 100644 index 000000000000..dcca8a9baeb8 --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/program-error-no-prio-1.a68 @@ -0,0 +1,6 @@ +{ dg-modules "module2" } + +access Module_2 +begin assert (2 // 3 = 5); { dg-error "no priority" } + skip +end diff --git a/gcc/testsuite/algol68/compile/modules/program-error-outside-access-1.a68 b/gcc/testsuite/algol68/compile/modules/program-error-outside-access-1.a68 new file mode 100644 index 000000000000..39f0f1896f81 --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/program-error-outside-access-1.a68 @@ -0,0 +1,6 @@ +{ dg-modules "module1" } + +begin int x = access Module1 ( beast_number ), + y = beast_number; { dg-error "declared" } + skip +end diff --git a/gcc/testsuite/algol68/compile/modules/program-module-accesses-module-1.a68 b/gcc/testsuite/algol68/compile/modules/program-module-accesses-module-1.a68 new file mode 100644 index 000000000000..7ba7804636cf --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/program-module-accesses-module-1.a68 @@ -0,0 +1,5 @@ +{ dg-modules "module3 module4" } +{ This test accesses a Module4 that itself accesses a Module3. } + +access Module_4 (skip) + diff --git a/gcc/testsuite/algol68/compile/modules/program-proc-arg-order-1.a68 b/gcc/testsuite/algol68/compile/modules/program-proc-arg-order-1.a68 new file mode 100644 index 000000000000..eecf6867ba1f --- /dev/null +++ b/gcc/testsuite/algol68/compile/modules/program-proc-arg-order-1.a68 @@ -0,0 +1,8 @@ +{ dg-modules "module3" } + +access Module_3 +begin foo (10, "foo"); + Jorl x = (10, "foo"); + Jurl y = 3.14; + skip +end diff --git a/gcc/testsuite/algol68/compile/nested-comment-1.a68 b/gcc/testsuite/algol68/compile/nested-comment-1.a68 new file mode 100644 index 000000000000..f5752435a0e8 --- /dev/null +++ b/gcc/testsuite/algol68/compile/nested-comment-1.a68 @@ -0,0 +1,4 @@ +{ Comment delimiters within strings get ignored. } +begin { puts { ("{""'n"); } } + skip +end diff --git a/gcc/testsuite/algol68/compile/nested-comment-2.a68 b/gcc/testsuite/algol68/compile/nested-comment-2.a68 new file mode 100644 index 000000000000..9fc912f26872 --- /dev/null +++ b/gcc/testsuite/algol68/compile/nested-comment-2.a68 @@ -0,0 +1,6 @@ +{ The string in nested comment is in one logical line. } +begin + { puts ("{'n\ +"); { this prints foo }} + skip +end diff --git a/gcc/testsuite/algol68/compile/operators-firmly-related.a68 b/gcc/testsuite/algol68/compile/operators-firmly-related.a68 new file mode 100644 index 000000000000..a7efe750219a --- /dev/null +++ b/gcc/testsuite/algol68/compile/operators-firmly-related.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN PRIO MIN = 6; + OP MIN = (REF REAL a, b) REF REAL: (a < b | a | b), # { dg-error "firmly related" } # + MIN = (REAL a, b) REAL: (a < b | a | b); # { dg-error "firmly related" } # + SKIP +END diff --git a/gcc/testsuite/algol68/compile/recursive-modes-1.a68 b/gcc/testsuite/algol68/compile/recursive-modes-1.a68 new file mode 100644 index 000000000000..4a77a5646bef --- /dev/null +++ b/gcc/testsuite/algol68/compile/recursive-modes-1.a68 @@ -0,0 +1,33 @@ +# { dg-options "-fstropping=upper" } # + +# This program triggered a bug related to incomplete modes. # +BEGIN MODE REC_MSET = STRUCT (REF REC_MSET_ELM head, tail, + INT num elems, + PROC(REC_MSET_DATA)BOOL gate), + REC_MSET_ELM = STRUCT (REC_MSET_DATA data, BOOL mark, REF REC_MSET_ELM next), + REC_MSET_DATA = UNION (REC_RSET,REC_RECORD,REC_FIELD,REC_CMNT), + REC_RSET = STRUCT (REC_MSET mset, + INT min size, max size, + REF REC_RECORD descriptor), + REC_RECORD = STRUCT (REC_LOC loc, REC_MSET mset, INT foo), + REC_CMNT = STRUCT (REC_LOC loc, STRING content), + REC_FIELD = STRUCT (REC_LOC loc, STRING name, value), + REC_LOC = STRUCT (STRING source, INT line, char); + + PROC rec loc unknown = REC_LOC: + ("unknown", 0, 0); + PROC rec record gate = (REC_MSET_DATA d) BOOL: + (d | (REC_FIELD): TRUE, (REC_CMNT): TRUE | FALSE); + REF REC_MSET_ELM rec no mset elm = NIL; + + PROC rec mset new = (PROC(REC_MSET_DATA)BOOL gate) REC_MSET: + (HEAP REC_MSET := (rec no mset elm, rec no mset elm, + 0, gate)); + + REF REC_RECORD rec no record = NIL; + + PROC rec record new = REF REC_RECORD: + HEAP REC_RECORD := (rec loc unknown, rec mset new (rec record gate), 0); + + SKIP +END diff --git a/gcc/testsuite/algol68/compile/recursive-modes-2.a68 b/gcc/testsuite/algol68/compile/recursive-modes-2.a68 new file mode 100644 index 000000000000..f79b214d0751 --- /dev/null +++ b/gcc/testsuite/algol68/compile/recursive-modes-2.a68 @@ -0,0 +1,7 @@ +begin mode Word = union (int, struct (ref Word w)), + Value = union (void,Word), + Stack = struct (ref Stack prev, Value val); + + struct (Word a) qs; { type_2 has no size! } + skip +end diff --git a/gcc/testsuite/algol68/compile/serial-clause-jump-1.a68 b/gcc/testsuite/algol68/compile/serial-clause-jump-1.a68 new file mode 100644 index 000000000000..f4e3773ba53a --- /dev/null +++ b/gcc/testsuite/algol68/compile/serial-clause-jump-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # + +# This is an infinite loop, but it should compile just fine an yield + an integer after infinite time. # + +BEGIN foo: foo +END diff --git a/gcc/testsuite/algol68/compile/snobol.a68 b/gcc/testsuite/algol68/compile/snobol.a68 new file mode 100644 index 000000000000..9b6c4fc824fa --- /dev/null +++ b/gcc/testsuite/algol68/compile/snobol.a68 @@ -0,0 +1,1100 @@ +# { dg-options "-fstropping=upper" } # + +# This is Frank Pagan's SNOBOL4 Interpreter in ALGOL 68 (1976), + fetched from Dick Grune's page https://dickgrune.com/CS/Algol68/ + + The interpreter described in "Algol 68 as an Implementation Language\ + for Portable Interpreters", ACM SIGPLAN Notices - Proceedings of the + Strathclyde ALGOL 68 conference, Volume 12 Issue 6, June 1977, + pp. 54 - 62, and "A Highly-Structured Interpreter for a SNOBOL4 + Subset", Software: Practice and Experience, Vol. 9, 4, + pp. 281-312, April 1979. + + Modifications by Jose E. Marchesi: + - Use the simple POSIX-like transput provided by GCC. + - Read programs from lines rather than from cards. + - Add command-line option -l (listing). +# + +BEGIN PROC itoa = (INT i) STRING: + BEGIN IF i = 0 + THEN "0" + ELSE INT n := ABS i; + STRING res; + WHILE n /= 0 + DO INT rem = n %* 10; + res := REPR (rem > 9 | (rem - 10) + ABS "a" | rem + ABS "0") + res; + n %:= 10 + OD; + (i < 0 | "-" + res | res) + FI + END; + + CHAR sharp = REPR 35; # Sharp character, + to avoid confusing Emacs. # + + # Input file. # + INT filein; + + # IMPLEMENTATION RESTRICTIONS # + INT spoolsize = 400, + stlim = 50, + arglim = 5, + rslim = 80, + pslim = 20, + ftlim = 10; + + # ABSTRACT MACHINE # + MODE ITEM = UNION (INT, REF STRINGITEM, PATTERN), + STRINGITEM = STRUCT (STRING val, REF ITEM ref), + PATTERN = REF[]COMPONENT, + COMPONENT = STRUCT (INT routine, subsequent, alternate, extra, + REF ITEM arg), + PSENTRY = STRUCT (INT cursor, alternate), + RSENTRY = REF ITEM, + FTENTRY = STRUCT (REF ITEM fnname, entry name, + REF[]REF ITEM params, locals); + + [1:spoolsize] REF ITEM spool; + [1:pslim] PSENTRY pattern stack; + [1:rslim] RSENTRY run stack; + [1:ftlim] FTENTRY function table; + + BOOL failed := FALSE; + INT nin, psp, rsp := 0, ftp := 0; + INT mstr = 1, mlen = 2, mbrk = 3, mspn = 4, many = 5, mnul = 6, + miv1 = 7, miv2 = 8, m1 = 9, mat = 10, mpos = 11, mtab = 12, + mrpos = 13, mrtab = 14, mnty = 15; + + # INTERNAL FORM OF PROGRAMS # + + MODE STMT = STRUCT (REF IDR label, + UNION (REF ASMT, REF MATCH, + REF REPL, REF EXPR) stmt core, + REF GOTOFIELD goto), + IDR = STRUCT (REF ITEM idr addr), + NUM = STRUCT (REF ITEM num addr), + LSTR = STRUCT (REF ITEM lstr addr), + ASMT = STRUCT (REF EXPR subject, object), + MATCH = STRUCT (REF EXPR subject, pattern), + REPL = STRUCT (REF EXPR subject, pattern, object), + EXPR = UNION (REF UNARYEXPR, REF BINARYEXPR, IDR, NUM, + LSTR, REF CALL), + GOTOFIELD = STRUCT (REF DEST upart, spart, fpart), + DEST = UNION (REF EXPR, CHAR), + UNARYEXPR = STRUCT (REF EXPR operand, CHAR operator), + BINARYEXPR = STRUCT (REF EXPR operand1, operand2, + CHAR operator), + CALL = STRUCT (IDR fnname, REF[]REF EXPR args); + + REF[]STMT t; + REF ITEM prog entry := NIL; + + PROC error = (STRING mess) VOID: + (puts ("error: " + mess + "'n"); stop); + + # TRANSLATION PHASE # + + BEGIN # DECLARATIONS FOR SCANNER # + STRING card, INT cp, # SOURCE LINE AND POINTER # + CHAR ch, # SOURCE CHARACTER # + [1:80]CHAR str, INT sp, # STRING BUFFER AND POINTER # + CHAR tok, # TOKEN CODE # + REF ITEM psn, # POSITION OF A CREATED VALUE # + INT nv, # NUMERIC VALUE OF CONSTANT # + INT stn, # SOURCE STATEMENT NUMBER # + BOOL listing, # FLAG FOR SOURCE LISTING # + CHAR c; # TEMPORARY # + + # TOKEN MNEMONICS # + CHAR doll = "$", bdoll = "D", + plus = "+", bplus = "P", + minus = "-", bminus = "M", + at = "@", bbar = "!", + bstar = "*", bslash = "/", + lpar = "(", rpar = ")", + comma = ",", colon = ":", + equal = "=", blank = " ", + eos = ";", name = "A", + lstring = "L", number = "U", + endt = "E", ret = "R", + fret = "F", stok = "Y", + ftok = "Z"; + + PROC get card = VOID: + BEGIN cp := 0; + WHILE card := fgets (filein, 80); + IF UPB card = 0 THEN exit FI; + c := card[1]; + IF c /= "." AND c /= "+" AND c /= "-" AND c /= "*" + THEN stn := stn + 1 FI; + IF listing THEN puts (itoa (stn) + " " + card + "'n") FI; + IF c = "-" + THEN IF card[2:5] = "LIST" + THEN listing := TRUE + ELIF card[2:7] = "UNLIST" + THEN listing := FALSE + FI + FI; + c = "-" OR c = "*" + DO SKIP OD; + exit: SKIP + END; + + PROC next ch = VOID: + IF cp = UPB card + THEN get card; + IF c = "." OR c = "+" + THEN ch := " "; cp := 1 + ELSE ch := sharp # END OF LINE AND STATEMENT # + FI + ELSE ch := card[cp +:= 1] + FI; + + PROC lookup = (STRING sv) REF ITEM : ( + INT i := 0, BOOL nf := TRUE; + WHILE IF (i +:= 1) <= nin + THEN nf := sv /= val OF (spool[i] | (REF STRINGITEM s) : s) + ELSE FALSE + FI + DO SKIP OD; + IF nf + THEN IF nin = spoolsize THEN error ("too many strings") FI; + spool[nin +:= 1] := HEAP ITEM := HEAP STRINGITEM := + (sv, NIL) + FI; + spool[i]); + + PROC scan = VOID: + IF ch = " " # BLANKS AND BINARY OPERATORS # + THEN WHILE next ch; ch = " " DO SKIP OD; + # IGNORE TRAILING BLANKS IN A STATEMENT # + IF ch = ";" THEN next ch; stn := stn + 1; tok := eos + ELIF ch = sharp THEN next ch; tok := eos + ELIF ch = "!" OR ch = "$" OR ch = "+" OR ch = "-" + OR ch = "*" OR ch = "/" + THEN IF card[cp+1] = " " + THEN c := ch; + WHILE next ch; ch = " " DO SKIP OD ; + tok := (c = "!" | bbar + |: c = "$" | bdoll + |: c = "-" | bminus + |: c = "+" | bplus + |: c = "*" | bstar + | bslash) + ELSE tok := blank + FI + ELSE tok := blank + FI + ELIF ch = "''" OR ch = """" # LITERAL STRINGS # + THEN c := ch; sp := 0; + WHILE next ch; + IF ch = sharp THEN error ("UNTERMINATED LITERAL") FI; + (str[sp +:= 1] := ch) /= c + DO SKIP OD ; + next ch; + tok := lstring; + IF sp = 1 + THEN psn := NIL + ELSE STRING s = str[1:sp-1] ; + psn := lookup (s) + FI + ELIF ch >= "0" AND ch <= "9" # NUMBERS # + THEN nv := 0 ; + WHILE nv := nv * 10 + ABS ch - ABS "0"; + next ch; + ch >= "0" AND ch <= "9" + DO SKIP OD ; + tok := number; + psn := HEAP ITEM := nv + ELIF ch >= "A" AND ch <= "Z" # NAMES # + THEN sp := 0; + WHILE str[sp +:= 1] := ch; + next ch; + ch = "." OR ch >= "A" AND ch <= "Z" + OR ch >= "0" AND ch <= "9" + DO SKIP OD ; + STRING s = str[1:sp]; + tok := (s = "S" | stok + |: s = "F" | ftok + |: s = "END" | endt + |: s = "RETURN" | ret + |: s = "FRETURN" | fret + | psn := lookup (s); name) + ELIF ch = ";" + THEN next ch; stn := stn + 1; tok := eos + ELIF ch = sharp + THEN next ch; tok := eos + ELSE # ( ) , : = @ $ + - # + tok := ch; next ch + FI; + + PROC init = VOID: + BEGIN stn := 0; + spool[nin := 1] := HEAP ITEM := HEAP STRINGITEM := + ("ARB", HEAP ITEM := HEAP[1:3]COMPONENT := + ((mnul, 2, 0, SKIP, NIL), + (mnul, 0, 3, SKIP, NIL), + (m1, 2, 0, SKIP, NIL))); + get card; + next ch; + scan + END; + + PROC verify = (CHAR token) VOID: + IF tok = token THEN scan + ELSE STRING s := "TOKEN "" "" DOES NOT OCCUR WHERE EXPECTED"; + s[8] := token; + error (s) + FI; + + PROC translate = VOID: + BEGIN HEAP[1:stlim]STMT ss, INT ssc := 0; + WHILE IF ssc = stlim THEN error ("TOO MANY STATEMENTS") FI; + tok /= endt + DO ss[ssc +:= 1] := trans stmt OD; + scan; + IF tok = blank + THEN scan; + IF tok = name THEN prog entry := psn FI + FI; + t := ss[1:ssc] + END; + + PROC trans stmt = STMT: + BEGIN + REF IDR lab := NIL; + REF EXPR subj, pat, obj := NIL; + REF GOTOFIELD go := NIL; + BOOL asgn; + + PROC move to obj = STMT: + BEGIN + IF tok = blank + THEN scan; + IF tok = colon + THEN go := trans gofield + ELSE obj := trans expr; + IF tok = colon + THEN go := trans gofield + ELSE verify (eos) + FI + FI + ELSE verify (eos) + FI ; + IF asgn + THEN STMT (lab, HEAP ASMT := (subj, obj), go) + ELSE STMT (lab, HEAP REPL := (subj, pat, obj), go) + FI + END; + + PROC move to subj = STMT: + BEGIN scan; + IF tok = colon + THEN STMT (lab, REF EXPR (NIL), trans gofield) + ELSE subj := trans elem; + IF tok = blank + THEN scan; + IF tok = colon + THEN STMT (lab, REF EXPR (subj), trans gofield) + ELIF tok = equal + THEN asgn := TRUE; scan; move to obj + ELSE pat := trans expr; + IF tok = colon + THEN STMT (lab, HEAP MATCH := (subj, pat), trans gofield) + ELIF tok = equal + THEN asgn := FALSE; scan; move to obj + ELSE verify (eos); + STMT (lab, HEAP MATCH := (subj, pat), NIL) + FI + FI + ELSE verify (eos); + STMT (lab, REF EXPR (subj), NIL) + FI + FI + END; + + # Body of trans stmt. # + IF tok = name + THEN lab := HEAP IDR; idr addr OF lab := psn; scan; + IF tok = blank + THEN move to subj + ELSE verify (eos); + STMT (lab, REF EXPR (NIL), NIL) + FI + ELIF tok = blank + THEN move to subj + ELSE verify (eos); + STMT (lab, REF EXPR (NIL), NIL) + FI + END; + + PROC trans gofield = REF GOTOFIELD: + BEGIN PROC where = REF DEST: + BEGIN HEAP DEST d; + verify (lpar); + IF tok = blank THEN scan FI; + d := (tok = endt | scan; "E" + |: tok = ret | scan; "R" + |: tok = fret | scan; "F" + | trans expr); + verify (rpar); + d + END; + + REF DEST uncond := NIL, succ := NIL, fail := NIL; + scan; IF tok = blank THEN scan FI; + IF tok = stok + THEN scan; succ := where; + IF tok = blank THEN scan FI; + IF tok = ftok THEN scan; fail := where FI; + verify (eos) + ELIF tok = ftok + THEN scan; fail := where; + IF tok = blank THEN scan FI; + IF tok = stok THEN scan; succ := where FI; + verify (eos) + ELSE uncond := where; verify (eos) + FI; + HEAP GOTOFIELD := (uncond, succ, fail) + END; + + PROC trans expr = REF EXPR: + BEGIN REF EXPR e := trans expr1; + WHILE tok = bbar + DO scan; + e := HEAP EXPR := HEAP BINARYEXPR := (e, trans expr1, "!") + OD; + e + END; + + PROC trans expr1 = REF EXPR: + BEGIN REF EXPR e := trans expr2; + WHILE tok = blank + DO scan; + IF tok /= colon AND tok /= rpar AND tok /= comma AND tok /= equal + THEN e := HEAP EXPR := HEAP BINARYEXPR := (e, trans expr2, "C") + FI + OD; + e + END; + + PROC trans expr2 = REF EXPR: + BEGIN REF EXPR e := trans term; + CHAR opr; + WHILE tok = bplus OR tok = bminus + DO opr := (tok = bplus | "+" | "-"); + scan; + e := HEAP EXPR := HEAP BINARYEXPR := (e, trans term, opr) + OD; + e + END; + + PROC trans term = REF EXPR: + BEGIN REF EXPR e := trans term1; + WHILE tok = bslash + DO scan; + e := HEAP EXPR := HEAP BINARYEXPR := (e, trans term1, "/") + OD; + e + END; + + PROC trans term1 = REF EXPR: + BEGIN REF EXPR e := trans term2; + WHILE tok = bstar + DO scan; + e := HEAP EXPR := HEAP BINARYEXPR := (e, trans term2, "*") + OD; + e + END; + + PROC trans term2 = REF EXPR: + BEGIN REF EXPR e := trans elem; + WHILE tok = bdoll + DO scan; + e := HEAP EXPR := HEAP BINARYEXPR := (e, trans elem, "$") + OD; + e + END; + + PROC trans elem = REF EXPR: + IF tok = doll OR tok = plus OR tok = minus OR tok = at + THEN CHAR opr = tok; + scan; + HEAP EXPR := HEAP UNARYEXPR := (trans element, opr) + ELSE trans element + FI; + + PROC trans element = REF EXPR: + IF tok = name + THEN IDR n; + idr addr OF n := psn; + scan; + IF tok /= lpar + THEN HEAP EXPR := n + ELSE HEAP[1:arglim]REF EXPR a, INT ac := 0; + WHILE scan; + IF tok = blank THEN scan FI; + IF ac = arglim + THEN error ("TOO MANY ARGUMENTS IN FUNCTION CALL") + FI; + IF NOT (ac = 0 AND tok = rpar) + THEN a[ac +:= 1] := (tok = comma OR tok = rpar | NIL | trans expr) + FI; + IF tok /= comma AND tok /= rpar + THEN error ("ERROR IN ARGUMENT LIST") + FI; + tok = comma + DO SKIP OD; + scan; + HEAP EXPR := HEAP CALL := (n, a[1:ac]) + FI + ELIF tok = lstring + THEN LSTR ls; + lstr addr OF ls := psn; + scan; + HEAP EXPR := ls + ELIF tok = number + THEN NUM nu; num addr OF nu := psn; + scan; + HEAP EXPR := nu + ELSE verify (lpar); + IF tok = blank THEN scan FI; + REF EXPR e = trans expr; + verify (rpar); + e + FI; + + PROC usage = VOID: + BEGIN puts ("Usage: snobol [-l] FILE'n"); + stop + END; + + listing := FALSE; + IF argc < 2 THEN usage FI; + FOR i FROM 2 TO argc + DO IF argv (i) = "-l" THEN listing := TRUE + ELIF filein = 0 + THEN filein := fopen (argv (i), file o rdonly); + IF (filein = -1) + THEN error ("opening " + argv (i) + ": " + strerror (errno)) FI + ELSE usage + FI + OD; + init; + translate + END; # TRANSLATION PHASE # + + BEGIN # INTERPRETATION PHASE # + + OP INTG = (REF ITEM a) INT: (a | (INT i) : i), + STR = (REF ITEM a) REF STRINGITEM: (a | (REF STRINGITEM s): s), + PAT = (REF ITEM a) PATTERN: (a | (PATTERN p) : p); + BOOL fn success; + + PROC interpret = (INT stmt no) VOID: + BEGIN INT sn := stmt no; BOOL cycling := TRUE; + + PROC jump = (REF DEST dest) VOID: + BEGIN failed := FALSE; + CASE dest + IN (REF EXPR e): sn := find label (eval softly (e)), + (CHAR c): IF c = "E" THEN sn := UPB t + 1 + ELIF c = "R" THEN fn success := TRUE; + cycling := FALSE + ELSE # c = "F" # fn success := cycling := FALSE + FI + ESAC + END; + + WHILE cycling + DO IF sn > UPB t THEN stop FI; + failed := FALSE; + + # EXECUTE STATEMENT CORE # + CASE stmt core OF t[sn] + IN (REF ASMT a): + (REF ITEM sp = eval softly (subject OF a); + assign (sp, eval strongly (object OF a))), + (REF MATCH m): + (REF ITEM svp = eval strongly (subject OF m); + match (convert to str (svp), + convert to pat (eval strongly (pattern OF m)))), + (REF REPL r): + (REF ITEM sp = eval softly (subject OF r); + REF ITEM pp = convert to pat (eval strongly (pattern OF r)); + REF ITEM svp = convert to str (ref OF (STR sp)); + INT c = match (svp, pp); + REF ITEM b = (svp IS NIL | NIL | make str ((val OF (STR svp))[c+1:])); + REF ITEM obp = eval strongly (object OF r); + assign (sp, concatenate (obp, b))), + (REF EXPR e): + eval strongly (e) + ESAC; + + # PROCESS GOTO FIELD # + REF GOTOFIELD go = goto OF t[sn]; + IF go IS NIL THEN sn := sn + 1 + ELIF REF DEST (upart OF go) ISNT NIL + THEN jump (upart OF go) + ELIF NOT failed AND (REF DEST (spart OF go) ISNT NIL) + THEN jump (spart OF go) + ELIF failed AND (REF DEST (fpart OF go) ISNT NIL) + THEN jump (fpart OF go) + ELSE sn := sn + 1 + FI + OD + END; # END OF INTERPRET # + + PROC find label = (REF ITEM label ptr) INT: + BEGIN INT stmt no := 0; + IF failed THEN error ("FAILURE IN GOTO FIELD") FI; + FOR i TO UPB t WHILE stmt no = 0 + DO IF (REF IDR (label OF t[i]) IS NIL + | FALSE + | label ptr IS idr addr OF label OF t[i]) + THEN stmt no := i + FI + OD; + IF stmt no = 0 THEN error ("UNDEFINED LABEL") FI; + stmt no + END; + + PROC match = (REF ITEM subject ptr, pattern ptr) INT: + IF failed + THEN 0 + ELSE PATTERN p = PAT pattern ptr; + STRING subj = (subject ptr IS NIL | "" | val OF (STR subject ptr)); + INT u = UPB subj; + INT iarg, # INTEGER COMPONENT ARGUMENT # + STRING sarg, # STRING COMPONENT ARGUMENT # + INT l; # LENGTH OF SARG # + INT cn := 1, # COMPONENT NUMBER # + c := 0, # CURSOR # + code; # NEW CURSOR OR -1 IF COMPONENT NO-MATCH # + BOOL matching := TRUE; + + psp := 0; # CLEAR PATTERN STACK # + WHILE matching + DO IF alternate OF p[cn] /= 0 + THEN # PUSH PATTERN STACK # + pattern stack[psp +:= 1] := (c, alternate OF p[cn]) + FI; + IF REF ITEM (arg OF p[cn]) ISNT NIL + THEN CASE arg OF p[cn] + IN (INT i) : iarg := i, + (REF STRINGITEM s): + (sarg := val OF s; l := UPB sarg) + ESAC + FI; + + # EXECUTE INDICATED MATCHING ROUTINE # + CASE routine OF p[cn] + IN # MSTR # + IF REF ITEM (arg OF p[cn]) IS NIL + THEN code := c + ELIF c + l > u THEN code := -1 + ELSE code := (sarg = subj[c+1:c+l] | c + l | -1) + FI, + # MLEN # + code := (iarg <= u - c | c + iarg | -1), + # MBRK # + IF c >= u THEN code := -1 + ELSE INT n = break scan (subj[c+1:], sarg); + code := (n < u - c | c + n | -1) + FI, + # MSPN # + IF c >= u THEN code := -1 + ELIF any (sarg, subj[c+1]) + THEN INT j := c + 1; + FOR i FROM c + 2 TO u WHILE any (sarg, subj[i]) + DO j := i OD; + code := j + ELSE code := -1 + FI, + # MANY # + IF c >= u + THEN code := -1 + ELSE code := (any (sarg, subj[c+1]) | c + 1 | -1) + FI, + # MNUL # + code := c, + # MIV1 # + code := extra OF p[cn] := c, + # MIV2 # + (INT m = extra OF p[cn - extra OF p[cn]] + 1; + assign (arg OF p[cn], make str (subj[m:c])); + code := c), + # M1 # + code := (1 <= u - c | c + 1 | -1), + # MAT # + (assign (arg OF p[cn], make int (c)); + code := c), + # MPOS # + code := (c = iarg | c | -1), + # MTAB # + code := (c <= iarg AND iarg <= u | iarg | -1), + # MRPOS # + code := (u - c = iarg | c | -1), + # MRTAB # + code := (u - c >= iarg | u - iarg | -1), + # MNTY # + IF c >= u + THEN code := -1 + ELSE code := (any (sarg, subj[c+1]) | -1 | c + 1) + FI + ESAC; + + # DECIDE WHAT TO DO NEXT # + IF code >= 0 + THEN IF subsequent OF p[cn] = 0 + THEN matching := FALSE #SUCCESSFUL TERMINATION # + ELSE cn := subsequent OF p[cn]; + c := code # CONTINUE # + FI + ELIF psp = 0 + THEN failed := TRUE; + matching := FALSE # STMT FAILURE # + ELSE # POP PATTERN STACK TO BACKTRACK # + cn := alternate OF pattern stack[psp]; + c := cursor OF pattern stack[psp]; + psp := psp - 1 + FI + OD; + (failed | 0 | code) + FI; # END OF MATCH PROCEDURE # + + PROC assign = (REF ITEM subject ptr, object ptr) VOID: + IF failed THEN SKIP + ELSE REF STRINGITEM s = STR subject ptr; + ref OF s := object ptr; + IF val OF s = "OUTPUT" + THEN IF object ptr IS NIL + THEN puts ("'n") + ELSE CASE object ptr + IN (REF STRINGITEM r): puts ((val OF r) + "'n"), + (INT i): puts (itoa (i) + "'n"), + (PATTERN): (error ("ATTEMPT TO OUTPUT PATTERN"); SKIP) + ESAC + FI + FI + FI; + + PROC eval softly = (REF EXPR expression) REF ITEM: + IF failed THEN SKIP + ELSE CASE expression # CAN NEVER BE NIL # + IN (IDR id): idr addr OF id, + (REF UNARYEXPR ue): + IF operator OF ue = "$" + THEN REF ITEM r = convert to str (eval strongly (operand OF ue)); + IF r IS NIL + THEN error ("NULL RESULT WHERE VAR REQUIRED"); + SKIP + ELSE r + FI + ELSE error ("INAPPROPRIATE UNARY EXPR WHERE VAR REQUIRED"); + SKIP + FI + OUT error ("INAPPROPRIATE EXPR WHERE VAR REQUIRED"); + SKIP + ESAC + FI; + + PROC eval strongly = (REF EXPR expression) REF ITEM: + IF failed THEN SKIP + ELIF expression IS NIL THEN NIL + ELSE CASE expression + IN (IDR id): + (REF STRINGITEM s = STR (idr addr OF id); + IF val OF s = "INPUT" + THEN STRING line; + # SNOBOL programs read data from stdin. # + line := gets (80); + IF (line = "") THEN failed := TRUE; eof FI; + assign (idr addr OF id, make str (line)); + eof: SKIP + FI; + ref OF s), + (NUM nbr): + num addr OF nbr, + (LSTR ls): + lstr addr OF ls, + (REF UNARYEXPR ue): + (REF ITEM arg ptr = (operator OF ue = "@" + | eval softly (operand OF ue) + | eval strongly (operand OF ue)); + eval unary (arg ptr, operator OF ue)), + (REF BINARYEXPR be): + (REF ITEM arg1 ptr = eval strongly (operand1 OF be); + REF ITEM arg2 ptr = (operator OF be = "$" + | eval softly (operand2 OF be) + | eval strongly (operand2 OF be)); + eval binary (arg1 ptr, arg2 ptr, operator OF be)), + (REF CALL cl): + (INT n = UPB args OF cl; + [1:n]REF ITEM arglist; + FOR i TO n + DO arglist[i] := eval strongly ((args OF cl)[i]) OD; + eval call (idr addr OF fnname OF cl, arglist)) + ESAC + FI; + + PROC eval unary = (REF ITEM arg ptr, CHAR opr) REF ITEM: + IF failed THEN SKIP + ELSE IF opr = "$" + THEN IF arg ptr IS NIL + THEN error ("INDIRECTION APPLIED TO NULL STRING"); + SKIP + ELSE ref OF (STR convert to str (arg ptr)) + FI + ELIF opr = "+" + THEN convert to int (arg ptr) + ELIF opr = "-" + THEN INT k = INTG convert to int (arg ptr); + make int (-k) + ELSE # OPR = "@" # + make pat comp (mat, arg ptr) + FI + FI; + + PROC eval binary = (REF ITEM arg1 ptr, arg2 ptr, CHAR opr) REF ITEM: + IF failed THEN SKIP + ELSE IF opr = "$" + THEN REF ITEM c = concatenate (make pat comp (miv1, NIL), + arg1 ptr); + concatenate (c, make pat comp (miv2, arg2 ptr)) + ELIF opr = "*" OR opr = "/" OR opr = "+" OR opr = "-" + THEN INT m = INTG convert to int (arg1 ptr), + n = INTG convert to int (arg2 ptr); + make int ((opr = "*" | m * n + |: opr = "/" | m OVER n + |: opr = "+" | m + n | m - n)) + ELIF opr = "C" + THEN concatenate (arg1 ptr, arg2 ptr) + ELSE # OPR = "!" # + PATTERN p1 = PAT convert to pat (arg1 ptr), + p2 = PAT convert to pat (arg2 ptr); + INT u1 = UPB p1, u2 = UPB p2; + PATTERN p = HEAP[u1 + u2]COMPONENT, + INT offset = u1 + 1, INT j := 1; + p[1:u1] := p1[1:u1]; + WHILE alternate OF p[j] /= 0 + DO j := alternate OF p[j] OD; + alternate OF p[j] := offset; + FOR i FROM offset TO u1 + u2 + DO p[i] := p2 [i - u1]; + IF subsequent OF p[i] /= 0 + THEN subsequent OF p[i] +:= u1 + FI; + IF alternate OF p[i] /= 0 + THEN alternate OF p[i] +:= u1 + FI + OD; + HEAP ITEM := p + FI + FI; + + PROC eval call = (REF ITEM name ptr, REF[]REF ITEM arglist) REF ITEM: + IF failed THEN SKIP + ELSE # SEARCH FUNCTION TABLE FOR NAME # + BOOL not found := TRUE, INT j; + FOR i TO ftp WHILE not found + DO IF name ptr IS fnname OF function table[i] + THEN j := i; not found := FALSE + FI + OD; + IF not found + THEN exec prim fn (name ptr, arglist) + ELSE #PROGRAMMER-DEFINED FUNCTION # + + PROC stack = (REF ITEM a) VOID: + (IF rsp = rslim THEN error ("RUN STACK OVERFLOW") FI; + run stack [rsp +:= 1] := a); + + PROC unstack = REF ITEM: + (IF rsp = 0 THEN error ("RETURN FROM LEVEL 0") FI; + run stack [(rsp -:= 1) + 1]); + + REF STRINGITEM name = STR name ptr; + + # ENTRY PROTOCOL # + stack (ref OF name); + assign (name ptr, NIL); + REF[]REF ITEM params = params OF function table[j], + INT n = UPB arglist; + IF UPB params /= n + THEN error ("WRONG NUMBER OF ARGUMENTS IN CALL") + FI; + FOR i TO n + DO stack (ref OF (STR params[i])); + assign (params[i], arglist[i]) + OD; + REF[]REF ITEM locals = locals OF function table[j]; + FOR i TO UPB locals + DO stack (ref OF (STR locals[i])); + assign (locals[i], NIL) + OD; + + interpret (find label (entry name OF function table[j])); + + # RETURN PROTOCOL # + FOR i FROM UPB locals BY -1 TO 1 + DO assign (locals[i], unstack) OD; + FOR i FROM n BY -1 TO 1 + DO assign (params[i], unstack) OD; + REF ITEM result = ref OF name; + assign (name ptr, unstack); + (fn success | result | failed := TRUE ; SKIP) + FI + FI; + + PROC exec prim fn = (REF ITEM name ptr, + REF[]REF ITEM arglist) REF ITEM: + BEGIN + PROC gen1 = (INT routine) REF ITEM: + BEGIN # CREATE PATTERN COMPONENT WITH STRING ARGUMENT # + REF ITEM arg = convert to str (arglist[1]); + IF arg IS NIL + THEN error ("NULL ARG FOR PATTERN-VALUED PRIMITIVE FUNCTION" ) + FI; + make pat comp (routine, arg) + END; + + PROC gen2 = (INT routine) REF ITEM: + BEGIN # CREATE PATTERN COMPONENT WITH INTEGER ARGUMENT # + REF ITEM arg = convert to int (arglist[1]); + IF INTG arg < 0 + THEN error ("NEGATIVE ARG FOR PATTERN-VALUED PRIMITIVE FUNCTION") + FI; + make pat comp (routine, arg) + END; + + STRING fn = val OF (STR name ptr), INT n = UPB arglist; + IF fn = "LE" AND n = 2 + THEN IF INTG convert to int (arglist[1]) + <= INTG convert to int (arglist[2]) + THEN NIL + ELSE failed := TRUE; + SKIP + FI + ELIF fn = "EQ" AND n = 2 + THEN IF INTG convert to int (arglist[1]) + = INTG convert to int (arglist[2]) + THEN NIL + ELSE failed := TRUE; + SKIP + FI + ELIF fn = "NE" AND n = 2 + THEN IF INTG convert to int (arglist[1]) + /= INTG convert to int (arglist[2]) + THEN NIL + ELSE failed := TRUE; + SKIP + FI + ELIF fn = "IDENT" AND n = 2 + THEN IF REF ITEM (arglist[1]) IS arglist[2] + THEN NIL + ELSE failed := TRUE; + SKIP + FI + ELIF fn = "DIFFER" AND n = 2 + THEN IF REF ITEM (arglist[1]) ISNT arglist[2] + THEN NIL + ELSE failed := TRUE; + SKIP + FI + ELIF fn = "ANY" AND n = 1 THEN gen1 (many) + ELIF fn = "LEN" AND n = 1 THEN gen2 (mlen) + ELIF fn = "POS" AND n = 1 THEN gen2 (mpos) + ELIF fn = "TAB" AND n = 1 THEN gen2 (mtab) + ELIF fn = "SPAN" AND n = 1 THEN gen1 (mspn) + ELIF fn = "RPOS" AND n = 1 THEN gen2 (mrpos) + ELIF fn = "RTAB" AND n = 1 THEN gen2 (mrtab) + ELIF fn = "BREAK" AND n = 1 THEN gen1 (mbrk) + ELIF fn = "NOTANY" AND n = 1 THEN gen1 (mnty) + ELIF fn = "SIZE" AND n = 1 + THEN make int (UPB val OF (STR convert to str (arglist[1]))) + ELIF fn = "DEFINE" AND n = 2 + THEN IF REF ITEM (arglist[1]) IS NIL + THEN error ("NULL PROTOTYPE") FI; + STRING prototype = val OF (STR convert to str (arglist[1])); + REF ITEM entry = convert to str (arglist[2]); + IF entry IS NIL THEN error ("NULL ENTRY LABEL") FI; + + PROC check and find = (STRING str) REF ITEM: + BEGIN IF UPB str = 0 THEN error ("ILLEGAL PROTOTYPE") FI; + STRING an = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789."; + IF NOT any (an[:26], str[1]) + THEN error ("ILLEGAL PROTOTYPE") FI; + FOR i FROM 2 TO UPB str + DO IF NOT any (an, str[i]) + THEN error ("ILLEGAL PROTOTYPE") + FI + OD; + make str (str) + END; + + PROC breakup = (STRING str) REF[]REF ITEM: + BEGIN #ANALYZE A LIST OF IDENTIFIERS # + [1:arglim]REF ITEM r, INT p := 0, a := 1, b; + WHILE a <= UPB str + DO b := break scan (str[a:], ","); + IF p >= arglim + THEN error ("TOO MANY PARAMETERS OR LOCALS IN PROTOTYPE") FI; + r[p +:= 1] := check and find (str[a:a+b-1]); + a := a + b + 1 + OD; + HEAP[1:p]REF ITEM := r[:p] + END; + + INT lp = UPB prototype; + INT a = break scan (prototype, "("); + IF a >= lp THEN error ("ILLEGAL PROTOTYPE") FI; + REF ITEM name ptr = check and find (prototype[:a]); + INT b = break scan (prototype[a+2:], ")"); + IF b >= lp - a - 1 THEN error ("ILLEGAL PROTOTYPE") FI; + REF[]REF ITEM params = breakup (prototype[a+2:a+1+b]); + REF[]REF ITEM locals = breakup (prototype[a+b+3:]); + + BOOL not found := TRUE; + FOR i TO ftp WHILE not found + DO IF name ptr IS fnname OF function table[i] + THEN not found := FALSE; + function table[i] := (name ptr, entry, params, locals) + FI + OD; + IF not found + THEN IF ftp = ftlim + THEN error ("FUNCTION TABLE OVERFLOW") FI; + function table [ftp +:= 1] := (name ptr, entry, params, locals) + FI; + NIL # RESULT OF DEFINE(...) # + ELSE error ("ILLEGAL FUNCTION CALL"); + SKIP + FI + END; + + PROC concatenate = (REF ITEM ptr1, ptr2) REF ITEM: + BEGIN + + PROC concat patterns = (PATTERN p1, p2) REF ITEM: + BEGIN INT u1 = UPB p1, u2 = UPB p2; + PATTERN p = HEAP[u1 + u2]COMPONENT; + INT offset = u1 + 1; + FOR i TO u1 + DO p[i] := p1[i]; + IF subsequent OF p[i] = 0 + THEN subsequent OF p[i] := offset FI + OD; + FOR i FROM offset TO u1 + u2 + DO p[i] := p2[i - u1]; + IF subsequent OF p[i] /= 0 + THEN subsequent OF p[i] +:= u1 FI; + IF alternate OF p[i] /= 0 + THEN alternate OF p[i] +:= u1 FI + OD; + IF u2 = 1 AND routine OF p[offset] = miv2 + THEN extra OF p[offset] := u1 FI; + HEAP ITEM := p + END; + + IF failed THEN SKIP + ELSE IF ptr1 IS NIL THEN ptr2 + ELIF ptr2 IS NIL THEN ptr1 + ELSE CASE ptr1 + IN (PATTERN p1): + concat patterns (p1, PAT convert to pat (ptr2)) + OUSE ptr2 + IN (PATTERN p2): + concat patterns (PAT convert to pat (ptr1), p2) + OUT STRING s1 = val OF (STR convert to str (ptr1)); + make str (s1 + val OF (STR convert to str (ptr2))) + ESAC + FI + FI + END; + + PROC convert to int = (REF ITEM ptr) REF ITEM: + IF failed THEN SKIP + ELSE IF ptr IS NIL THEN make int (0) + ELSE CASE ptr + IN (INT): ptr, + (PATTERN): (error ("PATTERN VALUE WHERE INTEGER REQUIRED"); SKIP), + (REF STRINGITEM s): + (INT n := 0, d, z := ABS "0"; + FOR i TO UPB val OF s + DO d := ABS (val OF s)[i] - z; + IF d < 0 OR d > 9 + THEN error ("STRING NOT CONVERTIBLE TO INTEGER") FI; + n := n * 10 + d + OD; + make int (n)) + ESAC + FI + FI; + + PROC convert to pat = (REF ITEM ptr) REF ITEM: + IF failed THEN SKIP + ELSE IF ptr IS NIL + THEN make pat comp (mstr, NIL) + ELSE CASE ptr + IN (PATTERN): ptr + OUT make pat comp (mstr, convert to str (ptr)) + ESAC + FI + FI; + + PROC convert to str = (REF ITEM ptr) REF ITEM: + IF failed THEN SKIP + ELSE IF ptr IS NIL THEN ptr + ELSE CASE ptr + IN (REF STRINGITEM): ptr, + (PATTERN): (error ("PATTERN VALUE WHERE STRING REQUIRED"); SKIP), + (INT i): make str (itoa (i)) + ESAC + FI + FI; + + PROC make int = (INT val) REF ITEM: + IF failed THEN SKIP + ELSE HEAP ITEM := val + FI; + + PROC make pat comp = (INT routine, REF ITEM arg) REF ITEM: + IF failed THEN SKIP + ELSE HEAP ITEM := HEAP[1:1]COMPONENT := COMPONENT (routine, 0, 0, SKIP, arg) + FI; + + PROC make str = (STRING val) REF ITEM: + IF failed THEN SKIP + ELIF UPB val = 0 THEN NIL + ELSE INT i := 0, BOOL nf := TRUE; + WHILE IF (i +:= 1) <= nin + THEN nf := val /= val OF (STR spool [i]) + ELSE FALSE + FI + DO SKIP OD; + IF nf + THEN IF nin = spoolsize THEN error ("TOO MANY STRINGS") FI; + spool[nin +:= 1] := HEAP ITEM := HEAP STRINGITEM := (val, NIL) + FI; + spool[i] + FI; + + PROC break scan = (STRING str, arg) INT: + BEGIN # RESULT = UPB STR IF NO BREAK CHAR, LESS OTHERWISE # + INT j := 0; + FOR i TO UPB str WHILE NOT any (arg, str[i]) + DO j := i OD; + j + END; + + PROC any = (STRING str, CHAR ch) BOOL: + BEGIN BOOL nf; + FOR i TO UPB str WHILE nf := ch /= str[i] DO SKIP OD; + NOT nf + END; + + interpret ((REF ITEM (prog entry) IS NIL | 1 | find label (prog entry))) + END # INTERPRETATION PHASE # +END diff --git a/gcc/testsuite/algol68/compile/supper-1.a68 b/gcc/testsuite/algol68/compile/supper-1.a68 new file mode 100644 index 000000000000..a572f1e929f0 --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-1.a68 @@ -0,0 +1,11 @@ +{ dg-options {-fstropping=supper} } + +begin mode Some_Mode = real; + Some_Mode some_real := random; + + puts ("Hello time for SUPPER!\n"); + if some_real > 0.5 + then puts ("YES\n") + else puts ("NO\n") + fi +end diff --git a/gcc/testsuite/algol68/compile/supper-10.a68 b/gcc/testsuite/algol68/compile/supper-10.a68 new file mode 100644 index 000000000000..5c661a677f4a --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-10.a68 @@ -0,0 +1,6 @@ +{ dg-options {-fstropping=supper} } + +begin mode BEGIN = int; + BEGIN some_int = 10; + skip +end diff --git a/gcc/testsuite/algol68/compile/supper-11.a68 b/gcc/testsuite/algol68/compile/supper-11.a68 new file mode 100644 index 000000000000..5c661a677f4a --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-11.a68 @@ -0,0 +1,6 @@ +{ dg-options {-fstropping=supper} } + +begin mode BEGIN = int; + BEGIN some_int = 10; + skip +end diff --git a/gcc/testsuite/algol68/compile/supper-12.a68 b/gcc/testsuite/algol68/compile/supper-12.a68 new file mode 100644 index 000000000000..497a88a2e66f --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-12.a68 @@ -0,0 +1,6 @@ +{ dg-options {-fstropping=supper} } + +begin for i while i < 10 + do puts ("lala\n") + od +end diff --git a/gcc/testsuite/algol68/compile/supper-13.a68 b/gcc/testsuite/algol68/compile/supper-13.a68 new file mode 100644 index 000000000000..5e17fb4832c5 --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-13.a68 @@ -0,0 +1,7 @@ +{ dg-options "-fstropping=supper" } + +{ mode_ should not be recognized as a symbol. } + +begin int mode_ = 10; + skip +end diff --git a/gcc/testsuite/algol68/compile/supper-2.a68 b/gcc/testsuite/algol68/compile/supper-2.a68 new file mode 100644 index 000000000000..04d5f0f461f3 --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-2.a68 @@ -0,0 +1,5 @@ +{ dg-options {-fstropping=supper} } + +begin int foo_bar = 10; + skip +end diff --git a/gcc/testsuite/algol68/compile/supper-3.a68 b/gcc/testsuite/algol68/compile/supper-3.a68 new file mode 100644 index 000000000000..4cc711b9132a --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-3.a68 @@ -0,0 +1,5 @@ +{ dg-options {-fstropping=supper} } + +begin int foo_bar_ = 10; + skip +end diff --git a/gcc/testsuite/algol68/compile/supper-4.a68 b/gcc/testsuite/algol68/compile/supper-4.a68 new file mode 100644 index 000000000000..283be9a4735c --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-4.a68 @@ -0,0 +1,5 @@ +{ dg-options {-fstropping=supper} } + +begin int foo_ = 10; + skip +end diff --git a/gcc/testsuite/algol68/compile/supper-5.a68 b/gcc/testsuite/algol68/compile/supper-5.a68 new file mode 100644 index 000000000000..b3ffd899e5c0 --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-5.a68 @@ -0,0 +1,6 @@ +{ dg-options {-fstropping=supper} } + +begin mode Foo_bar = int; + Foo_bar some_int = 10; + skip +end diff --git a/gcc/testsuite/algol68/compile/supper-6.a68 b/gcc/testsuite/algol68/compile/supper-6.a68 new file mode 100644 index 000000000000..37fc5e6f3c20 --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-6.a68 @@ -0,0 +1,5 @@ +{ dg-options {-fstropping=supper} } + +begin go to done; +done: skip +end diff --git a/gcc/testsuite/algol68/compile/supper-7.a68 b/gcc/testsuite/algol68/compile/supper-7.a68 new file mode 100644 index 000000000000..a3741748b4cb --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-7.a68 @@ -0,0 +1,5 @@ +{ dg-options {-fstropping=supper} } + +begin goto done; +done: skip +end diff --git a/gcc/testsuite/algol68/compile/supper-8.a68 b/gcc/testsuite/algol68/compile/supper-8.a68 new file mode 100644 index 000000000000..363d9b483ca0 --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-8.a68 @@ -0,0 +1,6 @@ +{ dg-options {-fstropping=supper} } + +begin mode Int = int; + Int some_int = 10; + skip +end diff --git a/gcc/testsuite/algol68/compile/supper-9.a68 b/gcc/testsuite/algol68/compile/supper-9.a68 new file mode 100644 index 000000000000..5c661a677f4a --- /dev/null +++ b/gcc/testsuite/algol68/compile/supper-9.a68 @@ -0,0 +1,6 @@ +{ dg-options {-fstropping=supper} } + +begin mode BEGIN = int; + BEGIN some_int = 10; + skip +end diff --git a/gcc/testsuite/algol68/compile/uniting-1.a68 b/gcc/testsuite/algol68/compile/uniting-1.a68 new file mode 100644 index 000000000000..057c4f85838d --- /dev/null +++ b/gcc/testsuite/algol68/compile/uniting-1.a68 @@ -0,0 +1,8 @@ +{ dg-options {-fstropping=supper} } +begin mode JSON_Val = union (int,ref JSON_Obj), + JSON_Obj = struct (int je), + + proc json_new_obj = JSON_Val: + (JSON_Obj o; o); + skip +end diff --git a/gcc/testsuite/algol68/compile/upper-1.a68 b/gcc/testsuite/algol68/compile/upper-1.a68 new file mode 100644 index 000000000000..6fb7871301f2 --- /dev/null +++ b/gcc/testsuite/algol68/compile/upper-1.a68 @@ -0,0 +1,11 @@ +# { dg-options {-fstropping=upper} } # + +BEGIN MODE SOME_MODE = REAL; + SOME_MODE some_real := random; + + puts ("Hello time for SUPPER!\n"); + IF some_real > 0.5 + THEN puts ("YES\n") + ELSE puts ("NO\n") + FI +END diff --git a/gcc/testsuite/algol68/compile/warning-hidding-1.a68 b/gcc/testsuite/algol68/compile/warning-hidding-1.a68 new file mode 100644 index 000000000000..b3d568bf9a2e --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-hidding-1.a68 @@ -0,0 +1,6 @@ +{ dg-options "-Whidden-declarations" } +begin + op UPB = (union (int,string) v) int: { dg-warning "hides" } + (v | (string s): UPB s | 0); + UPB "lala" +end diff --git a/gcc/testsuite/algol68/compile/warning-hidding-2.a68 b/gcc/testsuite/algol68/compile/warning-hidding-2.a68 new file mode 100644 index 000000000000..12bfcbbc63f5 --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-hidding-2.a68 @@ -0,0 +1,6 @@ +{ dg-options "-Whidden-declarations" } +begin + op UPB = (union ([]int,string) v) int: { dg-warning "hides" } + (v | (string s): UPB s | 0); + UPB "lala" +end diff --git a/gcc/testsuite/algol68/compile/warning-hidding-3.a68 b/gcc/testsuite/algol68/compile/warning-hidding-3.a68 new file mode 100644 index 000000000000..25f4809ebcf0 --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-hidding-3.a68 @@ -0,0 +1,5 @@ +{ dg-options "-Whidden-declarations" } +begin op UPB = (union (int,union(string,real)) v) int: { dg-warning "hides" } + (v | (string s): UPB s | 0); + UPB "lala" +end diff --git a/gcc/testsuite/algol68/compile/warning-hidding-4.a68 b/gcc/testsuite/algol68/compile/warning-hidding-4.a68 new file mode 100644 index 000000000000..0078e6a593f9 --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-hidding-4.a68 @@ -0,0 +1,6 @@ +{ dg-options "-Whidden-declarations" } +begin + op UPB = (int i, union (int,string) v) int: { dg-warning "hides" } + (v | (string s): UPB s | 0); + UPB "lala" +end diff --git a/gcc/testsuite/algol68/compile/warning-hidding-5.a68 b/gcc/testsuite/algol68/compile/warning-hidding-5.a68 new file mode 100644 index 000000000000..f9bc4a41ea4d --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-hidding-5.a68 @@ -0,0 +1,9 @@ +{ dg-options "-Whidden-declarations=none" } +begin real b; + begin int getchar = 10; + int b; + op UPB = (int i, union (int,string) v) int: + (v | (string s): UPB s | 0); + UPB "lala" + end +end diff --git a/gcc/testsuite/algol68/compile/warning-hidding-6.a68 b/gcc/testsuite/algol68/compile/warning-hidding-6.a68 new file mode 100644 index 000000000000..a865103bcdfb --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-hidding-6.a68 @@ -0,0 +1,9 @@ +{ dg-options "-Whidden-declarations=prelude" } +begin real b; + begin int getchar = 10; { dg-warning "hides" } + int b; + op UPB = (int i, union (int,string) v) int: { dg-warning "hides" } + (v | (string s): UPB s | 0); + UPB "lala" + end +end diff --git a/gcc/testsuite/algol68/compile/warning-hidding-7.a68 b/gcc/testsuite/algol68/compile/warning-hidding-7.a68 new file mode 100644 index 000000000000..e641a93934e4 --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-hidding-7.a68 @@ -0,0 +1,9 @@ +{ dg-options "-Whidden-declarations=all" } +begin real b; + begin int getchar = 10; { dg-warning "hides" } + int b; { dg-warning "hides" } + op UPB = (int i, union (int,string) v) int: { dg-warning "hides" } + (v | (string s): UPB s | 0); + UPB "lala" + end +end diff --git a/gcc/testsuite/algol68/compile/warning-module-hidding-1.a68 b/gcc/testsuite/algol68/compile/warning-module-hidding-1.a68 new file mode 100644 index 000000000000..84b4b0e25b28 --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-module-hidding-1.a68 @@ -0,0 +1,6 @@ +{ dg-options "-Whidden-declarations=all" } + +module Foo = def int i; i := 10 postlude puts ("bye foo'n") fed, + Bar = def int j; j := 20 + postlude int j; puts ("bye bar'n") fed, { dg-warning "hidden" } + Baz = def skip fed diff --git a/gcc/testsuite/algol68/compile/warning-pub-loc-1.a68 b/gcc/testsuite/algol68/compile/warning-pub-loc-1.a68 new file mode 100644 index 000000000000..57baef93ecaf --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-pub-loc-1.a68 @@ -0,0 +1,7 @@ +module Foo = +def pub ref int xx = loc int := 777; { dg-warning "" } + pub ref int yy; + pub ref int zz = heap int := 888; + ref int vv = loc int := 999; + skip +fed diff --git a/gcc/testsuite/algol68/compile/warning-scope-1.a68 b/gcc/testsuite/algol68/compile/warning-scope-1.a68 new file mode 100644 index 000000000000..99ae973fe90a --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-scope-1.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # + +# Potential scope violation warnings are disabled by default. # +BEGIN PROC increase = (REF INT i) REF INT: + BEGIN INT j := i; + j # Inhibited warning. # + END; + increase (LOC INT) +END diff --git a/gcc/testsuite/algol68/compile/warning-scope-2.a68 b/gcc/testsuite/algol68/compile/warning-scope-2.a68 new file mode 100644 index 000000000000..5bbc0b371263 --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-scope-2.a68 @@ -0,0 +1,8 @@ +# { dg-options {-Wscope -fstropping=upper} } # +BEGIN PROC increase = (REF INT i) REF INT: + BEGIN + INT j := i; + j # { dg-warning "scope violation" } # + END; + increase (LOC INT) +END diff --git a/gcc/testsuite/algol68/compile/warning-scope-3.a68 b/gcc/testsuite/algol68/compile/warning-scope-3.a68 new file mode 100644 index 000000000000..c5dd29562c00 --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-scope-3.a68 @@ -0,0 +1,3 @@ +# { dg-options {-Wscope -fstropping=upper} } # +(REF INT xx; + xx := (INT x; x := 3)) # { dg-warning "scope violation" } # diff --git a/gcc/testsuite/algol68/compile/warning-scope-4.a68 b/gcc/testsuite/algol68/compile/warning-scope-4.a68 new file mode 100644 index 000000000000..ae0592ed743f --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-scope-4.a68 @@ -0,0 +1,3 @@ +# { dg-options {-Wscope -fstropping=upper} } # +(REF INT xx; + (INT x; xx:= x; x := 3)) # { dg-warning "scope violation" } # diff --git a/gcc/testsuite/algol68/compile/warning-scope-5.a68 b/gcc/testsuite/algol68/compile/warning-scope-5.a68 new file mode 100644 index 000000000000..2bb5b4afe884 --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-scope-5.a68 @@ -0,0 +1,8 @@ +# { dg-options {-Wscope -fstropping=upper} } # +# The scope violation here is due to the routine text, which is copied + to P, referring to a value whose range doesn't exist anymore: X # +BEGIN (PROC REAL p; + (REAL x; + p := REAL: x * 2); # { dg-warning "scope violation" } # + p) +END diff --git a/gcc/testsuite/algol68/compile/warning-scope-6.a68 b/gcc/testsuite/algol68/compile/warning-scope-6.a68 new file mode 100644 index 000000000000..fa3888d65289 --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-scope-6.a68 @@ -0,0 +1,6 @@ +# { dg-options {-Wscope -fstropping=upper} } # +BEGIN (PROC REAL p; REAL mypi := 3.14; + (REAL x; + p := REAL: mypi * 2); # No scope violation here. # + p) +END diff --git a/gcc/testsuite/algol68/compile/warning-scope-7.a68 b/gcc/testsuite/algol68/compile/warning-scope-7.a68 new file mode 100644 index 000000000000..b99fa85ddffa --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-scope-7.a68 @@ -0,0 +1,12 @@ +# { dg-options {-Wscope -fstropping=upper} } # +# N,M below represent pairs of insc, outsc # +BEGIN (INT x; + REF INT xx; + (REF INT yy; + INT y; + xx := yy; # 0,0 := 1,0. Dynamic check. # + yy := y; # 1,1 := 1,1. OK # + xx := y # 0,0 := 1,1. { dg-warning "scope violation" } # + ) + ) +END diff --git a/gcc/testsuite/algol68/compile/warning-voiding-1.a68 b/gcc/testsuite/algol68/compile/warning-voiding-1.a68 new file mode 100644 index 000000000000..f34787c2979f --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-voiding-1.a68 @@ -0,0 +1,5 @@ +# { dg-options {-Wvoiding -fstropping=upper} } # +BEGIN PROC sum = (INT a, INT b) INT: + ( a + b ); + sum (10, 20) # { dg-warning "will be voided" } # +END diff --git a/gcc/testsuite/algol68/compile/warning-voiding-2.a68 b/gcc/testsuite/algol68/compile/warning-voiding-2.a68 new file mode 100644 index 000000000000..e3c98792c91f --- /dev/null +++ b/gcc/testsuite/algol68/compile/warning-voiding-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # + +BEGIN PROC sum = (INT a, INT b) INT: + ( a + b ); + sum (10, 20) # Voiding warning won't be emitted by default. # +END diff --git a/gcc/testsuite/algol68/execute/abs-bits-1.a68 b/gcc/testsuite/algol68/execute/abs-bits-1.a68 new file mode 100644 index 000000000000..bdb3a1bef52e --- /dev/null +++ b/gcc/testsuite/algol68/execute/abs-bits-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# ABS for SIZETY BITS # +BEGIN ASSERT (255 = ABS 16rff); + ASSERT (LONG 255 = ABS LONG 16rff); + ASSERT (LONG LONG 255 = ABS LONG LONG 16rff) + # XXX test ABS of negative numbers (extension). # +END diff --git a/gcc/testsuite/algol68/execute/abs-bool-1.a68 b/gcc/testsuite/algol68/execute/abs-bool-1.a68 new file mode 100644 index 000000000000..90ea0d685a34 --- /dev/null +++ b/gcc/testsuite/algol68/execute/abs-bool-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (ABS TRUE /= 0); + ASSERT (ABS FALSE = 0) +END diff --git a/gcc/testsuite/algol68/execute/abs-char-1.a68 b/gcc/testsuite/algol68/execute/abs-char-1.a68 new file mode 100644 index 000000000000..124fb3d473ff --- /dev/null +++ b/gcc/testsuite/algol68/execute/abs-char-1.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (ABS "a" = 97) +END diff --git a/gcc/testsuite/algol68/execute/abs-int-1.a68 b/gcc/testsuite/algol68/execute/abs-int-1.a68 new file mode 100644 index 000000000000..fa8125a1587b --- /dev/null +++ b/gcc/testsuite/algol68/execute/abs-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (ABS 10 = 10); + ASSERT (ABS -10 = 10); + ASSERT (ABS SHORT 10 = SHORT 10); + ASSERT (ABS - SHORT 10 = SHORT 10); + ASSERT (ABS - SHORT SHORT 10 = SHORT SHORT 10); + ASSERT (ABS LONG 10 = LONG 10); + ASSERT (ABS - LONG 10 = LONG 10); + ASSERT (ABS - LONG LONG 10 = LONG LONG 10) +END diff --git a/gcc/testsuite/algol68/execute/abs-int-negative-1.a68 b/gcc/testsuite/algol68/execute/abs-int-negative-1.a68 new file mode 100644 index 000000000000..77973ad220f2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/abs-int-negative-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper -std=algol68" } # +BEGIN SHORT SHORT BITS b = BIN - SHORT SHORT 2; + ASSERT (ABS b = SHORT SHORT INT (SKIP)) +END diff --git a/gcc/testsuite/algol68/execute/abs-int-negative-gnu-1.a68 b/gcc/testsuite/algol68/execute/abs-int-negative-gnu-1.a68 new file mode 100644 index 000000000000..4afe25679e01 --- /dev/null +++ b/gcc/testsuite/algol68/execute/abs-int-negative-gnu-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper -std=gnu68" } # +BEGIN SHORT SHORT BITS b = BIN - SHORT SHORT 2; + ASSERT (ABS b = - SHORT SHORT 2) +END diff --git a/gcc/testsuite/algol68/execute/acos-1.a68 b/gcc/testsuite/algol68/execute/acos-1.a68 new file mode 100644 index 000000000000..6a985cc8a235 --- /dev/null +++ b/gcc/testsuite/algol68/execute/acos-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r = 1.0; + LONG REAL rr = LONG 45.0; + LONG LONG REAL rrr = LONG LONG 60.0; + ASSERT (arccos (r) = 0.0); + long arccos (rr); + long long arccos (rrr) +END diff --git a/gcc/testsuite/algol68/execute/affirm-int-1.a68 b/gcc/testsuite/algol68/execute/affirm-int-1.a68 new file mode 100644 index 000000000000..4cd065fa2358 --- /dev/null +++ b/gcc/testsuite/algol68/execute/affirm-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 10; + LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10; + SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10; + ASSERT (+i = 10); + ASSERT (+ii = LONG 10); + ASSERT (+iii = LONG LONG 10); + ASSERT (+ss = SHORT 10); + ASSERT (+sss = SHORT SHORT 10) +END diff --git a/gcc/testsuite/algol68/execute/and-bits-1.a68 b/gcc/testsuite/algol68/execute/and-bits-1.a68 new file mode 100644 index 000000000000..e6530bcdfb01 --- /dev/null +++ b/gcc/testsuite/algol68/execute/and-bits-1.a68 @@ -0,0 +1,18 @@ +# { dg-options "-fstropping=upper" } # +# AND for SIZETY BITS. # +BEGIN BITS b = 16r0f0f0; + ASSERT ((b AND 16r0f0f) = 16r0); + ASSERT ((b AND 16r00ff) = 16rf0); + LONG BITS bb = LONG 16r0f0f0; + ASSERT ((bb AND LONG 16r0f0f) = LONG 16r0); + ASSERT ((bb AND LONG 16r00ff) = LONG 16rf0); + LONG LONG BITS bbb = LONG LONG 16r0f0f0; + ASSERT ((bbb AND LONG LONG 16r0f0f) = LONG LONG 16r0); + ASSERT ((bbb AND LONG LONG 16r00ff) = LONG LONG 16rf0); + SHORT BITS ss = SHORT 16r0f0f0; + ASSERT ((ss AND SHORT 16r0f0f) = SHORT 16r0); + ASSERT ((ss AND SHORT 16r00ff) = SHORT 16rf0); + SHORT SHORT BITS sss = SHORT SHORT 16r0f0f0; + ASSERT ((sss AND SHORT SHORT 16r0f0f) = SHORT SHORT 16r0); + ASSERT ((sss AND SHORT SHORT 16r00ff) = SHORT SHORT 16rf0) +END diff --git a/gcc/testsuite/algol68/execute/andf-1.a68 b/gcc/testsuite/algol68/execute/andf-1.a68 new file mode 100644 index 000000000000..72667a653bd5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/andf-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 10; + ASSERT (i /= 0 ANDTH i = 10) +END diff --git a/gcc/testsuite/algol68/execute/ascription-1.a68 b/gcc/testsuite/algol68/execute/ascription-1.a68 new file mode 100644 index 000000000000..f6744e322f92 --- /dev/null +++ b/gcc/testsuite/algol68/execute/ascription-1.a68 @@ -0,0 +1,12 @@ +# { dg-options "-fstropping=upper" } # +# Make sure structs are copied when ascribed. # +BEGIN MODE BAR = STRUCT (INT j, REAL r); + MODE FOO = STRUCT (INT i, BAR bar); + + FOO f1 := (10, (20, 3.14)); + FOO f2 = f1; + + j OF bar OF f1 := 200; + ASSERT (j OF bar OF f1 = 200); + ASSERT (j OF bar OF f2 = 20) +END diff --git a/gcc/testsuite/algol68/execute/asin-1.a68 b/gcc/testsuite/algol68/execute/asin-1.a68 new file mode 100644 index 000000000000..114518edfa2c --- /dev/null +++ b/gcc/testsuite/algol68/execute/asin-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r = 0.0; + LONG REAL rr = LONG 45.0; + LONG LONG REAL rrr = LONG LONG 60.0; + ASSERT (arcsin (r) = 0.0); + long arcsin (rr); + long long arcsin (rrr) +END diff --git a/gcc/testsuite/algol68/execute/assert-1.a68 b/gcc/testsuite/algol68/execute/assert-1.a68 new file mode 100644 index 000000000000..2ed6ea40e7e6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/assert-1.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (TRUE) +END diff --git a/gcc/testsuite/algol68/execute/assignation-char-1.a68 b/gcc/testsuite/algol68/execute/assignation-char-1.a68 new file mode 100644 index 000000000000..5558ccc140d9 --- /dev/null +++ b/gcc/testsuite/algol68/execute/assignation-char-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN CHAR c; + c := "x"; + ASSERT (c = "x") +END diff --git a/gcc/testsuite/algol68/execute/assignation-int-1.a68 b/gcc/testsuite/algol68/execute/assignation-int-1.a68 new file mode 100644 index 000000000000..139d7436ebd6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/assignation-int-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i; + i := 20; + ASSERT (i = 20) +END diff --git a/gcc/testsuite/algol68/execute/assignation-int-2.a68 b/gcc/testsuite/algol68/execute/assignation-int-2.a68 new file mode 100644 index 000000000000..cfd384076316 --- /dev/null +++ b/gcc/testsuite/algol68/execute/assignation-int-2.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN x := 100; + INT x; + ASSERT (x = 100) +END diff --git a/gcc/testsuite/algol68/execute/assignation-int-3.a68 b/gcc/testsuite/algol68/execute/assignation-int-3.a68 new file mode 100644 index 000000000000..9b60f7e0a36a --- /dev/null +++ b/gcc/testsuite/algol68/execute/assignation-int-3.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REF INT j = LOC INT; + INT i; + i := j := 20; + ASSERT (i + j = 40) +END diff --git a/gcc/testsuite/algol68/execute/assignation-int-4.a68 b/gcc/testsuite/algol68/execute/assignation-int-4.a68 new file mode 100644 index 000000000000..2aeb35b11477 --- /dev/null +++ b/gcc/testsuite/algol68/execute/assignation-int-4.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REF INT xx; + INT x := 10; + ASSERT ((xx := (x)) = 10) +END diff --git a/gcc/testsuite/algol68/execute/assignation-int-5.a68 b/gcc/testsuite/algol68/execute/assignation-int-5.a68 new file mode 100644 index 000000000000..2b67b21fae2b --- /dev/null +++ b/gcc/testsuite/algol68/execute/assignation-int-5.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx := x; + x := 20; + ASSERT ((xx := (INT j; x)) = 20) +END diff --git a/gcc/testsuite/algol68/execute/assignation-multiple-1.a68 b/gcc/testsuite/algol68/execute/assignation-multiple-1.a68 new file mode 100644 index 000000000000..cf8d78020ef5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/assignation-multiple-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRUCT ([2:3]INT m, [1:5]REAL g) s; + g OF s:= (1.0, 2.0, 3.0, 4.0, 5.0) +END diff --git a/gcc/testsuite/algol68/execute/assignation-multiple-2.a68 b/gcc/testsuite/algol68/execute/assignation-multiple-2.a68 new file mode 100644 index 000000000000..22ff7e119427 --- /dev/null +++ b/gcc/testsuite/algol68/execute/assignation-multiple-2.a68 @@ -0,0 +1,15 @@ +begin [5]struct(char i, real r) foo; + + { The stride in the single dimension of the multiple resulting + from the selection is not the size of a 'char'. } + i of foo := ("a","b","c","d","e"); + puts ((i of foo) + "'n"); + { Via indexing then selection. } + assert (i of foo[1] = "a"); + assert (i of foo[2] = "b"); + assert (i of foo[3] = "c"); + assert (i of foo[4] = "d"); + assert (i of foo[5] = "e"); + { Via selection of multiple. } + assert (i of foo = "abcde"); +end diff --git a/gcc/testsuite/algol68/execute/assignation-struct-1.a68 b/gcc/testsuite/algol68/execute/assignation-struct-1.a68 new file mode 100644 index 000000000000..a2d661b18378 --- /dev/null +++ b/gcc/testsuite/algol68/execute/assignation-struct-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE NODE = STRUCT (INT one, two, three); + NODE top; + top := (10,20,30); + ASSERT (two OF top = 20) +END diff --git a/gcc/testsuite/algol68/execute/assignation-struct-2.a68 b/gcc/testsuite/algol68/execute/assignation-struct-2.a68 new file mode 100644 index 000000000000..61734cc0db65 --- /dev/null +++ b/gcc/testsuite/algol68/execute/assignation-struct-2.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# Struct containing a multiple, which must be copied when + the struct value is assigned. # +BEGIN MODE FOO = STRUCT (STRING s, INT i); + FOO f1; + f1 := ("foo", 10); + ASSERT (i OF f1 = 10) +END diff --git a/gcc/testsuite/algol68/execute/atan-1.a68 b/gcc/testsuite/algol68/execute/atan-1.a68 new file mode 100644 index 000000000000..bc710c5cdfd8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/atan-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r = 0.0; + LONG REAL rr = LONG 45.0; + LONG LONG REAL rrr = LONG LONG 60.0; + ASSERT (arctan (r) = 0.0); + long arctan (rr); + long long arctan (rrr) +END diff --git a/gcc/testsuite/algol68/execute/balancing-1.a68 b/gcc/testsuite/algol68/execute/balancing-1.a68 new file mode 100644 index 000000000000..418b0e4efb9e --- /dev/null +++ b/gcc/testsuite/algol68/execute/balancing-1.a68 @@ -0,0 +1,12 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL x, y; + REF REAL xx, yy; + xx := yy := x; + + ASSERT (xx :=: x); + ASSERT (x :=: xx); + ASSERT (xx :/=: yy); + ASSERT (REF REAL (xx) :=: yy); + ASSERT (xx :=: REF REAL (yy)); + ASSERT (REF REAL (xx) :=: REF REAL (yy)) +END diff --git a/gcc/testsuite/algol68/execute/balancing-rows-1.a68 b/gcc/testsuite/algol68/execute/balancing-rows-1.a68 new file mode 100644 index 000000000000..1f69d47259a9 --- /dev/null +++ b/gcc/testsuite/algol68/execute/balancing-rows-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (UPB IF FALSE THEN []INT (1) ELSE [,]REAL (1) FI = 1); + ASSERT (2 UPB CASE 2 IN []INT (1), [,]REAL (1) ESAC = 1) +END diff --git a/gcc/testsuite/algol68/execute/bin-1.a68 b/gcc/testsuite/algol68/execute/bin-1.a68 new file mode 100644 index 000000000000..4fb095fb5dd8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/bin-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# BIN for SIZETY INTs # +BEGIN ASSERT (BIN 255 = 16rff); + ASSERT (BIN LONG 255 = LONG 16rff); + ASSERT (BIN LONG LONG 255 = LONG LONG 16rff) +END diff --git a/gcc/testsuite/algol68/execute/bin-negative-1.a68 b/gcc/testsuite/algol68/execute/bin-negative-1.a68 new file mode 100644 index 000000000000..97c2cf000c3b --- /dev/null +++ b/gcc/testsuite/algol68/execute/bin-negative-1.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper -std=algol68" } # +BEGIN ASSERT (BIN - SHORT SHORT 2 = SHORT SHORT 2r0) +END diff --git a/gcc/testsuite/algol68/execute/bin-negative-gnu-1.a68 b/gcc/testsuite/algol68/execute/bin-negative-gnu-1.a68 new file mode 100644 index 000000000000..41d95533f3c5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/bin-negative-gnu-1.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper -std=gnu68" } # +BEGIN ASSERT (BIN - SHORT SHORT 2 = SHORT SHORT 2r11111110) +END diff --git a/gcc/testsuite/algol68/execute/boolops-1.a68 b/gcc/testsuite/algol68/execute/boolops-1.a68 new file mode 100644 index 000000000000..82600fc2f9a6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/boolops-1.a68 @@ -0,0 +1,18 @@ +# { dg-options "-fstropping=upper" } # +BEGIN BOOL t := TRUE; + BOOL f := FALSE; + ASSERT (NOT t = FALSE); + ASSERT (~t = FALSE); + ASSERT ((t AND t) = TRUE); + ASSERT ((t AND f) = FALSE); + ASSERT ((f AND f) = FALSE); + ASSERT ((f AND t) = FALSE); + ASSERT ((t OR t) = TRUE); + ASSERT ((t OR f) = TRUE); + ASSERT ((f OR f) = FALSE); + ASSERT ((f OR t) = TRUE); + ASSERT ((t XOR t) = FALSE); + ASSERT ((t XOR f) = TRUE); + ASSERT ((f XOR f) = FALSE); + ASSERT ((f XOR t) = TRUE) +END diff --git a/gcc/testsuite/algol68/execute/call-1.a68 b/gcc/testsuite/algol68/execute/call-1.a68 new file mode 100644 index 000000000000..f77113dcc464 --- /dev/null +++ b/gcc/testsuite/algol68/execute/call-1.a68 @@ -0,0 +1,19 @@ +# { dg-options "-fstropping=upper" } # +# Calling a procedure that gets a row of united values. # +BEGIN INT num ints := 0, num reals := 0, num strings := 0; + PROC foo = ([]UNION(INT,REAL,STRING) d) VOID: + BEGIN FOR i TO UPB d + DO CASE d[i] + IN (STRING): num strings +:= 1, + (INT): num ints +:= 1, + (REAL): num reals +:= 1 + ESAC + OD + END; + foo (()); + foo (10); + ASSERT (num ints = 1 AND num reals = 0 AND num strings = 0); + num ints := 0; + foo (("baz", 1, 3.14, 2, 0.0, "foo")); + ASSERT (num ints = 2 AND num reals = 2 AND num strings = 2) +END diff --git a/gcc/testsuite/algol68/execute/call-2.a68 b/gcc/testsuite/algol68/execute/call-2.a68 new file mode 100644 index 000000000000..21a6b252028a --- /dev/null +++ b/gcc/testsuite/algol68/execute/call-2.a68 @@ -0,0 +1,21 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT control := 0; + PROC set control = (PROC(INT)VOID p) VOID: p (100); + PROC setter = (INT i) VOID: control := i; + PROC(INT)VOID setter 2 = (INT i) VOID: control := i + 1; + PROC(INT)VOID setter 3 := setter 2; + PROC(INT)VOID setter 4 := (INT i) VOID: control := i + 2; + REF PROC(INT)VOID setter 5 := setter 4; + set control (setter); + ASSERT (control = 100); + set control (setter 2); + ASSERT (control = 101); + control := 0; + set control (setter 3); + ASSERT (control = 101); + set control (setter 4); + ASSERT (control = 102); + control := 0; + set control (setter 5); + ASSERT (control = 102) +END diff --git a/gcc/testsuite/algol68/execute/case-clause-1.a68 b/gcc/testsuite/algol68/execute/case-clause-1.a68 new file mode 100644 index 000000000000..71566edf9154 --- /dev/null +++ b/gcc/testsuite/algol68/execute/case-clause-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT j := 1; + ASSERT ((j|10,20,30|40) = 10); + j := 2; + ASSERT ((j|10,20,30|40) = 20); + j := 3; + ASSERT ((j|10,20,30|40) = 30); + j := 100; + ASSERT ((j|10,20,30|40) = 40) +END diff --git a/gcc/testsuite/algol68/execute/case-clause-2.a68 b/gcc/testsuite/algol68/execute/case-clause-2.a68 new file mode 100644 index 000000000000..971bdb56207a --- /dev/null +++ b/gcc/testsuite/algol68/execute/case-clause-2.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 2; + ASSERT (CASE INT x = 10; i + IN x + 1, + x + 2, + x + 3 + ESAC = 12) +END diff --git a/gcc/testsuite/algol68/execute/case-clause-3.a68 b/gcc/testsuite/algol68/execute/case-clause-3.a68 new file mode 100644 index 000000000000..3355cefc080f --- /dev/null +++ b/gcc/testsuite/algol68/execute/case-clause-3.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT days, INT month = 2, year = 2024; + days := CASE month + IN 31, (year MOD 4 = 0 AND year MOD 100 /= 0 OR year MOD 400 = 0 | 29 | 28), + 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ESAC; + ASSERT (days = 29) +END diff --git a/gcc/testsuite/algol68/execute/case-clause-4.a68 b/gcc/testsuite/algol68/execute/case-clause-4.a68 new file mode 100644 index 000000000000..cd69069fa84f --- /dev/null +++ b/gcc/testsuite/algol68/execute/case-clause-4.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT day = 3; + STRING day name = (day | "MONDAY", "TUESDAY", "WEDNESDAY", "THURSDAY", "FRIDAY", "SATURDAY", "SUNDAY"); + ASSERT (day name[1] = "W") +END diff --git a/gcc/testsuite/algol68/execute/closed-clause-1.a68 b/gcc/testsuite/algol68/execute/closed-clause-1.a68 new file mode 100644 index 000000000000..d7602e1ae86b --- /dev/null +++ b/gcc/testsuite/algol68/execute/closed-clause-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL pie, my small real := 0.001; + PROC my sqrt = (REAL r) REAL: r; + BEGIN REAL w := 0, INT i := 1, REAL z = my sqrt (my small real / 2); + loop: w := w + 2 / (i * (i + 2)); + i := i + 4; + IF 1/i > z THEN GO TO loop FI; + pie := 4 * w + END +END diff --git a/gcc/testsuite/algol68/execute/closed-clause-2.a68 b/gcc/testsuite/algol68/execute/closed-clause-2.a68 new file mode 100644 index 000000000000..c6acec88ebdd --- /dev/null +++ b/gcc/testsuite/algol68/execute/closed-clause-2.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL my small real := 0.001; + PROC my sqrt = (REAL r) REAL: r; + REAL res = 4 * (REAL w := 0, INT i := 1; REAL z = my sqrt (my small real / 2); + loop: w := w + 2/(i * (i + 2)); i := i + 4; + IF 1/i > z THEN loop FI; + w); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/collateral-clause-1.a68 b/gcc/testsuite/algol68/execute/collateral-clause-1.a68 new file mode 100644 index 000000000000..d467a424aa2a --- /dev/null +++ b/gcc/testsuite/algol68/execute/collateral-clause-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 10; + (i, i + 1, i + 2) +END diff --git a/gcc/testsuite/algol68/execute/collateral-clause-2.a68 b/gcc/testsuite/algol68/execute/collateral-clause-2.a68 new file mode 100644 index 000000000000..8d9aa6eeb74c --- /dev/null +++ b/gcc/testsuite/algol68/execute/collateral-clause-2.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 10; + ( + BEGIN + (i + 1, i +:= 1, i + 2) + END + ); + ASSERT (i = 11) +END diff --git a/gcc/testsuite/algol68/execute/collateral-clause-3.a68 b/gcc/testsuite/algol68/execute/collateral-clause-3.a68 new file mode 100644 index 000000000000..9af00e7c2db4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/collateral-clause-3.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 10; + ( + i +:= 1; + BEGIN + (i + 1, (i +:= 1, i + 10, i + 11, SKIP), i + 2) + END; + i +:= i + ); + ASSERT (i = 24) +END diff --git a/gcc/testsuite/algol68/execute/collateral-clause-4.a68 b/gcc/testsuite/algol68/execute/collateral-clause-4.a68 new file mode 100644 index 000000000000..2e64fb1787e3 --- /dev/null +++ b/gcc/testsuite/algol68/execute/collateral-clause-4.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper" } # +BEGIN (SKIP,SKIP) +END diff --git a/gcc/testsuite/algol68/execute/collateral-clause-5.a68 b/gcc/testsuite/algol68/execute/collateral-clause-5.a68 new file mode 100644 index 000000000000..c1375a96677a --- /dev/null +++ b/gcc/testsuite/algol68/execute/collateral-clause-5.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x, y, z; + (x := 1, y := 2, z := 3); + ASSERT (x = 1 AND y = 2 AND z = 3) +END diff --git a/gcc/testsuite/algol68/execute/collateral-clause-6.a68 b/gcc/testsuite/algol68/execute/collateral-clause-6.a68 new file mode 100644 index 000000000000..57599afb20e5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/collateral-clause-6.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i; + PROC side = INT: (i := 1; i := 2; i); + PROC add = (INT ii, INT jj) INT: ii + jj; + INT res = add (side, side); + # can be 3 or 4 due to collateral evaluation of arguments. # + ASSERT (res = 3 OR res = 4) +END diff --git a/gcc/testsuite/algol68/execute/completer-1.a68 b/gcc/testsuite/algol68/execute/completer-1.a68 new file mode 100644 index 000000000000..e3b488a7dd0b --- /dev/null +++ b/gcc/testsuite/algol68/execute/completer-1.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i; + BEGIN (i := 20 EXIT +cont: i := 30 + ); + i +:= 1 + END; + ASSERT (i = 21) +END diff --git a/gcc/testsuite/algol68/execute/completer-10.a68 b/gcc/testsuite/algol68/execute/completer-10.a68 new file mode 100644 index 000000000000..18d4f937cf3a --- /dev/null +++ b/gcc/testsuite/algol68/execute/completer-10.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 20; + REF INT xx := x; + REF REF INT xxx; + REF INT i := (x := 10; xxx := xx EXIT foo: xxx EXIT bar: xxx := xx); + ASSERT (i = 10) +END diff --git a/gcc/testsuite/algol68/execute/completer-2.a68 b/gcc/testsuite/algol68/execute/completer-2.a68 new file mode 100644 index 000000000000..fac329ab4bfd --- /dev/null +++ b/gcc/testsuite/algol68/execute/completer-2.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = (foo; + 10 EXIT +foo: 20 EXIT +bar: 30); + ASSERT (i = 20) +END diff --git a/gcc/testsuite/algol68/execute/completer-3.a68 b/gcc/testsuite/algol68/execute/completer-3.a68 new file mode 100644 index 000000000000..6514f2ddc60d --- /dev/null +++ b/gcc/testsuite/algol68/execute/completer-3.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = ((((foo; 10 EXIT foo: 20 EXIT bar: 30)))); + ASSERT (i = 20) +END diff --git a/gcc/testsuite/algol68/execute/completer-4.a68 b/gcc/testsuite/algol68/execute/completer-4.a68 new file mode 100644 index 000000000000..1291e733d730 --- /dev/null +++ b/gcc/testsuite/algol68/execute/completer-4.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := (foo; 10 EXIT foo: 20 EXIT bar: 30); + ASSERT (i = 20) +END diff --git a/gcc/testsuite/algol68/execute/completer-5.a68 b/gcc/testsuite/algol68/execute/completer-5.a68 new file mode 100644 index 000000000000..f6bc6f42719b --- /dev/null +++ b/gcc/testsuite/algol68/execute/completer-5.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x; + REF INT i := (foo; x := 10 EXIT foo: x := 20 EXIT bar: x := 30); + ASSERT (i = 20) +END diff --git a/gcc/testsuite/algol68/execute/completer-6.a68 b/gcc/testsuite/algol68/execute/completer-6.a68 new file mode 100644 index 000000000000..aaf512f4babd --- /dev/null +++ b/gcc/testsuite/algol68/execute/completer-6.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 20; + REF INT i := (foo; x := 10 EXIT foo: x EXIT bar: x := 30); + ASSERT (i = 20) +END diff --git a/gcc/testsuite/algol68/execute/completer-7.a68 b/gcc/testsuite/algol68/execute/completer-7.a68 new file mode 100644 index 000000000000..9ef0e27f6744 --- /dev/null +++ b/gcc/testsuite/algol68/execute/completer-7.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 20; + REF INT i := (x := 10 EXIT foo: x EXIT bar: x := 30); + ASSERT (i = 10) +END diff --git a/gcc/testsuite/algol68/execute/completer-8.a68 b/gcc/testsuite/algol68/execute/completer-8.a68 new file mode 100644 index 000000000000..b73fd13f4c32 --- /dev/null +++ b/gcc/testsuite/algol68/execute/completer-8.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 20; + REF INT i := (x EXIT foo: x EXIT bar: x := 30); + ASSERT (i = 20) +END diff --git a/gcc/testsuite/algol68/execute/completer-9.a68 b/gcc/testsuite/algol68/execute/completer-9.a68 new file mode 100644 index 000000000000..b84f01039816 --- /dev/null +++ b/gcc/testsuite/algol68/execute/completer-9.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 20; + REF INT xx := x; + REF INT i := (xx EXIT foo: xx EXIT bar: xx := x); + ASSERT (i = 20) +END diff --git a/gcc/testsuite/algol68/execute/cond-clause-1.a68 b/gcc/testsuite/algol68/execute/cond-clause-1.a68 new file mode 100644 index 000000000000..059bb8a61179 --- /dev/null +++ b/gcc/testsuite/algol68/execute/cond-clause-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 10, x; + IF i > 5 THEN x := i FI; + ASSERT (x = i) +END diff --git a/gcc/testsuite/algol68/execute/cond-clause-2.a68 b/gcc/testsuite/algol68/execute/cond-clause-2.a68 new file mode 100644 index 000000000000..f8e5d5f03710 --- /dev/null +++ b/gcc/testsuite/algol68/execute/cond-clause-2.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 10, x; + IF i < 5 THEN x = i FI; + ASSERT (x /= i) +END diff --git a/gcc/testsuite/algol68/execute/cond-clause-3.a68 b/gcc/testsuite/algol68/execute/cond-clause-3.a68 new file mode 100644 index 000000000000..4e9c685c55fa --- /dev/null +++ b/gcc/testsuite/algol68/execute/cond-clause-3.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 5; + IF i = 5 + THEN 0 + ELSE ASSERT (FALSE); 1 + FI +END diff --git a/gcc/testsuite/algol68/execute/cond-clause-4.a68 b/gcc/testsuite/algol68/execute/cond-clause-4.a68 new file mode 100644 index 000000000000..0e650414fb07 --- /dev/null +++ b/gcc/testsuite/algol68/execute/cond-clause-4.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper" } # +# Declarations in enquiry clause. # +(INT i; i := 3 ; i := 2; i /= i | ASSERT (FALSE); 1 | 0) diff --git a/gcc/testsuite/algol68/execute/cond-clause-5.a68 b/gcc/testsuite/algol68/execute/cond-clause-5.a68 new file mode 100644 index 000000000000..2164c75dc81a --- /dev/null +++ b/gcc/testsuite/algol68/execute/cond-clause-5.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper" } # +# Closed clauses in enquiry clause. # +((INT i; (i := 3 ; i := 2); ((i /= i))) | ASSERT (FALSE); 1 | 0) diff --git a/gcc/testsuite/algol68/execute/cond-clause-6.a68 b/gcc/testsuite/algol68/execute/cond-clause-6.a68 new file mode 100644 index 000000000000..39b4bda31a1f --- /dev/null +++ b/gcc/testsuite/algol68/execute/cond-clause-6.a68 @@ -0,0 +1,23 @@ +# { dg-options "-fstropping=upper" } # +# Nested conditional clauses # +BEGIN + INT i = 10; + IF i > 5 THEN + IF i < 15 THEN + IF i > 11 THEN + ASSERT (FALSE); + 1 + ELSE + 0 + FI + FI + ELSE + IF i > 100 THEN + ASSERT (FALSE); + 1 + ELSE + ASSERT (FALSE); + 1 + FI + FI +END diff --git a/gcc/testsuite/algol68/execute/cond-clause-7.a68 b/gcc/testsuite/algol68/execute/cond-clause-7.a68 new file mode 100644 index 000000000000..3a5af2bdbb04 --- /dev/null +++ b/gcc/testsuite/algol68/execute/cond-clause-7.a68 @@ -0,0 +1,23 @@ +# { dg-options "-fstropping=upper" } # +# Nested conditional clauses # +BEGIN + INT i = 12; + IF i > 5 THEN + IF i < 15 THEN + IF i > 11 THEN + 0 + ELSE + ASSERT (FALSE); + 1 + FI + FI + ELSE + IF i > 100 THEN + ASSERT (FALSE); + 1 + ELSE + ASSERT (FALSE); + 1 + FI + FI +END diff --git a/gcc/testsuite/algol68/execute/cond-clause-8.a68 b/gcc/testsuite/algol68/execute/cond-clause-8.a68 new file mode 100644 index 000000000000..0b3ca04fccba --- /dev/null +++ b/gcc/testsuite/algol68/execute/cond-clause-8.a68 @@ -0,0 +1,20 @@ +# { dg-options "-fstropping=upper" } # +# ELIF # +BEGIN + INT i = 12; + IF i > 20 THEN + 1 + ELIF i > 5 THEN + BEGIN + IF FALSE THEN + ASSERT (FALSE); + 1 + ELSE + 0 + FI + END + ELIF i < 10 THEN + ASSERT (FALSE); + 1 + FI +END diff --git a/gcc/testsuite/algol68/execute/cond-clause-9.a68 b/gcc/testsuite/algol68/execute/cond-clause-9.a68 new file mode 100644 index 000000000000..d0f70e883025 --- /dev/null +++ b/gcc/testsuite/algol68/execute/cond-clause-9.a68 @@ -0,0 +1,23 @@ +# { dg-options "-fstropping=upper" } # +# ELIF with ELSE # +BEGIN + INT i = 12; + IF i > 20 THEN + 1 + ELIF i > 12 THEN + BEGIN + IF FALSE THEN + ASSERT (FALSE); + 1 + ELSE + ASSERT (FALSE); + 1 + FI + END + ELIF i < 10 THEN + ASSERT (FALSE); + 1 + ELSE + 0 + FI +END diff --git a/gcc/testsuite/algol68/execute/conformity-clause-1.a68 b/gcc/testsuite/algol68/execute/conformity-clause-1.a68 new file mode 100644 index 000000000000..d34b7cfeabf5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/conformity-clause-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE DATUM = UNION(INT,REAL,CHAR); + DATUM datum := 10; + INT i = CASE datum + IN (REAL): 2, + (INT i): i + 1, + (CHAR): 3 + ESAC; + ASSERT (i = 11) +END diff --git a/gcc/testsuite/algol68/execute/conformity-clause-2.a68 b/gcc/testsuite/algol68/execute/conformity-clause-2.a68 new file mode 100644 index 000000000000..bfa28bba3d75 --- /dev/null +++ b/gcc/testsuite/algol68/execute/conformity-clause-2.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE DATUM = UNION(INT,REAL,CHAR); + DATUM datum := "X"; + INT i = CASE datum + IN (REAL): 2, + (INT val): val + 1 + OUT INT x = 100; + x + 10 + ESAC; + ASSERT (i = 110) +END diff --git a/gcc/testsuite/algol68/execute/conformity-clause-3.a68 b/gcc/testsuite/algol68/execute/conformity-clause-3.a68 new file mode 100644 index 000000000000..d0703de0c8c7 --- /dev/null +++ b/gcc/testsuite/algol68/execute/conformity-clause-3.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE DATUM = UNION(INT,REAL,CHAR); + DATUM datum := 20; + INT i = CASE INT i = 10; datum + IN (REAL): 2, + (INT val): val + i + OUT INT x = 100; + x + 10 + ESAC; + ASSERT (i = 30) +END diff --git a/gcc/testsuite/algol68/execute/conformity-clause-4.a68 b/gcc/testsuite/algol68/execute/conformity-clause-4.a68 new file mode 100644 index 000000000000..2cac20d50830 --- /dev/null +++ b/gcc/testsuite/algol68/execute/conformity-clause-4.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []UNION(INT,STRING,REAL) datum = (10, 3.14, "foo", 200); + ASSERT (CASE datum[1] IN (INT): 100 ESAC = 100); + ASSERT (CASE datum[2] IN (REAL): 200 ESAC = 200); + ASSERT (CASE datum[3] IN (STRING): 300 ESAC = 300); + ASSERT (CASE datum[4] IN (INT): 400 ESAC = 400) +END diff --git a/gcc/testsuite/algol68/execute/conformity-clause-5.a68 b/gcc/testsuite/algol68/execute/conformity-clause-5.a68 new file mode 100644 index 000000000000..eb6f41ea22e2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/conformity-clause-5.a68 @@ -0,0 +1,14 @@ +# { dg-options "-fstropping=upper" } # +BEGIN UNION(CHAR,BOOL,INT,REAL) cbira := "X"; + IF CASE cbira + IN (BOOL b): b, + (INT i): i > 0, + (REAL r): r > 0 + OUT FALSE + ESAC + THEN # We get here if cbira was not a CHAR and was otherwise + TRUE or >0, as the case may be. + # + ASSERT (FALSE) + FI +END diff --git a/gcc/testsuite/algol68/execute/conformity-clause-6.a68 b/gcc/testsuite/algol68/execute/conformity-clause-6.a68 new file mode 100644 index 000000000000..b3d3d6cf329e --- /dev/null +++ b/gcc/testsuite/algol68/execute/conformity-clause-6.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN UNION (CHAR,BOOL,REAL) cbra = 3.14, UNION (INT,REAL) ira = 10; + IF (cbra | (CHAR): FALSE, (BOOL b): b + |: ira | (INT i): i > 0, (REAL r): r > 0) + THEN SKIP + ELSE ASSERT (FALSE) + FI +END diff --git a/gcc/testsuite/algol68/execute/conformity-clause-7.a68 b/gcc/testsuite/algol68/execute/conformity-clause-7.a68 new file mode 100644 index 000000000000..18122a3dd70c --- /dev/null +++ b/gcc/testsuite/algol68/execute/conformity-clause-7.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN UNION (CHAR,BOOL,REAL) cbra = 3.14, UNION (INT,REAL) ira = -10; + IF (cbra | (CHAR): FALSE, (BOOL b): b + |: ira | (INT i): i > 0, (REAL r): r > 0) + THEN ASSERT (FALSE) + FI +END diff --git a/gcc/testsuite/algol68/execute/conformity-clause-8.a68 b/gcc/testsuite/algol68/execute/conformity-clause-8.a68 new file mode 100644 index 000000000000..2da55f9abdfe --- /dev/null +++ b/gcc/testsuite/algol68/execute/conformity-clause-8.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE JORL = STRUCT (UNION(INT,REAL) i, REF JORL next); + REF JORL p := HEAP JORL := (10, HEAP JORL := (20.0, NIL)); + p := HEAP JORL := (30, p); + INT num ints := 0, num reals := 0; + WHILE REF JORL (p) ISNT NIL + DO CASE i OF p IN (INT): num ints +:= 1, (REAL): num reals +:= 1 ESAC; + p := next OF p + OD; + ASSERT (num ints = 2 AND num reals = 1) +END diff --git a/gcc/testsuite/algol68/execute/conformity-clause-9.a68 b/gcc/testsuite/algol68/execute/conformity-clause-9.a68 new file mode 100644 index 000000000000..55f1fc3eb880 --- /dev/null +++ b/gcc/testsuite/algol68/execute/conformity-clause-9.a68 @@ -0,0 +1,10 @@ +begin union (int, bool, string) foo = 666; + case foo + in (union(int,string) bar): + case bar + in (int i): assert (i = 666), + (string s): assert (false) + esac, + (bool baz): assert (false) + esac +end diff --git a/gcc/testsuite/algol68/execute/conj-1.a68 b/gcc/testsuite/algol68/execute/conj-1.a68 new file mode 100644 index 000000000000..1954d38bf1d0 --- /dev/null +++ b/gcc/testsuite/algol68/execute/conj-1.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN COMPL z = 4.0I5.0; + CONJ z; + LONG COMPL zz = LONG 4.0 I LONG 6.0; + CONJ zz; + LONG LONG COMPL zzz = LONG LONG 4.0 I LONG LONG 7.0; + CONJ zzz; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/cos-1.a68 b/gcc/testsuite/algol68/execute/cos-1.a68 new file mode 100644 index 000000000000..e6b0f69279ac --- /dev/null +++ b/gcc/testsuite/algol68/execute/cos-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r = 0.0; + LONG REAL rr = LONG 45.0; + LONG LONG REAL rrr = LONG LONG 60.0; + ASSERT (cos (r) = 1.0); + long cos (rr); + long long cos (rrr) +END diff --git a/gcc/testsuite/algol68/execute/declarer-1.a68 b/gcc/testsuite/algol68/execute/declarer-1.a68 new file mode 100644 index 000000000000..61af0816c83c --- /dev/null +++ b/gcc/testsuite/algol68/execute/declarer-1.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +# Tests a jump out of the elaboration of a declarer. # +BEGIN STRING month = CASE 13 + IN "Jan", "Feb","March","April","May","June", + "July","Aug","Sept", "Oct", "Nov","Dec", + stop + ESAC; + ASSERT (FALSE) +END diff --git a/gcc/testsuite/algol68/execute/declarer-2.a68 b/gcc/testsuite/algol68/execute/declarer-2.a68 new file mode 100644 index 000000000000..b474e3e516e9 --- /dev/null +++ b/gcc/testsuite/algol68/execute/declarer-2.a68 @@ -0,0 +1,6 @@ +begin int n := 1; + { The actual-declarer below should be + elaborated only once. } + [1: n +:= 1]real a, b; + assert (n = 2) +end diff --git a/gcc/testsuite/algol68/execute/deprocedure-1.a68 b/gcc/testsuite/algol68/execute/deprocedure-1.a68 new file mode 100644 index 000000000000..17834f481094 --- /dev/null +++ b/gcc/testsuite/algol68/execute/deprocedure-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x = 100; + PROC foo = INT: (INT i = 10, j = 20; PROC bar = INT: 100; i + j + bar); + ASSERT (foo = 130) +END diff --git a/gcc/testsuite/algol68/execute/deprocedure-2.a68 b/gcc/testsuite/algol68/execute/deprocedure-2.a68 new file mode 100644 index 000000000000..1f501cf7ab21 --- /dev/null +++ b/gcc/testsuite/algol68/execute/deprocedure-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Procedure variables. # +BEGIN INT x = 100; + PROC foo := INT: (INT i = 10, j = 20; PROC bar := INT: 100; i + j + bar); + ASSERT (foo = 130) +END diff --git a/gcc/testsuite/algol68/execute/deref-1.a68 b/gcc/testsuite/algol68/execute/deref-1.a68 new file mode 100644 index 000000000000..5bb4d5d373ab --- /dev/null +++ b/gcc/testsuite/algol68/execute/deref-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + INT res := (REF INT xx := x; xx); + ASSERT (res = 10) +END diff --git a/gcc/testsuite/algol68/execute/deref-2.a68 b/gcc/testsuite/algol68/execute/deref-2.a68 new file mode 100644 index 000000000000..d49dc4a6987d --- /dev/null +++ b/gcc/testsuite/algol68/execute/deref-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx := x; + x := 20; + ASSERT (xx = 20) +END diff --git a/gcc/testsuite/algol68/execute/deref-3.a68 b/gcc/testsuite/algol68/execute/deref-3.a68 new file mode 100644 index 000000000000..8c077e079bad --- /dev/null +++ b/gcc/testsuite/algol68/execute/deref-3.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + INT y := 20; + REF INT xx := x; + CO This makes xx to refer to y + REF REF INT := REF INT + CO + xx := y; + y := 30; + ASSERT (xx = 30) +END diff --git a/gcc/testsuite/algol68/execute/deref-4.a68 b/gcc/testsuite/algol68/execute/deref-4.a68 new file mode 100644 index 000000000000..59639fd86120 --- /dev/null +++ b/gcc/testsuite/algol68/execute/deref-4.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + INT y := 20; + REF INT xx := x; + # This sets x to the current value of y # + REF INT (xx) := y; + ASSERT (x = 20) +END diff --git a/gcc/testsuite/algol68/execute/deref-5.a68 b/gcc/testsuite/algol68/execute/deref-5.a68 new file mode 100644 index 000000000000..804947f3dd2c --- /dev/null +++ b/gcc/testsuite/algol68/execute/deref-5.a68 @@ -0,0 +1,42 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx := x; + REF REF INT xxx := xx; + ASSERT (x = 10); + ASSERT (xx = 10); + ASSERT (xxx = 10); + ASSERT ((x) = 10); + ASSERT ((xx) = 10); + ASSERT ((xxx) = 10); + ASSERT (x + 1 = 11); + ASSERT (xx + 1 = 11); + ASSERT (xxx + 1 = 11); + ASSERT ((x + 1) = 11); + ASSERT ((xx + 1) = 11); + ASSERT ((xxx + 1) = 11); + ASSERT ((x := x) = 10); + ASSERT ((xx := x) = 10); + ASSERT ((xxx := xx) = 10); + ASSERT ((x := x) + 1 = 11); + ASSERT ((xx := x) + 1 = 11); + ASSERT ((xxx := xx) + 1 = 11); + x := 20; + ASSERT (x = 20); + ASSERT (xx = 20); + ASSERT (xxx = 20); + ASSERT ((x) = 20); + ASSERT ((xx) = 20); + ASSERT ((xxx) = 20); + ASSERT (x + 1 = 21); + ASSERT (xx + 1 = 21); + ASSERT (xxx + 1 = 21); + ASSERT ((x + 1) = 21); + ASSERT ((xx + 1) = 21); + ASSERT ((xxx + 1) = 21); + ASSERT ((x := x) = 20); + ASSERT ((xx := x) = 20); + ASSERT ((xxx := xx) = 20); + ASSERT ((x := x) + 1 = 21); + ASSERT ((xx := x) + 1 = 21); + ASSERT ((xxx := xx) + 1 = 21) +END diff --git a/gcc/testsuite/algol68/execute/deref-6.a68 b/gcc/testsuite/algol68/execute/deref-6.a68 new file mode 100644 index 000000000000..88754d2f58ea --- /dev/null +++ b/gcc/testsuite/algol68/execute/deref-6.a68 @@ -0,0 +1,48 @@ +# { dg-options "-fstropping=upper" } # +# Dereferencing of struct fields. # +BEGIN MODE S = STRUCT (REF INT x, REF REF INT xx, REF REF REF INT xxx); + + INT x := 10; + REF INT xx := x; + REF REF INT xxx := xx; + + S s = (x, xx, xxx); + + ASSERT (x OF s = 10); + ASSERT (xx OF s = 10); + ASSERT (xxx OF s = 10); + ASSERT ((x) = 10); + ASSERT ((xx) = 10); + ASSERT ((xxx) = 10); + ASSERT (x OF s + 1 = 11); + ASSERT (xx OF s + 1 = 11); + ASSERT (xxx OF s + 1 = 11); + ASSERT ((x OF s + 1) = 11); + ASSERT ((xx OF s + 1) = 11); + ASSERT ((xxx OF s + 1) = 11); + ASSERT ((x OF s := x) = 10); + ASSERT ((xx OF s := x) = 10); + ASSERT ((xxx OF s := xx) = 10); + ASSERT ((x OF s := x) + 1 = 11); + ASSERT ((xx OF s := x) + 1 = 11); + ASSERT ((xxx OF s := xx) + 1 = 11); + x OF s := 20; + ASSERT (x OF s = 20); + ASSERT (xx OF s = 20); + ASSERT (xxx OF s = 20); + ASSERT ((x) = 20); + ASSERT ((xx) = 20); + ASSERT ((xxx) = 20); + ASSERT (x OF s + 1 = 21); + ASSERT (xx OF s + 1 = 21); + ASSERT (xxx OF s + 1 = 21); + ASSERT ((x OF s + 1) = 21); + ASSERT ((xx OF s + 1) = 21); + ASSERT ((xxx OF s + 1) = 21); + ASSERT ((x OF s := x) = 20); + ASSERT ((xx OF s := x) = 20); + ASSERT ((xxx OF s := xx) = 20); + ASSERT ((x OF s := x) + 1 = 21); + ASSERT ((xx OF s := x) + 1 = 21); + ASSERT ((xxx OF s := xx) + 1 = 21) +END diff --git a/gcc/testsuite/algol68/execute/deref-7.a68 b/gcc/testsuite/algol68/execute/deref-7.a68 new file mode 100644 index 000000000000..b2acec98f8db --- /dev/null +++ b/gcc/testsuite/algol68/execute/deref-7.a68 @@ -0,0 +1,48 @@ +# { dg-options "-fstropping=upper" } # +# Dereferencing of struct fields. Version with sub-names. # +BEGIN MODE S = STRUCT (INT x, REF INT xx, REF REF INT xxx); + + INT x := 10; + REF INT xx := x; + REF REF INT xxx := xx; + + S s := (x, xx, xxx); + + ASSERT (x OF s = 10); + ASSERT (xx OF s = 10); + ASSERT (xxx OF s = 10); + ASSERT ((x) = 10); + ASSERT ((xx) = 10); + ASSERT ((xxx) = 10); + ASSERT (x OF s + 1 = 11); + ASSERT (xx OF s + 1 = 11); + ASSERT (xxx OF s + 1 = 11); + ASSERT ((x OF s + 1) = 11); + ASSERT ((xx OF s + 1) = 11); + ASSERT ((xxx OF s + 1) = 11); + ASSERT ((x OF s := x) = 10); + ASSERT ((xx OF s := xx) = 10); + ASSERT ((xxx OF s := xxx) = 10); + ASSERT ((x OF s := x) + 1 = 11); + ASSERT ((xx OF s := xx) + 1 = 11); + ASSERT ((xxx OF s := xxx) + 1 = 11); + x := 20; + ASSERT (x OF s = 10); + ASSERT (xx OF s = 20); + ASSERT (xxx OF s = 20); + ASSERT ((x) = 20); + ASSERT ((xx) = 20); + ASSERT ((xxx) = 20); + ASSERT (x OF s + 1 = 11); + ASSERT (xx OF s + 1 = 21); + ASSERT (xxx OF s + 1 = 21); + ASSERT ((x OF s + 1) = 11); + ASSERT ((xx OF s + 1) = 21); + ASSERT ((xxx OF s + 1) = 21); + ASSERT ((x OF s := x) = 20); + ASSERT ((xx OF s := xx) = 20); + ASSERT ((xxx OF s := xxx) = 20); + ASSERT ((x OF s := x) + 1 = 21); + ASSERT ((xx OF s := xx) + 1 = 21); + ASSERT ((xxx OF s := xxx) + 1 = 21) +END diff --git a/gcc/testsuite/algol68/execute/deref-8.a68 b/gcc/testsuite/algol68/execute/deref-8.a68 new file mode 100644 index 000000000000..6d57086a5e14 --- /dev/null +++ b/gcc/testsuite/algol68/execute/deref-8.a68 @@ -0,0 +1,53 @@ +# { dg-options "-fstropping=upper" } # +# Dereferencing of struct fields. Version with sub-names and + explicit assignations instead of initialization in variable declaration. # +BEGIN MODE S = STRUCT (INT x, REF INT xx, REF REF INT xxx); + + INT x := 10; + REF INT xx := x; + REF REF INT xxx := xx; + + S s; + + x OF s := x; + xx OF s := xx; + xxx OF s := xxx; + + ASSERT (x OF s = 10); + ASSERT (xx OF s = 10); + ASSERT (xxx OF s = 10); + ASSERT ((x) = 10); + ASSERT ((xx) = 10); + ASSERT ((xxx) = 10); + ASSERT (x OF s + 1 = 11); + ASSERT (xx OF s + 1 = 11); + ASSERT (xxx OF s + 1 = 11); + ASSERT ((x OF s + 1) = 11); + ASSERT ((xx OF s + 1) = 11); + ASSERT ((xxx OF s + 1) = 11); + ASSERT ((x OF s := x) = 10); + ASSERT ((xx OF s := xx) = 10); + ASSERT ((xxx OF s := xxx) = 10); + ASSERT ((x OF s := x) + 1 = 11); + ASSERT ((xx OF s := xx) + 1 = 11); + ASSERT ((xxx OF s := xxx) + 1 = 11); + x := 20; + ASSERT (x OF s = 10); + ASSERT (xx OF s = 20); + ASSERT (xxx OF s = 20); + ASSERT ((x) = 20); + ASSERT ((xx) = 20); + ASSERT ((xxx) = 20); + ASSERT (x OF s + 1 = 11); + ASSERT (xx OF s + 1 = 21); + ASSERT (xxx OF s + 1 = 21); + ASSERT ((x OF s + 1) = 11); + ASSERT ((xx OF s + 1) = 21); + ASSERT ((xxx OF s + 1) = 21); + ASSERT ((x OF s := x) = 20); + ASSERT ((xx OF s := xx) = 20); + ASSERT ((xxx OF s := xxx) = 20); + ASSERT ((x OF s := x) + 1 = 21); + ASSERT ((xx OF s := xx) + 1 = 21); + ASSERT ((xxx OF s := xxx) + 1 = 21) +END diff --git a/gcc/testsuite/algol68/execute/div-int-1.a68 b/gcc/testsuite/algol68/execute/div-int-1.a68 new file mode 100644 index 000000000000..6a26a7bef029 --- /dev/null +++ b/gcc/testsuite/algol68/execute/div-int-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 10; + LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10; + ASSERT (i / 2 = 5.0); + ASSERT (ii / LONG 2 = LONG 5.0); + ASSERT (iii / LONG LONG 2 = LONG LONG 5.0) +END diff --git a/gcc/testsuite/algol68/execute/divab-real-1.a68 b/gcc/testsuite/algol68/execute/divab-real-1.a68 new file mode 100644 index 000000000000..830ae2e5f8d6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/divab-real-1.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r := 3.14; + r DIVAB 2.0; + r /:= 2.0; + LONG REAL rr := LONG 3.14; + rr DIVAB LONG 2.0; + rr /:= LONG 2.0; + LONG LONG REAL rrr := LONG LONG 3.14; + rrr DIVAB LONG LONG 2.0; + rrr /:= LONG LONG 2.0 +END diff --git a/gcc/testsuite/algol68/execute/elem-bits-1.a68 b/gcc/testsuite/algol68/execute/elem-bits-1.a68 new file mode 100644 index 000000000000..1529b595e749 --- /dev/null +++ b/gcc/testsuite/algol68/execute/elem-bits-1.a68 @@ -0,0 +1,18 @@ +# { dg-options "-fstropping=upper" } # +# ELEM for SIZETY BITS # +BEGIN BITS b = 2r1010; + ASSERT ((bits width - 1) ELEM b); + ASSERT (NOT ((bits width - 2) ELEM b)); + LONG BITS bb = LONG 2r1010; + ASSERT ((long bits width - 1) ELEM bb); + ASSERT (NOT ((long bits width - 2) ELEM bb)); + LONG LONG BITS bbb = LONG LONG 2r1010; + ASSERT ((long long bits width - 1) ELEM bbb); + ASSERT (NOT ((long long bits width - 2) ELEM bbb)); + SHORT BITS ss = SHORT 2r1010; + ASSERT ((short bits width - 1) ELEM ss); + ASSERT (NOT ((short bits width - 2) ELEM ss)); + SHORT SHORT BITS sss = SHORT SHORT 2r1010; + ASSERT ((short short bits width - 1) ELEM sss); + ASSERT (NOT ((short short bits width - 2) ELEM sss)) +END diff --git a/gcc/testsuite/algol68/execute/elems-1.a68 b/gcc/testsuite/algol68/execute/elems-1.a68 new file mode 100644 index 000000000000..da538fcf24d1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/elems-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (ELEMS "foo" = 3); + ASSERT (ELEMS "" = 0); + ASSERT (1 ELEMS "foo" = 3); + ASSERT (1 ELEMS "" = 0) +END diff --git a/gcc/testsuite/algol68/execute/elems-2.a68 b/gcc/testsuite/algol68/execute/elems-2.a68 new file mode 100644 index 000000000000..0545f4ec67d1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/elems-2.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Flat and ultra-flat multiples. # +BEGIN [3,10:3]INT arr; + ASSERT (2 ELEMS arr = 0); + [1:0]INT arr2; + ASSERT (ELEMS arr2 = 0) +END diff --git a/gcc/testsuite/algol68/execute/entier-1.a68 b/gcc/testsuite/algol68/execute/entier-1.a68 new file mode 100644 index 000000000000..d7c84e23d3e6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/entier-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL x = 3.14, y = 3.80; + LONG REAL xx = LONG 3.14, yy = LONG 3.80; + LONG LONG REAL xxx = LONG LONG 3.14, yyy = LONG LONG 3.80; + ASSERT (ENTIER x = 3 AND ENTIER y = 3); + ASSERT (ENTIER xx = LONG 3 AND ENTIER yy = LONG 3); + ASSERT (ENTIER xxx = LONG LONG 3 AND ENTIER yyy = LONG LONG 3) +END diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-1.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-1.a68 new file mode 100644 index 000000000000..1601ac099729 --- /dev/null +++ b/gcc/testsuite/algol68/execute/environment-enquiries-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +# Environment enquiries for SIZETY INTs # +BEGIN ASSERT (max int /= 0); + (INT max int = 10; ASSERT (max int = 10)); + ASSERT (long max int >= LENG max int); + ASSERT (long long max int >= LENG long max int); + ASSERT (min int /= 0); + ASSERT (long min int <= LENG min int); + ASSERT (long long min int <= LENG long min int) +END diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-2.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-2.a68 new file mode 100644 index 000000000000..9f9d5fc0b683 --- /dev/null +++ b/gcc/testsuite/algol68/execute/environment-enquiries-2.a68 @@ -0,0 +1,12 @@ +# { dg-options "-fstropping=upper" } # +# Environment enquiries for SIZETY REALs # +BEGIN ASSERT (max real /= 0.0); + ASSERT (long max real >= LENG max real); + ASSERT (long long max real >= LENG long max real); + ASSERT (min real /= 0.0); + ASSERT (long min real <= LENG min real); + ASSERT (long long min real <= LENG long min real); + ASSERT (small real > 0.0); + ASSERT (long small real > LONG 0.0); + ASSERT (long long small real > LONG LONG 0.0) +END diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-3.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-3.a68 new file mode 100644 index 000000000000..7aba4cd4cb18 --- /dev/null +++ b/gcc/testsuite/algol68/execute/environment-enquiries-3.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +# Environment enquiries for SIZETY BITS # +BEGIN ASSERT (bits width > 0); + ASSERT (long bits width >= bits width); + ASSERT (long long bits width >= long bits width); + ASSERT (short bits width <= bits width); + ASSERT (short short bits width <= short bits width) +END + diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-4.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-4.a68 new file mode 100644 index 000000000000..b053ed143476 --- /dev/null +++ b/gcc/testsuite/algol68/execute/environment-enquiries-4.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Environment enquiries for pi constants. # +BEGIN ASSERT (pi > 3.0 AND pi < 4.0); + ASSERT (long pi > LONG 3.0 AND long pi < LONG 4.0); + ASSERT (long long pi > LONG LONG 3.0 AND long long pi < LONG LONG 4.0) +END + diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-5.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-5.a68 new file mode 100644 index 000000000000..a46879857b60 --- /dev/null +++ b/gcc/testsuite/algol68/execute/environment-enquiries-5.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Environment enquiries for certain particular characters. # +BEGIN ASSERT (null character /= blank); + ASSERT (max abs char = ABS 16r10ffff) +END diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-6.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-6.a68 new file mode 100644 index 000000000000..a37dd4c2e421 --- /dev/null +++ b/gcc/testsuite/algol68/execute/environment-enquiries-6.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Environment enquiries for SIZETY BITs # +BEGIN ASSERT (max bits /= 10r0); + # XXX use LENG max bits below # + ASSERT (long max bits >= LONG 10r0); + ASSERT (long long max bits >= LONG LONG 10r0) +END diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-7.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-7.a68 new file mode 100644 index 000000000000..d64a68f28d30 --- /dev/null +++ b/gcc/testsuite/algol68/execute/environment-enquiries-7.a68 @@ -0,0 +1,15 @@ +# { dg-options "-fstropping=upper" } # +# Environment enquiries for widths # +BEGIN ASSERT (int width > 0); + ASSERT (long int width > 0); + ASSERT (long long int width > 0); + ASSERT (short int width > 0); + ASSERT (short short int width > 0); + ASSERT (real width > 0); + ASSERT (long real width > 0); + ASSERT (long long real width > 0) +CO exp width; + long exp width; + long long exp width; +CO +END diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-8.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-8.a68 new file mode 100644 index 000000000000..8c2c904793d1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/environment-enquiries-8.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (flip = "T"); + ASSERT (flop = "F"); + ASSERT (error char = "*"); + ASSERT (ABS replacement char = ABS 16rfffd) +END diff --git a/gcc/testsuite/algol68/execute/eq-bits-1.a68 b/gcc/testsuite/algol68/execute/eq-bits-1.a68 new file mode 100644 index 000000000000..b26df33d8b1a --- /dev/null +++ b/gcc/testsuite/algol68/execute/eq-bits-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN BITS b, LONG BITS bb = LONG 16rff, LONG LONG BITS bbb; + SHORT BITS ss = SHORT 16rff, SHORT SHORT BITS sss; + ASSERT (b = 2r0); + ASSERT (bb EQ LONG 8r377); + ASSERT (bbb = LONG LONG 8r0); + ASSERT (ss EQ SHORT 8r377); + ASSERT (sss = SHORT SHORT 8r0) +END + diff --git a/gcc/testsuite/algol68/execute/eq-char-char-1.a68 b/gcc/testsuite/algol68/execute/eq-char-char-1.a68 new file mode 100644 index 000000000000..eb520d2d6a84 --- /dev/null +++ b/gcc/testsuite/algol68/execute/eq-char-char-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT ("a" = "a") +END + diff --git a/gcc/testsuite/algol68/execute/eq-int-1.a68 b/gcc/testsuite/algol68/execute/eq-int-1.a68 new file mode 100644 index 000000000000..399b91aeab75 --- /dev/null +++ b/gcc/testsuite/algol68/execute/eq-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 12; + LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12; + SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12; + ASSERT (12 = i); + ASSERT (ii = LONG 12); + ASSERT (iii = LONG LONG 12); + ASSERT (s = SHORT 12); + ASSERT (ss = SHORT SHORT 12) +END diff --git a/gcc/testsuite/algol68/execute/eq-string-1.a68 b/gcc/testsuite/algol68/execute/eq-string-1.a68 new file mode 100644 index 000000000000..0242f02bafb0 --- /dev/null +++ b/gcc/testsuite/algol68/execute/eq-string-1.a68 @@ -0,0 +1,16 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING foo = "foo", bar = "bar", quux = "quux"; + # = # + ASSERT ("" = ""); + ASSERT ("foo" = foo); + ASSERT (NOT (foo = bar)); + ASSERT (NOT (foo = quux)); + ASSERT (NOT (quux = foo)); + # EQ # + ASSERT ("" EQ ""); + ASSERT ("foo" EQ foo); + ASSERT (NOT (foo EQ bar)); + ASSERT (NOT (foo EQ quux)); + ASSERT (NOT (quux EQ foo)) +END + diff --git a/gcc/testsuite/algol68/execute/eq-string-stride-1.a68 b/gcc/testsuite/algol68/execute/eq-string-stride-1.a68 new file mode 100644 index 000000000000..6e9cec79a45f --- /dev/null +++ b/gcc/testsuite/algol68/execute/eq-string-stride-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]CHAR matrix = (("1", "2", "3"), + ("4", "5", "6"), + ("7", "8", "9")); + ASSERT (matrix[1:3,2] = "258") +END diff --git a/gcc/testsuite/algol68/execute/execute.exp b/gcc/testsuite/algol68/execute/execute.exp new file mode 100644 index 000000000000..60722c7ad097 --- /dev/null +++ b/gcc/testsuite/algol68/execute/execute.exp @@ -0,0 +1,37 @@ +# Copyright (C) 2024 Free Software Foundation, Inc. + +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# Execute tests, torture testing. + +if $tracelevel then { + strace $tracelevel +} + +load_lib algol68-torture.exp +load_lib torture-options.exp + +torture-init +set-torture-options $TORTURE_OPTIONS + +foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.a68]] { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $testcase] then { + continue + } + algol68-torture-execute $testcase + set algol68_compile_args "" +} + +torture-finish diff --git a/gcc/testsuite/algol68/execute/factorial-1.a68 b/gcc/testsuite/algol68/execute/factorial-1.a68 new file mode 100644 index 000000000000..f1fa920ae200 --- /dev/null +++ b/gcc/testsuite/algol68/execute/factorial-1.a68 @@ -0,0 +1,170 @@ +# { dg-options "-fstropping=upper" } # +# The Most Contrived Factorial Program + By John P. Baker + University of Bristol. + + Published in the Algol Bulletin 42. + http://jemarch.net/algol-bulletin-42.pdf + + Version adapted for GCC. +# + +BEGIN INT one = 1, two = 2, three = 3, four = 4, five = 5, + six = 6, seven = 7, eight = 8, nine = 9, ten = 10, + eleven = 11, twelve = 12; + INT a = one; + PRIO ME=5, LOVE=7, MY=7, LORDS=7, LADIES=7, + PIPERS=7, DRUMMERS=7, MAIDS=7, SWANS=7, GEESE=7, + GOLD=7, COLLY=7, FRENCH=7, TURTLE=7, PARTRIDGE=6; + BOOL sent to := TRUE; + OP THE = (BOOL a) BOOL: a, + TWELFTH = (INT a) BOOL: a = twelve, + ELEVENTH = (INT a) BOOL: a = eleven, + TENTH = (INT a) BOOL: a = ten, + NINTH = (INT a) BOOL: a = nine, + EIGHTH = (INT a) BOOL: a = eight, + SEVENTH = (INT a) BOOL: a = seven, + SIXTH = (INT a) BOOL: a = six, + FIFTH = (INT a) BOOL: a = five, + FOURTH = (INT a) BOOL: a = four, + THIRD = (INT a) BOOL: a = three, + SECOND = (INT a) BOOL: a = two, + FIRST = (INT a) BOOL: a = one; + OP ME = (BOOL a, INT b) VOID: SKIP; # XXX when transput done (a|print(b)) # + OP LOVE = (BOOL a, b) BOOL: (a|b|FALSE), + MY = (BOOL a, b) BOOL: a LOVE b; + OP AND = (INT a) INT: a; + MODE DATE = STRUCT (INT day, month); + LOC DATE christmas := (25, 12); + OP LORDS = (INT a, b) INT: a * b, + LADIES = (INT a, b) INT: a * b, + PIPERS = (INT a, b) INT: a * b, + DRUMMERS = (INT a, b) INT: a * b, + MAIDS = (INT a, b) INT: a * b, + SWANS = (INT a, b) INT: a * b, + GEESE = (INT a, b) INT: a * b, + GOLD = (INT a, b) INT: a * b, + COLLY = (INT a, b) INT: a * b, + FRENCH = (INT a, b) INT: a * b, + TURTLE = (INT a, b) INT: a * b; + OP LEAPING = (INT a) INT: a, + DANCING = (INT a) INT: a, + PIPING = (INT a) INT: a, + DRUMMING = (INT a) INT: a, + MILKING = (INT a) INT: a, + SWIMMING = (INT a) INT: a, + LAYING = (INT a) INT: a, + RINGS = (INT a) INT: a, + BIRDS = (INT a) INT: a, + HENS = (INT a) INT: a, + DOVES = (INT a) INT: a; + OP PARTRIDGE = (INT a, b) INT: a + b; + INT in a pear tree = 0; + + # Now we are ready... # + + THE FIRST day OF christmas MY TRUE LOVE sent to ME + a PARTRIDGE in a pear tree; + + THE SECOND day OF christmas MY TRUE LOVE sent to ME + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + THE THIRD day OF christmas MY TRUE LOVE sent to ME + three FRENCH HENS + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + THE FOURTH day OF christmas MY TRUE LOVE sent to ME + four COLLY BIRDS + three FRENCH HENS + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + THE FIFTH day OF christmas MY TRUE LOVE sent to ME + five GOLD RINGS + four COLLY BIRDS + three FRENCH HENS + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + THE SIXTH day OF christmas MY TRUE LOVE sent to ME + six GEESE LAYING + five GOLD RINGS + four COLLY BIRDS + three FRENCH HENS + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + THE SEVENTH day OF christmas MY TRUE LOVE sent to ME + seven SWANS SWIMMING + six GEESE LAYING + five GOLD RINGS + four COLLY BIRDS + three FRENCH HENS + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + THE EIGHTH day OF christmas MY TRUE LOVE sent to ME + eight MAIDS MILKING + seven SWANS SWIMMING + six GEESE LAYING + five GOLD RINGS + four COLLY BIRDS + three FRENCH HENS + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + THE NINTH day OF christmas MY TRUE LOVE sent to ME + nine DRUMMERS DRUMMING + eight MAIDS MILKING + seven SWANS SWIMMING + six GEESE LAYING + five GOLD RINGS + four COLLY BIRDS + three FRENCH HENS + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + THE TENTH day OF christmas MY TRUE LOVE sent to ME + ten PIPERS PIPING + nine DRUMMERS DRUMMING + eight MAIDS MILKING + seven SWANS SWIMMING + six GEESE LAYING + five GOLD RINGS + four COLLY BIRDS + three FRENCH HENS + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + THE ELEVENTH day OF christmas MY TRUE LOVE sent to ME + eleven LADIES DANCING + ten PIPERS PIPING + nine DRUMMERS DRUMMING + eight MAIDS MILKING + seven SWANS SWIMMING + six GEESE LAYING + five GOLD RINGS + four COLLY BIRDS + three FRENCH HENS + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + THE TWELFTH day OF christmas MY TRUE LOVE sent to ME + twelve LORDS LEAPING + eleven LADIES DANCING + ten PIPERS PIPING + nine DRUMMERS DRUMMING + eight MAIDS MILKING + seven SWANS SWIMMING + six GEESE LAYING + five GOLD RINGS + four COLLY BIRDS + three FRENCH HENS + two TURTLE DOVES AND + a PARTRIDGE in a pear tree; + + SKIP +END + diff --git a/gcc/testsuite/algol68/execute/flat-assignation-1.a68 b/gcc/testsuite/algol68/execute/flat-assignation-1.a68 new file mode 100644 index 000000000000..bf973564b1f5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/flat-assignation-1.a68 @@ -0,0 +1,7 @@ +{ Assigning to the flexible name replaces the descriptor + as well as the elements. } +begin [10:0]int flat1; + flex[10:-10]int flat2; + flat2 := flat1; + assert (UPB flat2 = 0 AND LWB flat2 = 10) +end diff --git a/gcc/testsuite/algol68/execute/flat-assignation-2.a68 b/gcc/testsuite/algol68/execute/flat-assignation-2.a68 new file mode 100644 index 000000000000..fb7fa82ba687 --- /dev/null +++ b/gcc/testsuite/algol68/execute/flat-assignation-2.a68 @@ -0,0 +1,8 @@ +{ Assigning to the flexible name replaces the descriptor + as well as the elements. } +begin [1:20,10:0]int flat1; + flex[100:200,10:-10]int flat2; + flat2 := flat1; + assert (1 UPB flat2 = 20 AND 1 LWB flat2 = 1); + assert (2 UPB flat2 = 0 AND 2 LWB flat2 = 10) +end diff --git a/gcc/testsuite/algol68/execute/flex-1.a68 b/gcc/testsuite/algol68/execute/flex-1.a68 new file mode 100644 index 000000000000..4e2bc315097c --- /dev/null +++ b/gcc/testsuite/algol68/execute/flex-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN FLEX[3]INT list := (1,2,3); + list[2] := 20; + ASSERT (list[2] = 20) +END diff --git a/gcc/testsuite/algol68/execute/flex-2.a68 b/gcc/testsuite/algol68/execute/flex-2.a68 new file mode 100644 index 000000000000..4f18674bc886 --- /dev/null +++ b/gcc/testsuite/algol68/execute/flex-2.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# Rowing to flexible rows. # +BEGIN FLEX[]INT list = 10; + ASSERT (list[1] = 10); + FLEX[,]INT table = 10; + ASSERT (table[1,1] = 10) +END + diff --git a/gcc/testsuite/algol68/execute/flex-3.a68 b/gcc/testsuite/algol68/execute/flex-3.a68 new file mode 100644 index 000000000000..8ee388557277 --- /dev/null +++ b/gcc/testsuite/algol68/execute/flex-3.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Slicing flexible names. # +BEGIN FLEX[]INT list = (1,2,3); + FLEX[]INT sliced = list[2:3]; + ASSERT (LWB sliced = 1 AND UPB sliced = 2); + ASSERT (sliced[1] = 2 AND sliced[2] = 3) +END diff --git a/gcc/testsuite/algol68/execute/flex-4.a68 b/gcc/testsuite/algol68/execute/flex-4.a68 new file mode 100644 index 000000000000..d4d7c998f7dc --- /dev/null +++ b/gcc/testsuite/algol68/execute/flex-4.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Rowing to flexible rows. # +BEGIN FLEX[3]INT list := (1,2,3); + list := (10,20,30,40); + ASSERT (list[4] = 40) +END diff --git a/gcc/testsuite/algol68/execute/flex-5.a68 b/gcc/testsuite/algol68/execute/flex-5.a68 new file mode 100644 index 000000000000..9f9dccc36640 --- /dev/null +++ b/gcc/testsuite/algol68/execute/flex-5.a68 @@ -0,0 +1,12 @@ +# { dg-options "-fstropping=upper" } # +BEGIN FLEX[1:0]INT a; + ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0); + a := (1,2,3); + ASSERT (LWB a = 1 AND UPB a = 3 AND a[1] = 1 AND a[2] = 2 AND a[3] = 3); + a := (10,a[2],a[3]); + ASSERT (LWB a = 1 AND UPB a = 3 AND a[1] = 10 AND a[2] = 2 AND a[3] = 3); + a := 100; + ASSERT (LWB a = 1 AND UPB a = 1 AND a[1] = 100); + a := (); + ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0) +END diff --git a/gcc/testsuite/algol68/execute/formula-1.a68 b/gcc/testsuite/algol68/execute/formula-1.a68 new file mode 100644 index 000000000000..6d2ba4ef82d1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/formula-1.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN OP JORL = (INT a, b) INT: a + b; + OP JORL = (REAL a, b) REAL: a + b; + OP JORL = ([]CHAR s) INT: ELEMS s; + PRIO JORL = 6; + ASSERT (10 JORL 20 = 30); + ASSERT (REAL r = 3.14 JORL REAL (1); r > 4.13 AND r < 4.15); + ASSERT (JORL "foo" = 3) +END diff --git a/gcc/testsuite/algol68/execute/formula-2.a68 b/gcc/testsuite/algol68/execute/formula-2.a68 new file mode 100644 index 000000000000..5b09f3d870f9 --- /dev/null +++ b/gcc/testsuite/algol68/execute/formula-2.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i; + PROC side = INT: (i := 1; i := 2; i); + INT res = side + side; + # Can be either due to collateral elaboration in the formula above. # + ASSERT (res = 3 OR res = 4) +END diff --git a/gcc/testsuite/algol68/execute/fsize-1.a68 b/gcc/testsuite/algol68/execute/fsize-1.a68 new file mode 100644 index 000000000000..17e3ef2ba9ef --- /dev/null +++ b/gcc/testsuite/algol68/execute/fsize-1.a68 @@ -0,0 +1,2 @@ +begin assert (fsize (-1) = - long long 1) +end diff --git a/gcc/testsuite/algol68/execute/ge-int-1.a68 b/gcc/testsuite/algol68/execute/ge-int-1.a68 new file mode 100644 index 000000000000..9ed95321c095 --- /dev/null +++ b/gcc/testsuite/algol68/execute/ge-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 12; + LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12; + SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12; + ASSERT (i >= 10); + ASSERT (ii GE LONG 10); + ASSERT (iii >= LONG LONG 12); + ASSERT (s >= SHORT 12); + ASSERT (ss >= SHORT SHORT 10) +END diff --git a/gcc/testsuite/algol68/execute/ge-string-stride-1.a68 b/gcc/testsuite/algol68/execute/ge-string-stride-1.a68 new file mode 100644 index 000000000000..4f51d6ba6fcb --- /dev/null +++ b/gcc/testsuite/algol68/execute/ge-string-stride-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]CHAR matrix = (("1", "0", "1"), + ("4", "0", "4"), + ("7", "0", "7")); + ASSERT (matrix[1:3,1] >= matrix[1:3,3]); + ASSERT (("1","4","7") >= matrix[1:3,3]) +END diff --git a/gcc/testsuite/algol68/execute/gen-flex-1.a68 b/gcc/testsuite/algol68/execute/gen-flex-1.a68 new file mode 100644 index 000000000000..ce993df27d20 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-flex-1.a68 @@ -0,0 +1,10 @@ +begin flex[10:-10]int je; + int num_fields = 3; + assert (UPB je = -10 AND LWB je = 10 AND ELEMS je = 0); + + [1:num_fields][1:num_fields]string fields; + for i to num_fields + do for j to num_fields + do assert (fields[i][j] = "") od + od +end diff --git a/gcc/testsuite/algol68/execute/gen-heap-1.a68 b/gcc/testsuite/algol68/execute/gen-heap-1.a68 new file mode 100644 index 000000000000..fdf8df23c6ef --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-heap-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT jorl; + REF INT var = HEAP INT; + var := jorl := 10; + ASSERT (var = 10) +END diff --git a/gcc/testsuite/algol68/execute/gen-heap-2.a68 b/gcc/testsuite/algol68/execute/gen-heap-2.a68 new file mode 100644 index 000000000000..80e3a77676c7 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-heap-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT jorl; + REF INT var := HEAP INT; + var := jorl := 10; + ASSERT (var = 10) +END diff --git a/gcc/testsuite/algol68/execute/gen-heap-3.a68 b/gcc/testsuite/algol68/execute/gen-heap-3.a68 new file mode 100644 index 000000000000..e2c026b2bc81 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-heap-3.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT jorl; + INT var := HEAP INT := 15; # The generated name goes away # + ASSERT (var = 15) +END diff --git a/gcc/testsuite/algol68/execute/gen-heap-bool-1.a68 b/gcc/testsuite/algol68/execute/gen-heap-bool-1.a68 new file mode 100644 index 000000000000..d4494f0d7536 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-heap-bool-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REF BOOL x = HEAP BOOL; + ASSERT (x = FALSE); + x := TRUE; + ASSERT (x = TRUE) +END diff --git a/gcc/testsuite/algol68/execute/gen-heap-int-1.a68 b/gcc/testsuite/algol68/execute/gen-heap-int-1.a68 new file mode 100644 index 000000000000..8500d792cbad --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-heap-int-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REF INT x = HEAP INT := 4; + ASSERT (x = 4) +END diff --git a/gcc/testsuite/algol68/execute/gen-heap-real-1.a68 b/gcc/testsuite/algol68/execute/gen-heap-real-1.a68 new file mode 100644 index 000000000000..3ea6dcb7edfe --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-heap-real-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REF REAL x = HEAP REAL := 4; + ASSERT (x > 3.9 AND x < 4.1) +END diff --git a/gcc/testsuite/algol68/execute/gen-heap-struct-1.a68 b/gcc/testsuite/algol68/execute/gen-heap-struct-1.a68 new file mode 100644 index 000000000000..2c2f9744371a --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-heap-struct-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN HEAP STRUCT(INT i, REAL r) foo; + ASSERT (i OF foo = 0) +END diff --git a/gcc/testsuite/algol68/execute/gen-heap-struct-2.a68 b/gcc/testsuite/algol68/execute/gen-heap-struct-2.a68 new file mode 100644 index 000000000000..0803204d2d89 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-heap-struct-2.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN HEAP STRUCT([10]INT i, REAL r) foo; + FOR i FROM LWB i OF foo TO UPB i OF foo + DO ASSERT ((i OF foo)[i] = 0) OD +END diff --git a/gcc/testsuite/algol68/execute/gen-heap-struct-3.a68 b/gcc/testsuite/algol68/execute/gen-heap-struct-3.a68 new file mode 100644 index 000000000000..849bbbd6234e --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-heap-struct-3.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN HEAP STRUCT([10]INT i, STRING s) foo; + FOR i FROM LWB i OF foo TO UPB i OF foo + DO ASSERT ((i OF foo)[i] = 0) OD +END diff --git a/gcc/testsuite/algol68/execute/gen-loc-1.a68 b/gcc/testsuite/algol68/execute/gen-loc-1.a68 new file mode 100644 index 000000000000..1a61bbea0a12 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-loc-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT jorl; + REF INT var = LOC INT; + var := jorl := 10; + ASSERT (var = 10) +END diff --git a/gcc/testsuite/algol68/execute/gen-loc-2.a68 b/gcc/testsuite/algol68/execute/gen-loc-2.a68 new file mode 100644 index 000000000000..fce63efec695 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-loc-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT jorl; + REF INT var := LOC INT; + var := jorl := 10; + ASSERT (var = 10) +END diff --git a/gcc/testsuite/algol68/execute/gen-loc-3.a68 b/gcc/testsuite/algol68/execute/gen-loc-3.a68 new file mode 100644 index 000000000000..66c3cf1ea0c5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-loc-3.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT jorl; + INT var := LOC INT := 15; # The generated name goes away # + ASSERT (var = 15) +END diff --git a/gcc/testsuite/algol68/execute/gen-loc-4.a68 b/gcc/testsuite/algol68/execute/gen-loc-4.a68 new file mode 100644 index 000000000000..6aeb30008e09 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-loc-4.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE NODE = STRUCT (INT code, REF NODE next); + + NODE top := (10, NIL); + next OF top := LOC NODE := (20, NIL); + ASSERT (code OF top = 10); + ASSERT (code OF next OF top = 20) +END diff --git a/gcc/testsuite/algol68/execute/gen-multiple-1.a68 b/gcc/testsuite/algol68/execute/gen-multiple-1.a68 new file mode 100644 index 000000000000..2be0d96e77e3 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-multiple-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE JORL = [(INT x; x + 1)]INT; + JORL xx; + ASSERT (ELEMS xx = 1 AND xx[1] = 0) +END diff --git a/gcc/testsuite/algol68/execute/gen-union-1.a68 b/gcc/testsuite/algol68/execute/gen-union-1.a68 new file mode 100644 index 000000000000..893da2229061 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-union-1.a68 @@ -0,0 +1,17 @@ +# { dg-options "-fstropping=upper" } # +BEGIN UNION(INT,REAL,[]INT,CHAR) datux; + ASSERT (CASE datux + IN (INT): 10, + (REAL): 20, + (CHAR): 30, + ([]INT): 40 + ESAC = 0); + []INT ja = (1,2,3); + datux := ja; + ASSERT (CASE datux + IN (INT): 10, + (REAL): 20, + (CHAR): 30, + ([]INT): 40 + ESAC = 40) +END diff --git a/gcc/testsuite/algol68/execute/gen-union-2.a68 b/gcc/testsuite/algol68/execute/gen-union-2.a68 new file mode 100644 index 000000000000..27ab7a8aeb19 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-union-2.a68 @@ -0,0 +1,20 @@ +# { dg-options "-fstropping=upper" } # +# pr UPPER pr # +BEGIN [10]UNION(INT,REAL,[]INT,CHAR) datux; + FOR i FROM LWB datux TO UPB datux + DO ASSERT (CASE datux[i] + IN (INT): 10, + (REAL): 20, + (CHAR): 30, + ([]INT): 40 + ESAC = 0); + []INT ja = (1,2,3); + datux[i] := ja; + ASSERT (CASE datux[i] + IN (INT): 10, + (REAL): 20, + (CHAR): 30, + ([]INT): 40 + ESAC = 40) + OD +END diff --git a/gcc/testsuite/algol68/execute/gen-union-3.a68 b/gcc/testsuite/algol68/execute/gen-union-3.a68 new file mode 100644 index 000000000000..78c5d0585845 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gen-union-3.a68 @@ -0,0 +1,14 @@ +# { dg-options "-fstropping=upper" } # +# An union generated from SKIP has -1 as overhead. # +BEGIN MODE JSONVAL = UNION (JSONOBJ,JSONSTR), + JSONSTR = STRING, + JSONOBJ = STRUCT (REF JSONFLD fields), + JSONFLD = STRUCT (JSONVAL value, REF JSONFLD next); + + JSONFLD fields; + ASSERT (CASE value OF fields + IN (JSONSTR s): "string", + (JSONOBJ o): "object" + OUT "fuckyou" + ESAC = "fuckyou") +END diff --git a/gcc/testsuite/algol68/execute/goto-1.a68 b/gcc/testsuite/algol68/execute/goto-1.a68 new file mode 100644 index 000000000000..7f61575efb2f --- /dev/null +++ b/gcc/testsuite/algol68/execute/goto-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 0; +beg: IF (i < 5) + THEN i +:= 1; + GOTO beg + FI +END diff --git a/gcc/testsuite/algol68/execute/goto-2.a68 b/gcc/testsuite/algol68/execute/goto-2.a68 new file mode 100644 index 000000000000..7f78215af283 --- /dev/null +++ b/gcc/testsuite/algol68/execute/goto-2.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN GOTO end; + ASSERT(FALSE); +end: SKIP +END diff --git a/gcc/testsuite/algol68/execute/goto-3.a68 b/gcc/testsuite/algol68/execute/goto-3.a68 new file mode 100644 index 000000000000..47573d2f8c1d --- /dev/null +++ b/gcc/testsuite/algol68/execute/goto-3.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN + INT i := 0; + beginning: + IF (i < 5) THEN + i +:= 1; + GO TO beginning + FI +END diff --git a/gcc/testsuite/algol68/execute/goto-4.a68 b/gcc/testsuite/algol68/execute/goto-4.a68 new file mode 100644 index 000000000000..c374ca86c1bf --- /dev/null +++ b/gcc/testsuite/algol68/execute/goto-4.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN + INT i := 0; + beginning: + IF (i < 5) THEN + i +:= 1; + beginning + FI +END diff --git a/gcc/testsuite/algol68/execute/goto-5.a68 b/gcc/testsuite/algol68/execute/goto-5.a68 new file mode 100644 index 000000000000..a5c720e3e63f --- /dev/null +++ b/gcc/testsuite/algol68/execute/goto-5.a68 @@ -0,0 +1,20 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC is prime = (INT m) BOOL: + BEGIN IF m < 2 + THEN puts ("program terminated because m is less than 2\n"); + GOTO stop + FI; + + BOOL factor found := NOT (ODD m OR m = 2); + FOR i FROM 3 BY 2 TO m - 1 WHILE NOT factor found + DO factor found := m MOD i = 0 OD; + factor found + END; + + ASSERT (is prime (1)); + ASSERT (is prime (3)); + ASSERT (is prime (71)); + ASSERT (is prime (97)); + is prime (0); + ASSERT (FALSE) # Should jump to stop in the standard postlude. # +END diff --git a/gcc/testsuite/algol68/execute/gt-int-1.a68 b/gcc/testsuite/algol68/execute/gt-int-1.a68 new file mode 100644 index 000000000000..cd5437b9ff88 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gt-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 12; + LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12; + SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12; + ASSERT (i > 10); + ASSERT (ii GT LONG 10); + ASSERT (iii > LONG LONG 10); + ASSERT (s > SHORT 10); + ASSERT (ss > SHORT SHORT 10) +END diff --git a/gcc/testsuite/algol68/execute/gt-string-stride-1.a68 b/gcc/testsuite/algol68/execute/gt-string-stride-1.a68 new file mode 100644 index 000000000000..3f0565cf2716 --- /dev/null +++ b/gcc/testsuite/algol68/execute/gt-string-stride-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]CHAR matrix = (("1", "0", "1"), + ("4", "0", "4"), + ("7", "0", "6")); + ASSERT (matrix[1:3,1] > matrix[1:3,3]); + ASSERT (("1","4","7") > matrix[1:3,3]) +END diff --git a/gcc/testsuite/algol68/execute/i-1.a68 b/gcc/testsuite/algol68/execute/i-1.a68 new file mode 100644 index 000000000000..87b6979c6002 --- /dev/null +++ b/gcc/testsuite/algol68/execute/i-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN COMPL z = 4I5; + LONG COMPL zz = LONG 4 I LONG 6; + LONG LONG COMPL zzz = LONG LONG 4 I LONG LONG7; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/i-2.a68 b/gcc/testsuite/algol68/execute/i-2.a68 new file mode 100644 index 000000000000..455f0096e2e2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/i-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN COMPL z = 4.0I5.0; + LONG COMPL zz = LONG 4.0 I LONG 6.0; + LONG LONG COMPL zzz = LONG LONG 4.0 I LONG LONG 7.0; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/identification-1.a68 b/gcc/testsuite/algol68/execute/identification-1.a68 new file mode 100644 index 000000000000..71cc808cff4a --- /dev/null +++ b/gcc/testsuite/algol68/execute/identification-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC a = REAL: b := c; + REAL b := 1, c := 2; + REAL x := a; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/identification-2.a68 b/gcc/testsuite/algol68/execute/identification-2.a68 new file mode 100644 index 000000000000..8292063373a9 --- /dev/null +++ b/gcc/testsuite/algol68/execute/identification-2.a68 @@ -0,0 +1,14 @@ +# { dg-options "-fstropping=upper" } # +# The identification of c in the assignation marked with XXX works. + In some Algol 68 systems the assignation may fail or result in UB, + because the storage of the REF REAL c doesn't exist yet. In GNU + Algol 68 this works and the value yielded by c is guaranteed to be + zero. +# + +BEGIN REAL b; + b := c; # XXX # + ASSERT (b = 0); + REAL c; + c := b +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-1.a68 b/gcc/testsuite/algol68/execute/identity-declaration-1.a68 new file mode 100644 index 000000000000..ddfa8f28bcbd --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx = x := 20; + ASSERT (xx = 20); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-2.a68 b/gcc/testsuite/algol68/execute/identity-declaration-2.a68 new file mode 100644 index 000000000000..28ba62a9c64b --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx = x; + ASSERT (xx = 10); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-3.a68 b/gcc/testsuite/algol68/execute/identity-declaration-3.a68 new file mode 100644 index 000000000000..a694c3a640ef --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-3.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx = (x := 20); + ASSERT (xx = 20); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-4.a68 b/gcc/testsuite/algol68/execute/identity-declaration-4.a68 new file mode 100644 index 000000000000..d60867eff326 --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-4.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx = ((x)); + ASSERT (xx = 10) +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-5.a68 b/gcc/testsuite/algol68/execute/identity-declaration-5.a68 new file mode 100644 index 000000000000..7c29de1b92b6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-5.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE FOO = STRUCT (STRING s, INT i); + FOO f1 = ("foo", 10); + ASSERT (i OF f1 = 10) +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-1.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-1.a68 new file mode 100644 index 000000000000..9864ab975942 --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT foo = (1,2,3); + ASSERT (ELEMS foo = 3) +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-2.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-2.a68 new file mode 100644 index 000000000000..6fd973ee4453 --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-2.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [][]INT foo = ((1,2,3),(4,5,6)); + ASSERT (ELEMS foo = 2) +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-3.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-3.a68 new file mode 100644 index 000000000000..2d3b8f3c7bee --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-3.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [3]INT a := (1,2,3); + REF[]INT nn = a; # No copy happens here. # + nn[1] := 200; + ASSERT (a[1] = 200) +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-5.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-5.a68 new file mode 100644 index 000000000000..005a3c6c4fbb --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-5.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [:]INT foo = (1,2,3); + ASSERT (ELEMS foo = 3) +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-1.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-1.a68 new file mode 100644 index 000000000000..c8890c27c3d3 --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT a = (); + ASSERT (UPB a = 0); + ASSERT (LWB a = 1); + ASSERT (ELEMS a = 0) +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-2.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-2.a68 new file mode 100644 index 000000000000..67b5294d15b6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-2.a68 @@ -0,0 +1,12 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,,]INT a = (); + ASSERT (1 UPB a = 0); + ASSERT (1 LWB a = 1); + ASSERT (1 ELEMS a = 0); + ASSERT (2 UPB a = 0); + ASSERT (2 LWB a = 1); + ASSERT (2 ELEMS a = 0); + ASSERT (3 UPB a = 0); + ASSERT (3 LWB a = 1); + ASSERT (3 ELEMS a = 0) +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-3.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-3.a68 new file mode 100644 index 000000000000..b74761f74739 --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-3.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC foo = ([]INT a) VOID: (ASSERT (ELEMS a = 0)); + foo ([]INT()) +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-4.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-4.a68 new file mode 100644 index 000000000000..69bd760298a7 --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-4.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC foo = ([]INT a) VOID: (ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0)); + foo (()) +END diff --git a/gcc/testsuite/algol68/execute/identity-declaration-struct-1.a68 b/gcc/testsuite/algol68/execute/identity-declaration-struct-1.a68 new file mode 100644 index 000000000000..58e26b057d06 --- /dev/null +++ b/gcc/testsuite/algol68/execute/identity-declaration-struct-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +# An identity declaration shall make a copy of the struct value being + ascribed. # +BEGIN MODE FOO = STRUCT (STRING s, INT n); + FOO f1 := ("foo", 10); + FOO f2 = f1; + f1 := ("bar", 20); + ASSERT (n OF f1 = 20); + ASSERT (n OF f2 = 10) +END diff --git a/gcc/testsuite/algol68/execute/infinity-1.a68 b/gcc/testsuite/algol68/execute/infinity-1.a68 new file mode 100644 index 000000000000..a7c4fb29ca30 --- /dev/null +++ b/gcc/testsuite/algol68/execute/infinity-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN infinity; + minus infinity +END diff --git a/gcc/testsuite/algol68/execute/le-ge-bits-1.a68 b/gcc/testsuite/algol68/execute/le-ge-bits-1.a68 new file mode 100644 index 000000000000..8b355f1ba457 --- /dev/null +++ b/gcc/testsuite/algol68/execute/le-ge-bits-1.a68 @@ -0,0 +1,17 @@ +# { dg-options "-fstropping=upper" } # +# <= and => for SIZETY BITS # +BEGIN ASSERT (16rff <= 16rffff); + ASSERT (2r101 LE 2r111); + ASSERT (2r111 >= 2r101); + ASSERT (16rffff GE 16rff); + + ASSERT (LONG 16rff <= LONG 16rffff); + ASSERT (LONG 2r101 LE LONG 2r111); + ASSERT (LONG 2r111 >= LONG 2r101); + ASSERT (LONG 16rffff GE LONG 16rff); + + ASSERT (LONG LONG 16rff <= LONG LONG 16rffff); + ASSERT (LONG LONG 2r101 LE LONG LONG 2r111); + ASSERT (LONG LONG 2r111 >= LONG LONG 2r101); + ASSERT (LONG LONG 16rffff GE LONG LONG 16rff) +END diff --git a/gcc/testsuite/algol68/execute/le-int-1.a68 b/gcc/testsuite/algol68/execute/le-int-1.a68 new file mode 100644 index 000000000000..7ad17d308a3d --- /dev/null +++ b/gcc/testsuite/algol68/execute/le-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 12; + LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12; + SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12; + ASSERT (i <= 13); + ASSERT (ii LE LONG 13); + ASSERT (iii <= LONG LONG 13); + ASSERT (s <= SHORT 12); + ASSERT (ss <= SHORT SHORT 13) +END diff --git a/gcc/testsuite/algol68/execute/le-string-stride-1.a68 b/gcc/testsuite/algol68/execute/le-string-stride-1.a68 new file mode 100644 index 000000000000..b0fab2af55d8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/le-string-stride-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]CHAR matrix = (("1", "Z", "1"), + ("4", "Y", "4"), + ("7", "X", "9")); + ASSERT (matrix[1:3,1] <= matrix[1:3,3]); + ASSERT (("1","4","9") <= matrix[1:3,3]) +END diff --git a/gcc/testsuite/algol68/execute/leng-shorten-bits-1.a68 b/gcc/testsuite/algol68/execute/leng-shorten-bits-1.a68 new file mode 100644 index 000000000000..58b5d00efa59 --- /dev/null +++ b/gcc/testsuite/algol68/execute/leng-shorten-bits-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# SHORTEN and LENG on SIZETY BITS # +BEGIN ASSERT (LENG 16rff = LONG 16rff); + ASSERT (SHORTEN LONG 16rffff = 16rffff); + ASSERT (LENG LONG 16rffff = LONG LONG 16rffff); + ASSERT (SHORTEN LONG LONG 16rffff = LONG 16rffff) +END diff --git a/gcc/testsuite/algol68/execute/leng-shorten-ints-1.a68 b/gcc/testsuite/algol68/execute/leng-shorten-ints-1.a68 new file mode 100644 index 000000000000..d615f40c2fa2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/leng-shorten-ints-1.a68 @@ -0,0 +1,27 @@ +# { dg-options "-fstropping=upper" } # +# Environment enquiries for SIZETY INTs # +BEGIN # LENG # + (SHORT SHORT INT iii = short short max int; ASSERT (LENG iii = LENG short short max int)); + (SHORT INT ii = short max int; ASSERT (LENG ii = LENG short max int)); + (INT i = max int; ASSERT (LENG i = LENG max int)); + (LONG INT ii = long max int; ASSERT (LENG ii = LENG long max int)); + # SHORTEN # + (SHORT INT i = SHORT 10; SHORT SHORT INT ii = SHORT SHORT 100; ASSERT (ii + SHORTEN i = SHORT SHORT 110)); + IF int shorths > 2 + THEN (SHORT INT ii = LENG short short max int - SHORT 2; + ASSERT (SHORTEN ii = short short max int - SHORT SHORT 2)); + (SHORT INT ii = LENG short short max int + SHORT 1; ASSERT (SHORTEN ii = short short max int)); + (SHORT INT ii = LENG short short min int - SHORT 1; ASSERT (SHORTEN ii = short short min int)) + FI; + (INT i = LENG short max int - 2; ASSERT (SHORTEN i = SHORTEN max int - SHORT 2)); + (INT i = LENG short max int + 1; ASSERT (SHORTEN i = SHORTEN max int)); + (INT i = LENG short min int - 1; ASSERT (SHORTEN i = SHORTEN min int)); + (LONG INT ii = LENG max int - LONG 2; ASSERT (SHORTEN ii = max int - 2)); + (LONG INT ii = LENG max int + LONG 1; ASSERT (SHORTEN ii = max int)); + (LONG INT ii = LENG min int - LONG 1; ASSERT (SHORTEN ii = min int)); + IF int lengths > 2 + THEN (LONG LONG INT ii = LENG long max int - LONG LONG 2; ASSERT (SHORTEN ii = long max int - LONG 2)); + (LONG LONG INT ii = LENG long max int + LONG LONG 1; ASSERT (SHORTEN ii = long max int)); + (LONG LONG INT ii = LENG long min int - LONG LONG 1; ASSERT (SHORTEN ii = long min int)) + FI +END diff --git a/gcc/testsuite/algol68/execute/leng-shorten-reals-1.a68 b/gcc/testsuite/algol68/execute/leng-shorten-reals-1.a68 new file mode 100644 index 000000000000..dd6ed8c590ed --- /dev/null +++ b/gcc/testsuite/algol68/execute/leng-shorten-reals-1.a68 @@ -0,0 +1,17 @@ +# { dg-options "-fstropping=upper" } # +# Environment enquiries for SIZETY REALs # +BEGIN # LENG # + (REAL i = max real; ASSERT (LENG i = LENG max real)); + (LONG REAL ii = long max real; ASSERT (LENG ii = LENG long max real)); + + # SHORTEN # + (LONG REAL ii = LENG max real - LONG 2.0; ASSERT (SHORTEN ii = max real - 2.0)); + (LONG REAL ii = LENG max real + LONG 1.0; ASSERT (SHORTEN ii = max real)); + (LONG REAL ii = LENG min real - LONG 1.0; ASSERT (SHORTEN ii = min real)); + IF (long long max real > LENG long max real) + THEN (LONG LONG REAL ii = LENG long max real - LONG LONG 2.0; + ASSERT (SHORTEN ii = long max real - LONG 2.0)); + (LONG LONG REAL ii = LENG long max real + LONG LONG 1.0; ASSERT (SHORTEN ii = long max real)); + (LONG LONG REAL ii = LENG long min real - LONG LONG 1.0; ASSERT (SHORTEN ii = long min real)) + FI +END diff --git a/gcc/testsuite/algol68/execute/lengths-shorths-1.a68 b/gcc/testsuite/algol68/execute/lengths-shorths-1.a68 new file mode 100644 index 000000000000..f1c892354243 --- /dev/null +++ b/gcc/testsuite/algol68/execute/lengths-shorths-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (int lengths > 0); + ASSERT (int shorths > 0); + ASSERT (bits lengths > 0); + ASSERT (bits shorths > 0); + ASSERT (real lengths > 0); + ASSERT (real shorths > 0) +END diff --git a/gcc/testsuite/algol68/execute/lisp-1.a68 b/gcc/testsuite/algol68/execute/lisp-1.a68 new file mode 100644 index 000000000000..8cec7f6e94e7 --- /dev/null +++ b/gcc/testsuite/algol68/execute/lisp-1.a68 @@ -0,0 +1,25 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT num ints := 0, num chars := 0; + PROC collect stats = (REF CONS tree) VOID: + BEGIN REF CONS e := tree; + WHILE REF CONS (e) ISNT NIL + DO CASE car OF e + IN (CHAR c): num chars +:= 1, + (INT): num ints +:= 1, + (REF CONS s): collect stats (s) + ESAC; + e := cdr OF e + OD + END; + MODE ATOM = UNION (CHAR, INT); + MODE CONS = STRUCT (UNION (ATOM, REF CONS) car, REF CONS cdr); + PROC list = ([]UNION (ATOM, REF CONS) item) REF CONS: + BEGIN REF CONS a := NIL; + FOR i FROM UPB item BY -1 TO 1 + DO a := HEAP CONS := (item[i], a) OD; + a + END; + REF CONS expression := list (("X", "+", list (("Y", "x", 2)))); + collect stats (expression); + ASSERT (num ints = 1 AND num chars = 4) +END diff --git a/gcc/testsuite/algol68/execute/lisp-2.a68 b/gcc/testsuite/algol68/execute/lisp-2.a68 new file mode 100644 index 000000000000..79ae697fd17d --- /dev/null +++ b/gcc/testsuite/algol68/execute/lisp-2.a68 @@ -0,0 +1,21 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT num constants := 0, num vars := 0, num operators := 0; + PROC collect stats = (REF EXPRESSION expr) VOID: + BEGIN CASE left OF expr + IN (INT): num constants +:= 1, + (CHAR): num vars +:= 1, + (REF EXPRESSION s): collect stats (s) + ESAC; + num operators +:= 1; + CASE right OF expr + IN (INT): num constants +:= 1, + (CHAR): num vars +:= 1, + (REF EXPRESSION s): collect stats (s) + ESAC + END; + MODE OPERAND = UNION (CHAR,INT,REF EXPRESSION), + EXPRESSION = STRUCT (OPERAND left, CHAR operator, OPERAND right); + REF EXPRESSION expression := HEAP EXPRESSION := ("X", "+", HEAP EXPRESSION := ("Y", "x", 2)); + collect stats (expression); + ASSERT (num constants = 1 AND num vars = 2 AND num operators = 2) +END diff --git a/gcc/testsuite/algol68/execute/ln-1.a68 b/gcc/testsuite/algol68/execute/ln-1.a68 new file mode 100644 index 000000000000..5c569711bb49 --- /dev/null +++ b/gcc/testsuite/algol68/execute/ln-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r = 1.0; + LONG REAL rr = LONG 2.0; + LONG LONG REAL rrr = LONG LONG 60.0; + ASSERT (ln (r) = 0.0); + long ln (rr); + long long ln (rrr) +END diff --git a/gcc/testsuite/algol68/execute/log-1.a68 b/gcc/testsuite/algol68/execute/log-1.a68 new file mode 100644 index 000000000000..b1a8d8d11caf --- /dev/null +++ b/gcc/testsuite/algol68/execute/log-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r = 1.0; + LONG REAL rr = LONG 2.0; + LONG LONG REAL rrr = LONG LONG 60.0; + ASSERT (log (r) = 0.0); + long log (rr); + long long log (rrr) +END diff --git a/gcc/testsuite/algol68/execute/loop-1.a68 b/gcc/testsuite/algol68/execute/loop-1.a68 new file mode 100644 index 000000000000..91e47c09b57e --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 0; + DO i +:= 1; IF i = 5 THEN exit FI + OD; +exit: ASSERT (i = 5) +END diff --git a/gcc/testsuite/algol68/execute/loop-10.a68 b/gcc/testsuite/algol68/execute/loop-10.a68 new file mode 100644 index 000000000000..53e382356fb7 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-10.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 0, n := 2; + FOR a FROM n BY 2 TO n + 2 DO i +:= a OD; + ASSERT (i = 2 + 4) +END diff --git a/gcc/testsuite/algol68/execute/loop-11.a68 b/gcc/testsuite/algol68/execute/loop-11.a68 new file mode 100644 index 000000000000..eecaade529b4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-11.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Negative steps towards minus infinity. # +BEGIN INT i := 0, n := -5; + BY -1 TO n - 1 DO i -:= 1 OD; + ASSERT (i = -8) +END diff --git a/gcc/testsuite/algol68/execute/loop-12.a68 b/gcc/testsuite/algol68/execute/loop-12.a68 new file mode 100644 index 000000000000..ffd34a5945a1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-12.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 0, n := 5; + FOR a TO n WHILE a < 3 DO i +:= 1 OD; + ASSERT (i = 2) +END diff --git a/gcc/testsuite/algol68/execute/loop-13.a68 b/gcc/testsuite/algol68/execute/loop-13.a68 new file mode 100644 index 000000000000..dbbd9b966c89 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-13.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 0; + FOR a FROM 2 BY 1 WHILE a <= 10 + DO i +:= 1 OD; + ASSERT (i = 9) +END diff --git a/gcc/testsuite/algol68/execute/loop-14.a68 b/gcc/testsuite/algol68/execute/loop-14.a68 new file mode 100644 index 000000000000..bf06f986adc8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-14.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# The while-part shall not be elaborated if the iterator is exhausted. # +BEGIN STRING s = "abc", INT j := 0; + FOR i TO UPB s WHILE s[i] /= "x" + DO j +:= 1 OD; + ASSERT (j = 3) +END diff --git a/gcc/testsuite/algol68/execute/loop-2.a68 b/gcc/testsuite/algol68/execute/loop-2.a68 new file mode 100644 index 000000000000..a92efb398753 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-2.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# While loop. # +BEGIN INT i := 0; + WHILE INT j = 5; i < j + DO i +:= 1 OD; + ASSERT (i = 5) +END diff --git a/gcc/testsuite/algol68/execute/loop-3.a68 b/gcc/testsuite/algol68/execute/loop-3.a68 new file mode 100644 index 000000000000..63b3e203a52c --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-3.a68 @@ -0,0 +1,14 @@ +# { dg-options "-fstropping=upper" } # +# Nested loops. # +BEGIN INT i := 10, res := 0; + WHILE i > 0 + DO INT j := 10; + WHILE j > 0 + DO res +:= 1; + j -:= 1 + OD; + ASSERT (j = 0); + i -:= 1; + OD; + ASSERT (i = 0 AND res = 100) +END diff --git a/gcc/testsuite/algol68/execute/loop-4.a68 b/gcc/testsuite/algol68/execute/loop-4.a68 new file mode 100644 index 000000000000..491e569b2b97 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-4.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +# Nested loops and j on outside range. # +BEGIN INT i := 10, j := 10, res := 0; + WHILE i > 0 + DO j := 10; + WHILE j > 0 + DO res +:= 1; + j -:= 1 + OD; + i -:= 1 + OD; + ASSERT (i = 0 AND j = 0 AND res = 100) +END diff --git a/gcc/testsuite/algol68/execute/loop-5.a68 b/gcc/testsuite/algol68/execute/loop-5.a68 new file mode 100644 index 000000000000..ca0cae644305 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-5.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Skip in loop. # +BEGIN INT i := 0; + WHILE i +:= 1; i < 10 + DO SKIP OD; + ASSERT (i = 10) +END diff --git a/gcc/testsuite/algol68/execute/loop-6.a68 b/gcc/testsuite/algol68/execute/loop-6.a68 new file mode 100644 index 000000000000..216a5643aec3 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-6.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# The range of the while-part shall cover the do-part. # +BEGIN INT i := 0; + WHILE INT incr = 2; i < 10 + DO i +:= incr OD; + ASSERT (i = 10) +END diff --git a/gcc/testsuite/algol68/execute/loop-7.a68 b/gcc/testsuite/algol68/execute/loop-7.a68 new file mode 100644 index 000000000000..3d5112e1b4b5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-7.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 0, n := 5; + TO n + 1 DO i +:= 1 OD; + ASSERT (i = 6) +END diff --git a/gcc/testsuite/algol68/execute/loop-8.a68 b/gcc/testsuite/algol68/execute/loop-8.a68 new file mode 100644 index 000000000000..e7d090160aea --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-8.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 0, n := 2; + FOR a TO n + 1 DO i +:= a OD; + ASSERT (i = 1 + 2 + 3) +END diff --git a/gcc/testsuite/algol68/execute/loop-9.a68 b/gcc/testsuite/algol68/execute/loop-9.a68 new file mode 100644 index 000000000000..a101db250f90 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-9.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 0, n := 2; + FOR a FROM n TO n + 2 DO i +:= a OD; + ASSERT (i = 2 + 3 + 4) +END diff --git a/gcc/testsuite/algol68/execute/loop-overflow-underflow.a68 b/gcc/testsuite/algol68/execute/loop-overflow-underflow.a68 new file mode 100644 index 000000000000..1ace68aff0f4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/loop-overflow-underflow.a68 @@ -0,0 +1,55 @@ +{ Test for overflow/underflow in loops with implicit and explicit + iterators. } + +begin int count; + + { Overflow. } + count := 0; + by 1 while true do count +:= 1 od; + assert (count = max_int); + + count := 0; + from max_int do count +:= 1 od; + assert (count = 1); + count := 0; + + by max_int do count +:= 1 od; + assert (count = 1); + + count := 0; + for i by max_int do count +:= 1 od; + assert (count = 1); + + count := 0; + by max_int % 2 do count +:= 1 od; + assert (count = 3); + + count := 0; + by max_int - 1 do count +:= 1 od; + assert (count = 2); + + { Underflow. } + count := 0; + by -1 while true do count +:= 1 od; + assert (count = -min_int + 2); + + count := 0; + from min_int by -1 do count +:= 1 od; + assert (count = 1); + count := 0; + + by min_int do count +:= 1 od; + assert (count = 2); + + count := 0; + for i by min_int do count +:= 1 od; + assert (count = 2); + + count := 0; + by min_int % 2 do count +:= 1 od; + assert (count = 3); + + count := 0; + by min_int + 1 do count +:= 1 od; + assert (count = 2) +end diff --git a/gcc/testsuite/algol68/execute/lt-int-1.a68 b/gcc/testsuite/algol68/execute/lt-int-1.a68 new file mode 100644 index 000000000000..c0e93028aa3c --- /dev/null +++ b/gcc/testsuite/algol68/execute/lt-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 12; + LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12; + SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12; + ASSERT (i < 13); + ASSERT (ii LT LONG 13); + ASSERT (iii < LONG LONG 13); + ASSERT (s < SHORT 13); + ASSERT (ss < SHORT SHORT 13) +END diff --git a/gcc/testsuite/algol68/execute/lt-string-stride-1.a68 b/gcc/testsuite/algol68/execute/lt-string-stride-1.a68 new file mode 100644 index 000000000000..9109f6751a9d --- /dev/null +++ b/gcc/testsuite/algol68/execute/lt-string-stride-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]CHAR matrix = (("1", "Z", "1"), + ("4", "Y", "4"), + ("7", "X", "9")); + ASSERT (matrix[1:3,1] < matrix[1:3,3]); + ASSERT (("1","4","0") < matrix[1:3,3]) +END diff --git a/gcc/testsuite/algol68/execute/lwb-1.a68 b/gcc/testsuite/algol68/execute/lwb-1.a68 new file mode 100644 index 000000000000..c3dd5940bb12 --- /dev/null +++ b/gcc/testsuite/algol68/execute/lwb-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (LWB "foo" = 1); + ASSERT (LWB "" = 1); + ASSERT (1 LWB "foo" = 1); + ASSERT (1 LWB "" = 1) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/execute.exp b/gcc/testsuite/algol68/execute/mcgt/execute.exp new file mode 100644 index 000000000000..f07333f483aa --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/execute.exp @@ -0,0 +1,29 @@ +# Copyright (C) 2024 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +if $tracelevel then { + strace $tracelevel +} + +load_lib algol68-torture.exp + +foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.a68]] { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $testcase] then { + continue + } + algol68-torture-execute $testcase +} diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3a.a68 new file mode 100644 index 000000000000..c99c25feb888 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3a.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL e = 2.7182818284; REAL circum; + circum := 2 * pi * e +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3c.a68 new file mode 100644 index 000000000000..883d4e918ae4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3c.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := 10, result; + result := n * (n + 1) * (2 * n + 1) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.1a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.1a.a68 new file mode 100644 index 000000000000..4179a8221d47 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.1a.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +# Integer denotations. # +BEGIN 000; 43; 456; 0 +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.2a.a68 new file mode 100644 index 000000000000..3bd34667dde0 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.2a.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Real denotations. # +BEGIN .5; 0.5; 2.0; .001; + 2.3e1; 2e0; 2e+0; 2e-0 +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.3a.a68 new file mode 100644 index 000000000000..a9aa44c31995 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.3a.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +# Character denotations. # +BEGIN "X"; "a"; "1"; "."; " " +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3a.a68 new file mode 100644 index 000000000000..e8f403b119b2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3a.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Identifiers. # +BEGIN INT circum, r, ibm, a1, log2, begin; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3b.a68 new file mode 100644 index 000000000000..be7368f24a9a --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3b.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Identity declarations. # +BEGIN REAL e = 2.7182818284, log2 = 0.618, INT ten = 10, g = 32; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3c.a68 new file mode 100644 index 000000000000..676f9892bd88 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3c.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Equivalent declarations. # +BEGIN REAL x = 2.34; + REF INT n = LOC INT, REF INT m = LOC INT; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3e.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3e.a68 new file mode 100644 index 000000000000..1a0dffe1e4be --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3e.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Initialisation. # +BEGIN CHAR firstchar := "A", lastchar := "Z", currentchar; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2a.a68 new file mode 100644 index 000000000000..f304b8f21b62 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2a.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Ordinary division. # +BEGIN ASSERT (4/2 = 2.0); + INT a = 4, b = 7; + a/b # Yields a value of mode REAL. # +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2b.a68 new file mode 100644 index 000000000000..ed0b0c48676f --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2b.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +# Integer division. The operator OVER (%) performs integer + division with truncation. # +BEGIN ASSERT (4 % 2 = 2); + ASSERT (4 OVER 2 = 2); + ASSERT (5 % 3 = 1); + ASSERT (5 OVER 3 = 1); + INT n = -5, m = -3; + ASSERT (n % 3 = -1); + ASSERT (n % m = 1) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2c.a68 new file mode 100644 index 000000000000..a63eb7eeb5cb --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2c.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +# Integer modulus. The operator MOD (%*) performs integer modulus + with truncation. # +BEGIN ASSERT (0 MOD 4 = 0); + ASSERT (0 %* 4 = 0); + ASSERT (5 %* 3 = 2); + INT m = 5, n = -3; + ASSERT (m MOD n = 2) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.3a.a68 new file mode 100644 index 000000000000..d8707ee83a40 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.3a.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +# Exponentiation. # +BEGIN ASSERT (2 ** 3 = 8) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6a.a68 new file mode 100644 index 000000000000..68f8ee13ea41 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6a.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Comparison operators. # +BEGIN REAL x = 2.7, y = 3.6, z = 4.7; + ASSERT (x < y); + ASSERT ("B" /= "C") +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6b.a68 new file mode 100644 index 000000000000..c61342f3ac0b --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6b.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Comparison operators and boolean operators. # +BEGIN INT a = 4, b = 5, c = 9, REAL x = 4.7, y = 5.7, z = 6.7; + ASSERT (NOT (x + y < z) AND a + b = c) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7d.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7d.a68 new file mode 100644 index 000000000000..aa035f264e37 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7d.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Widening. # +BEGIN REAL x := 4, y := 7, z := 2.7; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7e.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7e.a68 new file mode 100644 index 000000000000..ad423a5a81ec --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7e.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Dereferencing and widening. # +BEGIN INT n, REAL x = n; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8a.a68 new file mode 100644 index 000000000000..23d5e5158d4c --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8a.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Examples of assignations. # +BEGIN REAL pi = 3.14, e = 2.71, INT n = 10, REAL circum, INT result; + circum := 2 * pi * e; + result := n * (n + 1) * ( 2 * n + 1) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8b.a68 new file mode 100644 index 000000000000..1b5d642b8f85 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8b.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Coercions and assignations. # +BEGIN REAL y, INT n, m := 1; + y := n % m +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.9.1a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.9.1a.a68 new file mode 100644 index 000000000000..e5e2e781591e --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.9.1a.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Arithmetical assignment operators. # +BEGIN INT m, n := 4; + n PLUSAB 1; + ASSERT (n = 5) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5.1a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5.1a.a68 new file mode 100644 index 000000000000..85080ea32014 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5.1a.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +# Equivalence. # +BEGIN INT m := 3; REF INT p = m; + ASSERT (m = 3 AND p = 3); + BEGIN INT m := 100; + ASSERT (m = 100 AND p = 3); + m -:= 1; p +:= 1 + END; + ASSERT (m = 4 AND p = 4) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5d.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5d.a68 new file mode 100644 index 000000000000..5f02498ec827 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5d.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +# On the availability and accessibility of space. # +BEGIN INT m := 3, INT five = 5; + ASSERT (m = 3); + BEGIN INT m := 100; CHAR five = "5"; + m +:= 1 + END; + ASSERT (m = 3 AND five = 5) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-3.7.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.7.2a.a68 new file mode 100644 index 000000000000..b6514eb8afe8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.7.2a.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT p := 10, q := 12; + FROM p TO q DO (p +:= 1, q +:= 1) OD; + ASSERT (p = 13 AND q = 15) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-3.8.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.8.2a.a68 new file mode 100644 index 000000000000..bfc67c9dbb69 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.8.2a.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +# Using case clauses. # +BEGIN PROC is divisible = (INT m) BOOL: + BEGIN BOOL divisible := FALSE; + FOR i TO 4 WHILE NOT divisible + DO INT k = (i|3, 5, 7, 11); + divisible := m MOD k = 0 + OD; + divisible + END; + ASSERT (is divisible (50)); + ASSERT (is divisible (253)) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-3.9.1b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.9.1b.a68 new file mode 100644 index 000000000000..01ef062fb5fc --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.9.1b.a68 @@ -0,0 +1,16 @@ +# { dg-options "-fstropping=upper" } # +# Using jumps. # +BEGIN INT a, INT b = 0, c = 2, d = 10, BOOL e = TRUE; + CO The following program using jumps is equivalent to: + FOR a FROM b BY c TO d WHILE e DO SKIP OD + CO + BEGIN INT j := b, INT k = c, m = d; + next: IF (k > 0 AND j <= m) OR (k < 0 AND j >= m) OR k = 0 + THEN INT i = j; + IF e + THEN SKIP; j +:= k; GOTO next + FI + FI; + ASSERT (j = 12) + END +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.2a.a68 new file mode 100644 index 000000000000..98e43c62334a --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.2a.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Monadic lwb and upb. # +BEGIN INT n := 4; [n]INT a; + ASSERT (UPB a = 4); + n := 6; + ASSERT (UPB a = 4) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.3a.a68 new file mode 100644 index 000000000000..b2592404700f --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.3a.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +# Dyadic lwb an upb. # +BEGIN [0:10,-4:100]REAL xx; + ASSERT (1 LWB xx = 0); + ASSERT (1 UPB xx = 10); + ASSERT (1 UPB xx = UPB xx); + ASSERT (2 LWB xx = -4); + ASSERT (2 UPB xx = 100) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6a.a68 new file mode 100644 index 000000000000..e17a9ccc17b4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6a.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [4]REAL x2 := (6, 7, 8, 9); + ASSERT (x2[2] > 6.9); + ASSERT (x2[2] < 7.1); + x2 := (1, 1, 1, 1); + ASSERT(x2[2] > 0.9); + ASSERT(x2[2] < 1.1) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6b.a68 new file mode 100644 index 000000000000..09302dac5f2e --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6b.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Multi-dimensional row displays. # +BEGIN [2,3]INT aa := ((1,2,3),(4,5,6)); + [2,3,4]REAL bb := (((1,2,3,4), (5,6,7,8), (9,10,11,12)), + ((13,14,15,16),(17,18,19,20),(21,22,2,24))); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6c.a68 new file mode 100644 index 000000000000..241e134bf72c --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6c.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Further row displays. # +BEGIN [4]INT a, b; + [4]INT c := a, d := (1,2,3,0); + [2,4]INT ab := (a,b), cd := ((0,0,0,0), b); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6a.a68 new file mode 100644 index 000000000000..ed1fa42771a8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6a.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRUCT (INT day, month, year) indep day = (4, 7, 1776); + ASSERT (day OF indep day = 4); + ASSERT (month OF indep day = 7); + ASSERT (year OF indep day = 1776); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6b.a68 new file mode 100644 index 000000000000..2f1ad2021d4d --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6b.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []STRUCT(CHAR letter, INT integer) roman + = (("I",1),("V",5),("X",10),("L",50),("C",100)); + # XXX letter OF roman should be ("I","V","X","L","C") # + # XXX integer OF roman whould be (1,5,10,50,100) # + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6d.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6d.a68 new file mode 100644 index 000000000000..8718efd7cd53 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6d.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +# Multiple values and structures. + + Having strings of different lenghts would not be valid in a variable + declaration, but is acceptable in an identity declaration. +# +BEGIN []STRUCT ([]CHAR name, INT age) family = + (("JOHN", 3), ("ROBERT", 1), ("CATHERINE", 4)); + SKIP +END + diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1a.a68 new file mode 100644 index 000000000000..0fae194fb227 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1a.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Simple mode declarations. # +BEGIN MODE INTEGER = INT; + MODE Z = INT, R = REAL, B = BOOL, V = VOID; + MODE ARRAYA = [100]INT, ARRAYB = [10,2:9]REAL; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1b.a68 new file mode 100644 index 000000000000..d98d7ec117e5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1b.a68 @@ -0,0 +1,15 @@ +# { dg-options "-fstropping=upper" } # +# Dynamic arrays revisited. # +BEGIN INT p := 2, q := 10; + MODE M = [p:q]INT; + M a; + ASSERT (LWB a = 2 AND UPB a = 10); + q := 4; + M b; + ASSERT (LWB a = 2 AND UPB a = 10); + ASSERT (LWB b = 2 AND UPB b = 4); + M c = (1,2,3,4); # M is interpreted as formal declarer. + Bounds are ignored. + # + ASSERT (LWB c = 1 AND UPB c = 4) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.2a.a68 new file mode 100644 index 000000000000..039a661a62f1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.2a.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Rows of integers. # +BEGIN [][]INT g = ((1,2,3),(4,5),(6,7,8,9)); + ASSERT (UPB g[1] = 3 AND UPB g[2] = 2 AND UPB g[3] = 4) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.2a.a68 new file mode 100644 index 000000000000..9d77795ad8d4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.2a.a68 @@ -0,0 +1,15 @@ +# { dg-options "-fstropping=upper" } # +# Procedure declarations I. # +BEGIN INT x = 10, y = 20, i = 2; + PROC xxx = (INT arg) INT: 10; + PROC yyy = (INT arg) INT: 20; + PROC zzz = (INT arg) INT: 30; + PROC(INT)INT f = IF x > y THEN xxx ELSE zzz FI, + g = CASE i IN xxx, yyy, zzz ESAC; + PROC(INT)INT h := IF x < y THEN xxx ELSE yyy FI; + ASSERT (f (100) = 30); + ASSERT (g (200) = 20); + ASSERT (h (300) = 10); + h := yyy; + ASSERT (h (300) = 20) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3a.a68 new file mode 100644 index 000000000000..45efc9c8834e --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3a.a68 @@ -0,0 +1,12 @@ +# { dg-options "-fstropping=upper" } # +# Using the factorial function in a program # +BEGIN PROC f = (INT n) INT: + BEGIN INT product := 1; + FOR i TO n DO product *:= i OD; + product + END; + ASSERT (f(0) = 1); + ASSERT (f(1) = 1); + ASSERT (f(2) = 2); + ASSERT (f(3) = 6) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3c.a68 new file mode 100644 index 000000000000..fcd93c85c441 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3c.a68 @@ -0,0 +1,29 @@ +# { dg-options "-fstropping=upper" } # +# Procedure declarations III # +BEGIN # From the ALGOL68 Revised Report. # + PROC my char in string = (CHAR c, REF INT i, []CHAR s) BOOL: + BEGIN BOOL found := FALSE; + FOR k FROM LWB s TO UPB s WHILE NOT found + DO (c = s[k] | i := k; found := TRUE) OD; + found + END; + ASSERT ((INT idx := 0; + my char in string ("o", idx, "foo") + ANDTH idx = 2)); + ASSERT (my char in string ("x", LOC INT, "foo") = FALSE); + # Swapping function. # + PROC swap = (REF INT a, b) VOID: + (INT r = a; a := b; b := r); + ASSERT ((INT x := 1, y := 2; + swap (x, y); + x = 2 AND y = 1)); + # Euclid's algorithm. # + PROC hcf = (INT m, n) INT: + BEGIN INT a := m, b := n; + IF a < b THEN swap (a, b) FI; + WHILE b /= 0 + DO INT c = b; b := a MOD b; a := c OD; + a + END; + ASSERT (hcf (10, 20) = 10) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.5a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.5a.a68 new file mode 100644 index 000000000000..4f61bf02a237 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.5a.a68 @@ -0,0 +1,19 @@ +# { dg-options "-fstropping=upper" } # +# Recursive procedures. # +BEGIN PROC f = (INT m, n) INT: + IF n = 0 + THEN m + ELIF m < n + THEN f (n, m) + ELSE m * f (m % n, n - 1) + n * f (m - 1, n) + FI; + f (10, 20); + PROC a = (INT m, n) INT: + IF m = 0 + THEN + 1 + ELIF n = 0 + THEN a (m - 1, 1) + ELSE a (m - 1, a (m, n - 1)) + FI; + a (10, 20) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2a.a68 new file mode 100644 index 000000000000..b2bed32b302a --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2a.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Using AND and OR # +BEGIN ASSERT ((2r111 AND 2r101) = 2r101); + ASSERT ((16rff AND 2r111) = 16r7) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2b.a68 new file mode 100644 index 000000000000..b9a4730b9d05 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2b.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Comparing objects of mode BITS # +BEGIN ASSERT (2r1010 <= 2r1110); + ASSERT (4r331 >= 8r74); + ASSERT (NOT (2r100 >= 2r011)) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2c.a68 new file mode 100644 index 000000000000..79bfc97d9b45 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2c.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Using BIN # +BEGIN ASSERT (BIN 7 = 2r111); + INT i = 22; + ASSERT ((BITS b = BIN i; ABS (b SHL 3) + ABS (b SHL 1)) = 220) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1a.a68 new file mode 100644 index 000000000000..efd948be8075 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1a.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# Declarations of flexible names. # +BEGIN FLEX[1:0]INT n; + ASSERT (LWB n = 1 AND UPB n = 0 AND ELEMS n = 0); + FLEX[4,6]INT p; + ASSERT (1 LWB p = 1 AND 1 UPB p = 4 AND 1 ELEMS p = 4 + AND 2 LWB p = 1 AND 2 UPB p = 6 AND 2 ELEMS p = 6) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1b.a68 new file mode 100644 index 000000000000..3360c5eabc23 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1b.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +# Null row displays an string denotations. # +BEGIN FLEX[4]INT a, FLEX[4,6]INT b, FLEX[10]CHAR c; + a := (); + ASSERT (LWB a = 1 AND UPB a = 0); + b := ((),()); + ASSERT (1 LWB b = 1 AND 1 UPB b = 2 + AND 2 LWB b = 1 AND 2 UPB b = 0); + c := (); + c := "" +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.3a.a68 new file mode 100644 index 000000000000..b1bfdf737caf --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.3a.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# Transient references and declarations. # +BEGIN FLEX[4,6]INT p; + []INT q1 = p[3,]; # Transient name is dereferenced giving []INT # + REF FLEX[,]INT q5 = p; # p and q5 are different ways of accessing + the same name. # + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.2a.a68 new file mode 100644 index 000000000000..688bcac00ec6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.2a.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +# Virtual declarers. # +BEGIN REF[]INT s; + STRUCT ([10]INT a, [4]REF[]INT b) c; + UNION (REF FLEX[]INT, PROC(INT)INT) f; + FLEX[4][3]INT a; + REF FLEX[][]INT aa = LOC FLEX[4][3]INT; + [4]FLEX[3]INT b; + REF[]FLEX[]INT bb = LOC[4]FLEX[3]INT; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6a.a68 new file mode 100644 index 000000000000..1fbf6a3772e5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6a.a68 @@ -0,0 +1,23 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := 3, m := 3; + REF INT w := n, z := n, REF INT y = n; + # Delivers TRUE since y and n deliver the same variable of mode REF + INT. No coercions take place. + # + ASSERT (y :=: n); + # Delivers TRUE. here w is dereferenced to yield n. The right + hand side is taken to be strong since dereferencing cannot + occur in a soft position. + # + ASSERT (n :=: w); + # Similarly delivers TRUE. Strong position is lhs. # + ASSERT (w :=: n); + # Delivers TRUE. No coercions take place. # + ASSERT (y ISNT m); + # Delivers true. w gets coerced to REF INT due to the strong + context introduced by the cast. No further coercions take place. + # + ASSERT (REF INT (w) :=: z); + # Delives true. No coercions take place. # + ASSERT (w :/=: z) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6b.a68 new file mode 100644 index 000000000000..479339d74855 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6b.a68 @@ -0,0 +1,12 @@ +# { dg-options "-fstropping=upper" } # +BEGIN + [3]INT a := (1,2,3); + + CO Comparing transient or flex names using an identity relation is + undefined. Therefore, a[2:3] :=: a[2:3] is undefined. + CO + + # But the following are defined. # + ASSERT (a[1] :=: a[1]); + ASSERT (a[1] :/=: a[2]) +END diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.5.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.5.3a.a68 new file mode 100644 index 000000000000..dfb8cd40460b --- /dev/null +++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.5.3a.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# Declarations involving global generators. # +BEGIN REF REAL xx; + BEGIN REF REAL x = HEAP REAL := 4; + xx := x + END; + ASSERT (xx = 4) +END diff --git a/gcc/testsuite/algol68/execute/minus-int-1.a68 b/gcc/testsuite/algol68/execute/minus-int-1.a68 new file mode 100644 index 000000000000..abaf1229ebe8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/minus-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 10; + LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10; + SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10; + ASSERT (i - 2 = 8); + ASSERT (ii - LONG 2 = LONG 8); + ASSERT (iii - LONG LONG 2 = LONG LONG 8); + ASSERT (ss - SHORT 2 = SHORT 8); + ASSERT (sss - SHORT SHORT 2 = SHORT SHORT 8) +END diff --git a/gcc/testsuite/algol68/execute/minusab-1.a68 b/gcc/testsuite/algol68/execute/minusab-1.a68 new file mode 100644 index 000000000000..0eb1661cb985 --- /dev/null +++ b/gcc/testsuite/algol68/execute/minusab-1.a68 @@ -0,0 +1,32 @@ +# { dg-options "-fstropping=upper" } # +BEGIN BEGIN INT i := 10; + i -:= 2; + ASSERT (i = 8); + i MINUSAB 2; + ASSERT (i = 6) + END; + BEGIN LONG INT i := LONG 1000; + i -:= LONG 100; + ASSERT (i = LONG 900); + i MINUSAB LONG 100; + ASSERT (i = LONG 800) + END; + BEGIN LONG LONG INT i := LONG LONG 10000; + i -:= LONG LONG 1000; + ASSERT (i = LONG LONG 9000); + i MINUSAB LONG LONG 1000; + ASSERT (i = LONG LONG 8000) + END; + BEGIN SHORT INT i := SHORT 100; + i -:= SHORT 10; + ASSERT (i = SHORT 90); + i MINUSAB SHORT 10; + ASSERT (i = SHORT 80) + END; + BEGIN SHORT SHORT INT i := SHORT SHORT 10; + i -:= SHORT SHORT 1; + ASSERT (i = SHORT SHORT 9); + i MINUSAB SHORT SHORT 2; + ASSERT (i = SHORT SHORT 7) + END +END diff --git a/gcc/testsuite/algol68/execute/minusab-2.a68 b/gcc/testsuite/algol68/execute/minusab-2.a68 new file mode 100644 index 000000000000..2fee755bf6e2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/minusab-2.a68 @@ -0,0 +1,20 @@ +# { dg-options "-fstropping=upper" } # +BEGIN BEGIN REAL i := 10.0; + i -:= 2.0; + ASSERT (i = 8.0); + i MINUSAB 2.0; + ASSERT (i = 6.0) + END; + BEGIN LONG REAL i := LONG 1000.0; + i -:= LONG 100.0; + ASSERT (i = LONG 900.0); + i MINUSAB LONG 100.0; + ASSERT (i = LONG 800.0) + END; + BEGIN LONG LONG REAL i := LONG LONG 10000.0; + i -:= LONG LONG 1000.0; + ASSERT (i = LONG LONG 9000.0); + i MINUSAB LONG LONG 1000.0; + ASSERT (i = LONG LONG 8000.0) + END +END diff --git a/gcc/testsuite/algol68/execute/minusab-3.a68 b/gcc/testsuite/algol68/execute/minusab-3.a68 new file mode 100644 index 000000000000..08d020d3f201 --- /dev/null +++ b/gcc/testsuite/algol68/execute/minusab-3.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := 10; + (((n -:= 1))) := 5; + ASSERT (n = 5) +END diff --git a/gcc/testsuite/algol68/execute/minusab-4.a68 b/gcc/testsuite/algol68/execute/minusab-4.a68 new file mode 100644 index 000000000000..4330908f58f8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/minusab-4.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT num ints := 10; + num ints -:= 1; + ASSERT (num ints = 9); + ASSERT ((LOC INT -:= 12) = -12) +END diff --git a/gcc/testsuite/algol68/execute/mod-int-1.a68 b/gcc/testsuite/algol68/execute/mod-int-1.a68 new file mode 100644 index 000000000000..0d8cfe415e4b --- /dev/null +++ b/gcc/testsuite/algol68/execute/mod-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 10; + LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10; + SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10; + ASSERT (i %* 3 = 1); + ASSERT (ii %* LONG 3 = LONG 1); + ASSERT (iii %* LONG LONG 3 = LONG LONG 1); + ASSERT (ss %* SHORT 3 = SHORT 1); + ASSERT (sss MOD SHORT SHORT 3 = SHORT SHORT 1) +END diff --git a/gcc/testsuite/algol68/execute/modab-1.a68 b/gcc/testsuite/algol68/execute/modab-1.a68 new file mode 100644 index 000000000000..41c49b089929 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modab-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN (SHORT SHORT INT i := SHORT SHORT 11; i MODAB SHORT SHORT 2; ASSERT (i = SHORT SHORT 1)); + (SHORT INT i := SHORT 11; i MODAB SHORT 2; ASSERT (i = SHORT 1)); + (INT i := 11; i MODAB 2; ASSERT (i = 1)); + (INT i := 11; i %*:= 2; ASSERT (i = 1)); + (LONG INT i := LONG 11; i MODAB LONG 2; ASSERT (i = LONG 1)); + (LONG INT i := LONG 11; i %*:= LONG 2; ASSERT (i = LONG 1)); + (LONG LONG INT i := LONG LONG 11; i MODAB LONG LONG 2; ASSERT (i = LONG LONG 1)); + (LONG LONG INT i := LONG LONG 11; i %*:= LONG LONG 2; ASSERT (i = LONG LONG 1)) +END diff --git a/gcc/testsuite/algol68/execute/modab-2.a68 b/gcc/testsuite/algol68/execute/modab-2.a68 new file mode 100644 index 000000000000..52fc9a12a546 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modab-2.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := 10; + (((n MODAB 1))) := 5; + ASSERT (n = 5) +END diff --git a/gcc/testsuite/algol68/execute/mode-indication-1.a68 b/gcc/testsuite/algol68/execute/mode-indication-1.a68 new file mode 100644 index 000000000000..f1dd8c28c92f --- /dev/null +++ b/gcc/testsuite/algol68/execute/mode-indication-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT j; REAL y; + MODE R = REAL; + BEGIN MODE R = INT; + R i := j; + SKIP + END; + R x := y; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/modules/README b/gcc/testsuite/algol68/execute/modules/README new file mode 100644 index 000000000000..a22c97c9ad6f --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/README @@ -0,0 +1,7 @@ +This directory contains tests that require using several packets. + +Files named module*.a68 contain prelude packets, i.e. the definitions +of one or more modules. These are to be referred within test programs +using dg-modules. + +Each program*.a68 file is a testcase. diff --git a/gcc/testsuite/algol68/execute/modules/execute.exp b/gcc/testsuite/algol68/execute/modules/execute.exp new file mode 100644 index 000000000000..cf61857aac11 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/execute.exp @@ -0,0 +1,42 @@ +# Copyright (C) 2024 Free Software Foundation, Inc. + +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# Execute tests, torture testing. + +if $tracelevel then { + strace $tracelevel +} + +load_lib algol68-torture.exp +load_lib torture-options.exp + +torture-init +set-torture-options $TORTURE_OPTIONS + +# The programs need to be able to find the built modules, which are +# left in objdir. +global BUILT_MODULES_DIR +set BUILT_MODULES_DIR "$objdir" + +foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/program-*.a68]] { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $testcase] then { + continue + } + algol68-torture-execute $testcase + set algol68_compile_args "" +} + +torture-finish diff --git a/gcc/testsuite/algol68/execute/modules/module1.a68 b/gcc/testsuite/algol68/execute/modules/module1.a68 new file mode 100644 index 000000000000..f49a747033e0 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module1.a68 @@ -0,0 +1,9 @@ +module Module1 = +def + pub mode MyInt = int; + pub int beast_number := 666; + pub string who = "jemarch"; + puts ("Hello from module'n") +postlude + puts ("Bye from module'n") +fed diff --git a/gcc/testsuite/algol68/execute/modules/module10.a68 b/gcc/testsuite/algol68/execute/modules/module10.a68 new file mode 100644 index 000000000000..5b163ffe1f95 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module10.a68 @@ -0,0 +1,7 @@ +module Module10 = +access Module9, Module3 +def int je = foo; + prio QUUX = 9; + pub Lala bar = (bump; getcounter); {11} + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module11.a68 b/gcc/testsuite/algol68/execute/modules/module11.a68 new file mode 100644 index 000000000000..39adb826019c --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module11.a68 @@ -0,0 +1,11 @@ +{ Mixing module texts with revelations and without revelations. } + +module Module11 = + access Module1, Module3 + def pub proc someproc = (int a, b) int: a + b; + skip + postlude + skip + fed, + Foo = def skip postlude skip fed, + Bar = def skip fed diff --git a/gcc/testsuite/algol68/execute/modules/module12.a68 b/gcc/testsuite/algol68/execute/modules/module12.a68 new file mode 100644 index 000000000000..3f849cbb9e65 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module12.a68 @@ -0,0 +1,5 @@ +module Module_12 = +def pub proc foo = (proc(int,string)void cb, int a) void: cb (a, "Foo"); + pub proc bar = (real r) void: skip; + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module13.a68 b/gcc/testsuite/algol68/execute/modules/module13.a68 new file mode 100644 index 000000000000..9d66fe150651 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module13.a68 @@ -0,0 +1,5 @@ +module Module_13 = +def + pub mode JSON_Val = struct (int i); + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module14.a68 b/gcc/testsuite/algol68/execute/modules/module14.a68 new file mode 100644 index 000000000000..bcb9d2cacd6d --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module14.a68 @@ -0,0 +1,5 @@ +module Module14 = +access Module13 +def pub proc getval = JSON_Val: skip; + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module15.a68 b/gcc/testsuite/algol68/execute/modules/module15.a68 new file mode 100644 index 000000000000..5e4208433ec2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module15.a68 @@ -0,0 +1,8 @@ +module Module15 = +access Module13, Module14 +def pub proc foo = int: + begin JSON_Val val = getval; + i of val + end; + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module16.a68 b/gcc/testsuite/algol68/execute/modules/module16.a68 new file mode 100644 index 000000000000..d798d4ff874c --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module16.a68 @@ -0,0 +1,8 @@ +module Module_16 = +def + pub int counter; + skip +postlude + assert (counter = 666); + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module17.a68 b/gcc/testsuite/algol68/execute/modules/module17.a68 new file mode 100644 index 000000000000..232ddeb5b91e --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module17.a68 @@ -0,0 +1,13 @@ +module Module = +def + pub int ce_port; + pub string ce_host; + + pub proc ce_connect = void: + myconnect (ce_host, ce_port); + + proc myconnect = (string host, int port) void: + skip; + + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module3.a68 b/gcc/testsuite/algol68/execute/modules/module3.a68 new file mode 100644 index 000000000000..d4d2066f2b23 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module3.a68 @@ -0,0 +1,11 @@ +module Module_3 = +def + { variable = 0 in_proc = 1 } pub proc bump = void: counter +:= 1; + { variable = 0 in_proc = 1 } pub proc bumptimes = (int n) void: to n do bump od; + { variable = 1 in_proc = 0 } pub proc vbump := void: counter +:= 1; + { variable = 1 in_proc = 0 } pub proc vbumptimes := (int n) void: to n do vbump od; + { variable = 0 in_proc = 1 } pub proc getcounter = int: counter; + { variable = 0 in_proc = 0 } pub proc int anothergetcounter = getcounter; + int counter := 10; + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module4.a68 b/gcc/testsuite/algol68/execute/modules/module4.a68 new file mode 100644 index 000000000000..f4ff315acf6b --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module4.a68 @@ -0,0 +1,4 @@ +module Module_4 = +def pub int ten = 10; + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module5.a68 b/gcc/testsuite/algol68/execute/modules/module5.a68 new file mode 100644 index 000000000000..d0b009aa7954 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module5.a68 @@ -0,0 +1,7 @@ +module Module_5 = +def pub prio // = 9; + pub op // = (int a, b) int: a + b; + pub prio LALA = 9; + pub op LALA = (int a, b) int: a - b; + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module6.a68 b/gcc/testsuite/algol68/execute/modules/module6.a68 new file mode 100644 index 000000000000..f89d7ac21a77 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module6.a68 @@ -0,0 +1,5 @@ +module Module_6 = +def prio // = 9; { Note priority is not publicized. } + pub op // = (int a, b) int: a + b; + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module7.a68 b/gcc/testsuite/algol68/execute/modules/module7.a68 new file mode 100644 index 000000000000..c9c2e078addf --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module7.a68 @@ -0,0 +1,10 @@ +{ This module exports an operator defined in a non-brief operator + declaration. This means the exported symbol is a pointer to a + function and shall be indirected on the accessing side. } + +module Module_7 = +def pub prio MINUS = 9; + pub op (int,int)int MINUS = minus; + proc minus = (int a, b) int: a - b; + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module8.a68 b/gcc/testsuite/algol68/execute/modules/module8.a68 new file mode 100644 index 000000000000..693629908b10 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module8.a68 @@ -0,0 +1,9 @@ +module Module_8 = +access Module_1, Module_4 +def + pub proc checks = void: + begin assert (ten = 10); + assert (beast_number = 666) + end; + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/module9.a68 b/gcc/testsuite/algol68/execute/modules/module9.a68 new file mode 100644 index 000000000000..ed59bb8bfb04 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/module9.a68 @@ -0,0 +1,8 @@ +module Module9 = +def pub int foo = 10; + pub prio // = 9; + pub op QUUX = (int a, b) int: a + b; + prio QUUX = 9; + pub mode Lala = int; + skip +fed diff --git a/gcc/testsuite/algol68/execute/modules/program-1.a68 b/gcc/testsuite/algol68/execute/modules/program-1.a68 new file mode 100644 index 000000000000..b385c5698a4e --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-1.a68 @@ -0,0 +1,20 @@ +{ dg-modules "module1" } + +begin string je = access Module1 begin who end; + string ju = access Module1 ( who ); + string ji = access Module1 if true then who else who fi; + string ja = access Module1 (true | who | who); + string aa = access Module1 case 1 in who, "no" esac; + mode United = union (void,int); + string bb = access Module1 case United (10) in (int): who esac; + string cc = access Module1 (1 | who, "no"); + assert (je = "jemarch"); + assert (ju = "jemarch"); + assert (ji = "jemarch"); + assert (ja = "jemarch"); + assert (aa = "jemarch"); + assert (bb = "jemarch"); + assert (cc = "jemarch"); + access Module1 to 1 do assert (who = "jemarch") od; + access Module1 (assert (beast_number = 666)) +end diff --git a/gcc/testsuite/algol68/execute/modules/program-10.a68 b/gcc/testsuite/algol68/execute/modules/program-10.a68 new file mode 100644 index 000000000000..101d065b19e7 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-10.a68 @@ -0,0 +1,6 @@ +{ dg-modules "module3 module9 module10" } + +access Module10 +begin int x = 11; + assert (x = bar) +end diff --git a/gcc/testsuite/algol68/execute/modules/program-11.a68 b/gcc/testsuite/algol68/execute/modules/program-11.a68 new file mode 100644 index 000000000000..ba2e1fe01004 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-11.a68 @@ -0,0 +1,3 @@ +{ dg-modules "module1 module3 module11" } + +access Module11 ( assert (someproc (2, 3) = 5)) diff --git a/gcc/testsuite/algol68/execute/modules/program-12.a68 b/gcc/testsuite/algol68/execute/modules/program-12.a68 new file mode 100644 index 000000000000..a8a6a4c03980 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-12.a68 @@ -0,0 +1,6 @@ +{ dg-modules "module12" } + +access Module_12 +begin proc lala = (int n, string s) void: skip; + foo (lala, 10) +end diff --git a/gcc/testsuite/algol68/execute/modules/program-15.a68 b/gcc/testsuite/algol68/execute/modules/program-15.a68 new file mode 100644 index 000000000000..7b6abafdbaae --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-15.a68 @@ -0,0 +1,3 @@ +{ dg-modules "module13 module14 module15" } + +access Module15 (assert (foo = 0)) diff --git a/gcc/testsuite/algol68/execute/modules/program-16.a68 b/gcc/testsuite/algol68/execute/modules/program-16.a68 new file mode 100644 index 000000000000..dd6ddb6b9413 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-16.a68 @@ -0,0 +1,8 @@ +{ dg-modules module16 } + +access Module_16 +begin assert (counter = 0); + counter := 20; + access Module_16 (assert (counter = 20)); + counter := 666 +end diff --git a/gcc/testsuite/algol68/execute/modules/program-17.a68 b/gcc/testsuite/algol68/execute/modules/program-17.a68 new file mode 100644 index 000000000000..90a1728c68b1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-17.a68 @@ -0,0 +1,7 @@ +{ dg-modules module17 } + +access Module17 +begin ce_port := 8888; + ce_host := "localhost"; + ce_connect +end diff --git a/gcc/testsuite/algol68/execute/modules/program-2.a68 b/gcc/testsuite/algol68/execute/modules/program-2.a68 new file mode 100644 index 000000000000..e0f320c2a9f0 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-2.a68 @@ -0,0 +1,15 @@ +{ dg-modules "module1" } + +begin int x = 1 + access Module1 ( beast_number); + int i = access Module1 ( beast_number ) + 1; + int z = 1 + access Module1 if true then beast_number fi; + int v = access Module1 if true then beast_number fi + 1; + int w = access Module1 if true then beast_number fi + + access Module1 if true then beast_number fi; + assert (i = 667); + assert (x = 667); + assert (z = 667); + assert (v = 667); + assert (w = 666 * 2); + skip +end diff --git a/gcc/testsuite/algol68/execute/modules/program-3.a68 b/gcc/testsuite/algol68/execute/modules/program-3.a68 new file mode 100644 index 000000000000..b1570bd9aed9 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-3.a68 @@ -0,0 +1,16 @@ +{ dg-modules "module3" } + +access Module_3 +begin assert (getcounter = 10); + bump; + assert (getcounter = 11); + bumptimes (3); + assert (getcounter = 14) + { vbump and vbumptimes are set to non-publicized routines + that are local to the module, so it is a scope violation + to call them. } +{ vbump; + assert (getcounter = 15); + vbumptimes (10); + assert (anothergetcounter = 25) } +end diff --git a/gcc/testsuite/algol68/execute/modules/program-4.a68 b/gcc/testsuite/algol68/execute/modules/program-4.a68 new file mode 100644 index 000000000000..f207d9c4b6ac --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-4.a68 @@ -0,0 +1,7 @@ +{ dg-modules "module4" } + +{ The widening coercion "jumps" inside the controlled xclause. } + +begin real realten = access Module_4 (ten); + skip +end diff --git a/gcc/testsuite/algol68/execute/modules/program-5.a68 b/gcc/testsuite/algol68/execute/modules/program-5.a68 new file mode 100644 index 000000000000..afa49f5c1230 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-5.a68 @@ -0,0 +1,7 @@ +{ dg-modules "module5" } + +access Module_5 +begin assert (2 // 3 = 5); + assert (2 LALA 3 = -1); + skip +end diff --git a/gcc/testsuite/algol68/execute/modules/program-6.a68 b/gcc/testsuite/algol68/execute/modules/program-6.a68 new file mode 100644 index 000000000000..05708fada46d --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-6.a68 @@ -0,0 +1,9 @@ +{ dg-modules "module6" } + +{ New priority is given to an importe operator. } + +access Module_6 +begin assert (2 // 3 = 5); + prio // = 9; + skip +end diff --git a/gcc/testsuite/algol68/execute/modules/program-7.a68 b/gcc/testsuite/algol68/execute/modules/program-7.a68 new file mode 100644 index 000000000000..6a5aa494c1db --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-7.a68 @@ -0,0 +1,3 @@ +{ dg-modules "module7" } + +access Module_7 ( assert (2 MINUS 3 = -1) ) diff --git a/gcc/testsuite/algol68/execute/modules/program-8.a68 b/gcc/testsuite/algol68/execute/modules/program-8.a68 new file mode 100644 index 000000000000..4a50e7153e83 --- /dev/null +++ b/gcc/testsuite/algol68/execute/modules/program-8.a68 @@ -0,0 +1,3 @@ +{ dg-modules "module1 module4 module8" } + +access Module_8 (checks) diff --git a/gcc/testsuite/algol68/execute/mult-char-1.a68 b/gcc/testsuite/algol68/execute/mult-char-1.a68 new file mode 100644 index 000000000000..0e3c1f4b93f0 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mult-char-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT ("a" * 3 = "aaa"); + ASSERT ("" * 1 = ""); + ASSERT ("x" * 0 = "x") +END diff --git a/gcc/testsuite/algol68/execute/mult-int-1.a68 b/gcc/testsuite/algol68/execute/mult-int-1.a68 new file mode 100644 index 000000000000..2da298837793 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mult-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 10; + LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10; + SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10; + ASSERT (i * 2 = 20); + ASSERT (ii * LONG 2 = LONG 20); + ASSERT (iii * LONG LONG 2 = LONG LONG 20); + ASSERT (ss * SHORT 2 = SHORT 20); + ASSERT (sss * SHORT SHORT 2 = SHORT SHORT 20) +END diff --git a/gcc/testsuite/algol68/execute/mult-string-1.a68 b/gcc/testsuite/algol68/execute/mult-string-1.a68 new file mode 100644 index 000000000000..b0d49178bd1e --- /dev/null +++ b/gcc/testsuite/algol68/execute/mult-string-1.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING foo = "foo"; + ASSERT (foo * -10 = "foo"); + ASSERT (-10 * foo = "foo"); + ASSERT (foo * 0 = "foo"); + ASSERT (0 * foo = "foo"); + ASSERT (foo * 1 = "foo"); + ASSERT (1 * foo = "foo"); + ASSERT (foo * 2 = "foofoo"); + ASSERT (2 * foo = "foofoo"); + ASSERT (foo * 3 = "foofoofoo"); + ASSERT (3 * foo = "foofoofoo") +END diff --git a/gcc/testsuite/algol68/execute/mult-string-2.a68 b/gcc/testsuite/algol68/execute/mult-string-2.a68 new file mode 100644 index 000000000000..670dcbf16d60 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mult-string-2.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []CHAR foo = ("f","o","o"); + ASSERT (foo * -10 = "foo"); + ASSERT (-10 * foo = "foo"); + ASSERT (foo * 0 = "foo"); + ASSERT (0 * foo = "foo"); + ASSERT (foo * 1 = "foo"); + ASSERT (1 * foo = "foo"); + ASSERT (foo * 2 = "foofoo"); + ASSERT (2 * foo = "foofoo"); + ASSERT (foo * 3 = "foofoofoo"); + ASSERT (3 * foo = "foofoofoo") +END diff --git a/gcc/testsuite/algol68/execute/mult-string-3.a68 b/gcc/testsuite/algol68/execute/mult-string-3.a68 new file mode 100644 index 000000000000..a8d3726d0dfa --- /dev/null +++ b/gcc/testsuite/algol68/execute/mult-string-3.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +BEGIN FLEX[3]CHAR foo := ("f","o","o"); + ASSERT (foo * -10 = "foo"); + ASSERT (-10 * foo = "foo"); + ASSERT (foo * 0 = "foo"); + ASSERT (0 * foo = "foo"); + ASSERT (foo * 1 = "foo"); + ASSERT (1 * foo = "foo"); + ASSERT (foo * 2 = "foofoo"); + ASSERT (2 * foo = "foofoo"); + ASSERT (foo * 3 = "foofoofoo"); + ASSERT (3 * foo = "foofoofoo") +END diff --git a/gcc/testsuite/algol68/execute/mult-string-4.a68 b/gcc/testsuite/algol68/execute/mult-string-4.a68 new file mode 100644 index 000000000000..d5e1adb66a3b --- /dev/null +++ b/gcc/testsuite/algol68/execute/mult-string-4.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING foo = "abc"; + ASSERT (foo[] * 2 = "abcabc") +END diff --git a/gcc/testsuite/algol68/execute/multab-1.a68 b/gcc/testsuite/algol68/execute/multab-1.a68 new file mode 100644 index 000000000000..355129baf658 --- /dev/null +++ b/gcc/testsuite/algol68/execute/multab-1.a68 @@ -0,0 +1,31 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 2; + i *:= 2; + ASSERT (i = 4); + i *:= 2; + ASSERT (i = 8); + + SHORT INT s := SHORT 2; + s *:= SHORT 2; + ASSERT (s = SHORT 4); + s *:= SHORT 3; + ASSERT (s = SHORT 12); + + SHORT SHORT INT ss := SHORT SHORT 2; + ss *:= SHORT SHORT 2; + ASSERT (ss = SHORT SHORT 4); + ss *:= SHORT SHORT 3; + ASSERT (ss = SHORT SHORT 12); + + REF LONG INT ii = HEAP LONG INT := LONG 2; + ii *:= LONG 2; + ASSERT (ii = LONG 4); + ii *:= LONG 2; + ASSERT (ii = LONG 8); + + LONG LONG INT iii := LONG LONG 2; + iii *:= LONG LONG 2; + ASSERT (iii = LONG LONG 4); + iii *:= LONG LONG 2; + ASSERT (iii = LONG LONG 8) +END diff --git a/gcc/testsuite/algol68/execute/multab-2.a68 b/gcc/testsuite/algol68/execute/multab-2.a68 new file mode 100644 index 000000000000..dc1485991cd1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/multab-2.a68 @@ -0,0 +1,31 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 2; + i TIMESAB 2; + ASSERT (i = 4); + i TIMESAB 2; + ASSERT (i = 8); + + REF SHORT INT ss = HEAP SHORT INT := SHORT 2; + ss TIMESAB SHORT 2; + ASSERT (ss = SHORT 4); + ss TIMESAB SHORT 2; + ASSERT (ss = SHORT 8); + + SHORT SHORT INT sss := SHORT SHORT 2; + sss TIMESAB SHORT SHORT 2; + ASSERT (sss = SHORT SHORT 4); + sss TIMESAB SHORT SHORT 2; + ASSERT (sss = SHORT SHORT 8); + + REF LONG INT ii = HEAP LONG INT := LONG 2; + ii TIMESAB LONG 2; + ASSERT (ii = LONG 4); + ii TIMESAB LONG 2; + ASSERT (ii = LONG 8); + + LONG LONG INT iii := LONG LONG 2; + iii TIMESAB LONG LONG 2; + ASSERT (iii = LONG LONG 4); + iii TIMESAB LONG LONG 2; + ASSERT (iii = LONG LONG 8) +END diff --git a/gcc/testsuite/algol68/execute/multab-3.a68 b/gcc/testsuite/algol68/execute/multab-3.a68 new file mode 100644 index 000000000000..87d7f42b80b1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/multab-3.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT num ints := 10; + num ints *:= 2; + ASSERT (num ints = 20); + ASSERT ((LOC INT *:= 12) = 0) +END diff --git a/gcc/testsuite/algol68/execute/mutual-recursion-1.a68 b/gcc/testsuite/algol68/execute/mutual-recursion-1.a68 new file mode 100644 index 000000000000..06e01f947ff3 --- /dev/null +++ b/gcc/testsuite/algol68/execute/mutual-recursion-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC is even = (INT n) BOOL: (n = 0 | TRUE | is odd (n - 1)); + PROC is odd = (INT n) BOOL: (n = 0 | FALSE | is even (n - 1)); + ASSERT (is even (20)); + ASSERT (is odd (13)) +END diff --git a/gcc/testsuite/algol68/execute/ne-bits-1.a68 b/gcc/testsuite/algol68/execute/ne-bits-1.a68 new file mode 100644 index 000000000000..49ef81061ae1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/ne-bits-1.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN BITS b, LONG BITS bb = LONG 16rff, LONG LONG BITS bbb; + SHORT BITS ss = SHORT 16rff, SHORT SHORT BITS sss; + ASSERT (b /= 2r1); + ASSERT (bb NE LONG 8r477); + ASSERT (bbb /= LONG LONG 8r2); + ASSERT (ss NE SHORT 8r477); + ASSERT (sss /= SHORT SHORT 8r2) +END diff --git a/gcc/testsuite/algol68/execute/ne-char-char-1.a68 b/gcc/testsuite/algol68/execute/ne-char-char-1.a68 new file mode 100644 index 000000000000..2a5b44fe83ca --- /dev/null +++ b/gcc/testsuite/algol68/execute/ne-char-char-1.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT ("x" /= "a") +END diff --git a/gcc/testsuite/algol68/execute/ne-int-1.a68 b/gcc/testsuite/algol68/execute/ne-int-1.a68 new file mode 100644 index 000000000000..2c26bd563c59 --- /dev/null +++ b/gcc/testsuite/algol68/execute/ne-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 12; + LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12; + SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12; + ASSERT (13 /= i); + ASSERT (ii NE LONG 13); + ASSERT (iii /= LONG LONG 13); + ASSERT (s /= SHORT 13); + ASSERT (ss /= SHORT SHORT 13) +END diff --git a/gcc/testsuite/algol68/execute/ne-string-1.a68 b/gcc/testsuite/algol68/execute/ne-string-1.a68 new file mode 100644 index 000000000000..95bd212dce30 --- /dev/null +++ b/gcc/testsuite/algol68/execute/ne-string-1.a68 @@ -0,0 +1,15 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING foo = "foo", bar = "bar", quux = "quux"; + # /= # + ASSERT (NOT ("" /= "")); + ASSERT (NOT ("foo" /= foo)); + ASSERT (foo /= bar); + ASSERT (foo /= quux); + ASSERT (quux /= foo); + # NE # + ASSERT (NOT ("" NE "")); + ASSERT (NOT ("foo" NE foo)); + ASSERT (foo NE bar); + ASSERT (foo NE quux); + ASSERT (quux NE foo) +END diff --git a/gcc/testsuite/algol68/execute/neg-int-1.a68 b/gcc/testsuite/algol68/execute/neg-int-1.a68 new file mode 100644 index 000000000000..0e66149ef286 --- /dev/null +++ b/gcc/testsuite/algol68/execute/neg-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 10; + LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10; + SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10; + ASSERT (-i = -10); + ASSERT (-ii = - LONG 10); + ASSERT (-iii = - LONG LONG 10); + ASSERT (-ss = - SHORT 10); + ASSERT (-sss = - SHORT SHORT 10) +END diff --git a/gcc/testsuite/algol68/execute/not-bits-1.a68 b/gcc/testsuite/algol68/execute/not-bits-1.a68 new file mode 100644 index 000000000000..8334f7f7a7f7 --- /dev/null +++ b/gcc/testsuite/algol68/execute/not-bits-1.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +# NOT for SIZETY BITS. # +BEGIN BITS b = 16rf0f0; + ASSERT ((NOT b AND 16rffff) = 16r0f0f); + LONG BITS bb = LONG 16rf0f0; + ASSERT ((NOT bb AND LONG 16rffff) = LONG 16r0f0f); + LONG LONG BITS bbb = LONG LONG 16rf0f0; + ASSERT ((NOT bbb AND LONG LONG 16rffff) = LONG LONG 16r0f0f); + SHORT BITS ss = SHORT 16rf0f0; + ASSERT ((NOT ss AND SHORT 16rffff) = SHORT 16r0f0f); + SHORT SHORT BITS sss = SHORT SHORT 16rf0f0; + ASSERT ((NOT sss AND SHORT SHORT 16rffff) = SHORT SHORT 16r0f0f) +END diff --git a/gcc/testsuite/algol68/execute/odd-1.a68 b/gcc/testsuite/algol68/execute/odd-1.a68 new file mode 100644 index 000000000000..893bf0479d01 --- /dev/null +++ b/gcc/testsuite/algol68/execute/odd-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT a = 1; + ASSERT (ODD a); + ASSERT (ODD LONG 3); + ASSERT (NOT ODD LONG LONG 4); + ASSERT (ODD SHORT 3); + ASSERT (NOT ODD SHORT SHORT 4) +END diff --git a/gcc/testsuite/algol68/execute/op-1.a68 b/gcc/testsuite/algol68/execute/op-1.a68 new file mode 100644 index 000000000000..3b63c323ca24 --- /dev/null +++ b/gcc/testsuite/algol68/execute/op-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN OP ONEOVER = (REAL a) REAL: 1/a; + REAL x; + x := ONEOVER 3.14 +END diff --git a/gcc/testsuite/algol68/execute/op-2.a68 b/gcc/testsuite/algol68/execute/op-2.a68 new file mode 100644 index 000000000000..c7721719a564 --- /dev/null +++ b/gcc/testsuite/algol68/execute/op-2.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN OP + = (INT a, b) INT: a - -b; + ASSERT (10 + 30 = 40) +END diff --git a/gcc/testsuite/algol68/execute/op-3.a68 b/gcc/testsuite/algol68/execute/op-3.a68 new file mode 100644 index 000000000000..9889a64a3536 --- /dev/null +++ b/gcc/testsuite/algol68/execute/op-3.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN OP MIN = (REAL a, b) REAL: (a < b | a | b), + MIN = (INT a, REAL b) REAL: (a < b | a | b), + MIN = (REAL a, INT b) REAL: a MIN REAL (b); + PRIO MIN = 6; + ASSERT (10.0 MIN 20.0 > 9.9 AND 10.0 MIN 20.0 < 10.1); + ASSERT (10.0 MIN 100 > 9.9 AND 10.0 MIN 100 < 10.1); + ASSERT (100.0 MIN 10 > 9.9 AND 100.0 MIN 10 < 10.1) +END diff --git a/gcc/testsuite/algol68/execute/operator-declaration-1.a68 b/gcc/testsuite/algol68/execute/operator-declaration-1.a68 new file mode 100644 index 000000000000..61f8fa9986b1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/operator-declaration-1.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n = 10; + # Note that the priority for the monadic operators gets ignored. # + PRIO JORL = 6, JURL = 6, XXX = 6, YYY = 6; + OP(INT)INT JORL = (n > 10 | (INT a) INT: a + 1 | (INT a) INT: a - 1), + JURL = (n <= 10 | (INT a) INT: a + 1 | (INT a) INT: a - 1); + OP(INT,INT)INT XXX = (INT a, b) INT: a + b, + YYY = (n > 10 | (INT a,b) INT: a * b | (INT a,b) INT: a - b); + ASSERT (JORL 10 = 9); + ASSERT (JURL 10 = 11); + ASSERT (2 XXX 3 = 5); + ASSERT (2 YYY 3 = -1); +END diff --git a/gcc/testsuite/algol68/execute/or-bits-1.a68 b/gcc/testsuite/algol68/execute/or-bits-1.a68 new file mode 100644 index 000000000000..4fc1b06225d7 --- /dev/null +++ b/gcc/testsuite/algol68/execute/or-bits-1.a68 @@ -0,0 +1,18 @@ +# { dg-options "-fstropping=upper" } # +# OR for SIZETY BITS. # +BEGIN BITS b = 16rf0f0; + ASSERT ((b OR 16r0f0f) = 16rffff); + ASSERT ((b OR 16r00ff) = 16rf0ff); + LONG BITS bb = LONG 16rf0f0; + ASSERT ((bb OR LONG 16r0f0f) = LONG 16rffff); + ASSERT ((bb OR LONG 16r00ff) = LONG 16rf0ff); + LONG LONG BITS bbb = LONG LONG 16rf0f0; + ASSERT ((bbb OR LONG LONG 16r0f0f) = LONG LONG 16rffff); + ASSERT ((bbb OR LONG LONG 16r00ff) = LONG LONG 16rf0ff); + SHORT BITS ss = SHORT 16rf0f0; + ASSERT ((ss OR SHORT 16r0f0f) = SHORT 16rffff); + ASSERT ((ss OR SHORT 16r00ff) = SHORT 16rf0ff); + SHORT SHORT BITS sss = SHORT SHORT 16rf0f0; + ASSERT ((sss OR SHORT SHORT 16r0f0f) = SHORT SHORT 16rffff); + ASSERT ((sss OR SHORT SHORT 16r00ff) = SHORT SHORT 16rf0ff) +END diff --git a/gcc/testsuite/algol68/execute/orf-1.a68 b/gcc/testsuite/algol68/execute/orf-1.a68 new file mode 100644 index 000000000000..10f052128bc2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/orf-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 10; + ASSERT (i = 0 OREL i = 10) +END diff --git a/gcc/testsuite/algol68/execute/over-int-1.a68 b/gcc/testsuite/algol68/execute/over-int-1.a68 new file mode 100644 index 000000000000..871effb61a0b --- /dev/null +++ b/gcc/testsuite/algol68/execute/over-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 10; + LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10; + SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10; + ASSERT (i % 2 = 5); + ASSERT (ii % LONG 2 = LONG 5); + ASSERT (iii % LONG LONG 2 = LONG LONG 5); + ASSERT (ss % SHORT 2 = SHORT 5); + ASSERT (sss % SHORT SHORT 2 = SHORT SHORT 5) +END diff --git a/gcc/testsuite/algol68/execute/overab-1.a68 b/gcc/testsuite/algol68/execute/overab-1.a68 new file mode 100644 index 000000000000..8edfa1e5fab0 --- /dev/null +++ b/gcc/testsuite/algol68/execute/overab-1.a68 @@ -0,0 +1,12 @@ +# { dg-options "-fstropping=upper" } # +BEGIN (INT i := 11; i OVERAB 2; ASSERT (i = 5)); + (INT i := 11; i %:= 2; ASSERT (i = 5)); + (SHORT INT i := SHORT 11; i OVERAB SHORT 2; ASSERT (i = SHORT 5)); + (SHORT INT i := SHORT 11; i %:= SHORT 2; ASSERT (i = SHORT 5)); + (SHORT SHORT INT i := SHORT SHORT 11; i OVERAB SHORT SHORT 2; ASSERT (i = SHORT SHORT 5)); + (SHORT SHORT INT i := SHORT SHORT 11; i %:= SHORT SHORT 2; ASSERT (i = SHORT SHORT 5)); + (LONG INT i := LONG 11; i OVERAB LONG 2; ASSERT (i = LONG 5)); + (LONG INT i := LONG 11; i %:= LONG 2; ASSERT (i = LONG 5)); + (LONG LONG INT i := LONG LONG 11; i OVERAB LONG LONG 2; ASSERT (i = LONG LONG 5)); + (LONG LONG INT i := LONG LONG 11; i %:= LONG LONG 2; ASSERT (i = LONG LONG 5)) +END diff --git a/gcc/testsuite/algol68/execute/overab-2.a68 b/gcc/testsuite/algol68/execute/overab-2.a68 new file mode 100644 index 000000000000..eec8a1cbfdc8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/overab-2.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := 10; + (((n OVERAB 1))) := 5; + ASSERT (n = 5) +END diff --git a/gcc/testsuite/algol68/execute/particular-program-1.a68 b/gcc/testsuite/algol68/execute/particular-program-1.a68 new file mode 100644 index 000000000000..2c490afce04f --- /dev/null +++ b/gcc/testsuite/algol68/execute/particular-program-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +# Particular program with preceding labels. # +jo: ju: +BEGIN SKIP END diff --git a/gcc/testsuite/algol68/execute/plus-char-1.a68 b/gcc/testsuite/algol68/execute/plus-char-1.a68 new file mode 100644 index 000000000000..d017fe08ab8f --- /dev/null +++ b/gcc/testsuite/algol68/execute/plus-char-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT ("a" + "b" = "ab"); + ASSERT ("" + "x" = "x") +END diff --git a/gcc/testsuite/algol68/execute/plus-int-1.a68 b/gcc/testsuite/algol68/execute/plus-int-1.a68 new file mode 100644 index 000000000000..93ea00445ddf --- /dev/null +++ b/gcc/testsuite/algol68/execute/plus-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 10; + LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10; + SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10; + ASSERT (i + 2 = 12); + ASSERT (ii + LONG 2 = LONG 12); + ASSERT (iii + LONG LONG 2 = LONG LONG 12); + ASSERT (ss + SHORT 2 = SHORT 12); + ASSERT (sss + SHORT SHORT 2 = SHORT SHORT 12) +END diff --git a/gcc/testsuite/algol68/execute/plus-string-1.a68 b/gcc/testsuite/algol68/execute/plus-string-1.a68 new file mode 100644 index 000000000000..be9edf79de22 --- /dev/null +++ b/gcc/testsuite/algol68/execute/plus-string-1.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING foo = "foo", bar = "bar", quux = "quux"; + ASSERT ("" + "" = ""); + ASSERT ("" + foo = "foo"); + ASSERT (bar + "" = "bar"); + ASSERT (foo + bar = "foobar"); + STRING res = foo + bar; + ASSERT (LWB res = 1 AND UPB res = 6); + STRING empty = "" + ""; + ASSERT (LWB empty = 1 AND UPB empty = 0) +END diff --git a/gcc/testsuite/algol68/execute/plus-string-2.a68 b/gcc/testsuite/algol68/execute/plus-string-2.a68 new file mode 100644 index 000000000000..6399ee1cf228 --- /dev/null +++ b/gcc/testsuite/algol68/execute/plus-string-2.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC rec parse comment = VOID: + BEGIN STRING content; + done; + 100; + done: + ASSERT (content + "x" = "x") + END; + + rec parse comment +END diff --git a/gcc/testsuite/algol68/execute/plus-string-stride-1.a68 b/gcc/testsuite/algol68/execute/plus-string-stride-1.a68 new file mode 100644 index 000000000000..07fdf79537c4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/plus-string-stride-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]CHAR matrix = (("1","H","3"), + ("4","O","6"), + ("7","M","9"), + ("8","E","2")); + ASSERT (matrix[1:2,1] + matrix[3:4,3] = "1492") +END diff --git a/gcc/testsuite/algol68/execute/plusab-1.a68 b/gcc/testsuite/algol68/execute/plusab-1.a68 new file mode 100644 index 000000000000..8de4e97b046a --- /dev/null +++ b/gcc/testsuite/algol68/execute/plusab-1.a68 @@ -0,0 +1,34 @@ +# { dg-options "-fstropping=upper" } # +BEGIN BEGIN INT i := 10; + i +:= 2; + ASSERT (i = 12); + i PLUSAB 2; + ASSERT (i = 14) + END; + + BEGIN SHORT INT i := SHORT 1000; + i +:= SHORT 100; + ASSERT (i = SHORT 1100); + i PLUSAB SHORT 100; + ASSERT (i = SHORT 1200) + END; + BEGIN SHORT SHORT INT i := SHORT SHORT 10000; + i +:= SHORT SHORT 1000; + ASSERT (i = SHORT SHORT 11000); + i PLUSAB SHORT SHORT 1000; + ASSERT (i = SHORT SHORT 12000) + END; + + BEGIN LONG INT i := LONG 1000; + i +:= LONG 100; + ASSERT (i = LONG 1100); + i PLUSAB LONG 100; + ASSERT (i = LONG 1200) + END; + BEGIN LONG LONG INT i := LONG LONG 10000; + i +:= LONG LONG 1000; + ASSERT (i = LONG LONG 11000); + i PLUSAB LONG LONG 1000; + ASSERT (i = LONG LONG 12000) + END +END diff --git a/gcc/testsuite/algol68/execute/plusab-2.a68 b/gcc/testsuite/algol68/execute/plusab-2.a68 new file mode 100644 index 000000000000..6db46864d8ae --- /dev/null +++ b/gcc/testsuite/algol68/execute/plusab-2.a68 @@ -0,0 +1,20 @@ +# { dg-options "-fstropping=upper" } # +BEGIN BEGIN REAL i := 10.0; + i +:= 2.0; + ASSERT (i > 11.9); + i PLUSAB 2.0; + ASSERT (i > 13.9) + END; + BEGIN LONG REAL i := LONG 1000.0; + i +:= LONG 100.0; + ASSERT (i > LONG 1099.9); + i PLUSAB LONG 100.0; + ASSERT (i > LONG 1199.9) + END; + BEGIN LONG LONG REAL i := LONG LONG 10000.0; + i +:= LONG LONG 1000.0; + ASSERT (i > LONG LONG 10999.9); + i PLUSAB LONG LONG 1000.0; + ASSERT (i > LONG LONG 11999.9) + END +END diff --git a/gcc/testsuite/algol68/execute/plusab-3.a68 b/gcc/testsuite/algol68/execute/plusab-3.a68 new file mode 100644 index 000000000000..beb63060135d --- /dev/null +++ b/gcc/testsuite/algol68/execute/plusab-3.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := 0; + (((n +:= 1))) := 5; + ASSERT (n = 5) +END diff --git a/gcc/testsuite/algol68/execute/plusab-4.a68 b/gcc/testsuite/algol68/execute/plusab-4.a68 new file mode 100644 index 000000000000..adfbc9f7a074 --- /dev/null +++ b/gcc/testsuite/algol68/execute/plusab-4.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT num ints := 0; + num ints +:= 1; + ASSERT (num ints = 1); + ASSERT ((LOC INT +:= 12) = 12) +END diff --git a/gcc/testsuite/algol68/execute/plusab-string-1.a68 b/gcc/testsuite/algol68/execute/plusab-string-1.a68 new file mode 100644 index 000000000000..ec1bd3c45fbb --- /dev/null +++ b/gcc/testsuite/algol68/execute/plusab-string-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING foo := ""; + foo +:= "foo"; + ASSERT (LWB foo = 1 AND UPB foo = 3 AND foo = "foo"); + foo PLUSAB "bar"; + ASSERT (LWB foo = 1 AND UPB foo = 6 AND foo = "foobar") +END diff --git a/gcc/testsuite/algol68/execute/plusto-char-1.a68 b/gcc/testsuite/algol68/execute/plusto-char-1.a68 new file mode 100644 index 000000000000..79881c07d101 --- /dev/null +++ b/gcc/testsuite/algol68/execute/plusto-char-1.a68 @@ -0,0 +1,7 @@ +begin string foo := "foo"; + char c := "x"; + c PLUSTO foo; + assert (foo = "xfoo"); + c +=: foo; + assert (foo = "xxfoo") +end diff --git a/gcc/testsuite/algol68/execute/plusto-string-1.a68 b/gcc/testsuite/algol68/execute/plusto-string-1.a68 new file mode 100644 index 000000000000..7d5894b0cd47 --- /dev/null +++ b/gcc/testsuite/algol68/execute/plusto-string-1.a68 @@ -0,0 +1,6 @@ +begin string foo := "foo"; + "bar" PLUSTO foo; + assert (foo = "barfoo"); + "quux" +=: foo; + assert (foo = "quuxbarfoo") +end diff --git a/gcc/testsuite/algol68/execute/posix-argc-argv-1.a68 b/gcc/testsuite/algol68/execute/posix-argc-argv-1.a68 new file mode 100644 index 000000000000..a6380380ffe7 --- /dev/null +++ b/gcc/testsuite/algol68/execute/posix-argc-argv-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (argc >= 1); + ASSERT (argv (1000) = ""); + ASSERT (argv (-1) = ""); + FOR i TO argc + DO puts (argv (i)) OD +END diff --git a/gcc/testsuite/algol68/execute/posix-fopen-1.a68 b/gcc/testsuite/algol68/execute/posix-fopen-1.a68 new file mode 100644 index 000000000000..d2a0c406f2b1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/posix-fopen-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT fd = fopen ("doesn''t exist", file o default); + ASSERT (fd = -1) +END diff --git a/gcc/testsuite/algol68/execute/posix-fputc-fputs-1.a68 b/gcc/testsuite/algol68/execute/posix-fputc-fputs-1.a68 new file mode 100644 index 000000000000..bf0af6e6e225 --- /dev/null +++ b/gcc/testsuite/algol68/execute/posix-fputc-fputs-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN fputc (stdout, "X"); + ASSERT (fputs (stdout, "foo") = 3); + fputs (stdout, fputc (stdout, "Y") + "T"); + fputc (stdout, "Z"); + ASSERT (fputs (stdout, "") = 0); + puts ("") +END diff --git a/gcc/testsuite/algol68/execute/posix-getenv-1.a68 b/gcc/testsuite/algol68/execute/posix-getenv-1.a68 new file mode 100644 index 000000000000..d1e690568124 --- /dev/null +++ b/gcc/testsuite/algol68/execute/posix-getenv-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (getenv ("") = ""); + ASSERT (getenv ("DOESNT EXIST FOR SURE") = "") +END diff --git a/gcc/testsuite/algol68/execute/posix-lseek.a68 b/gcc/testsuite/algol68/execute/posix-lseek.a68 new file mode 100644 index 000000000000..8f20dc53d975 --- /dev/null +++ b/gcc/testsuite/algol68/execute/posix-lseek.a68 @@ -0,0 +1,17 @@ +begin int fd = fopen ("../../ga68", file_o_rdonly); + assert (fd /= -1); + assert (errno = 0); + long long int offset; + offset := lseek (fd, long long 0, seek_cur); + assert (offset = long long 0); + assert (errno = 0); + offset := lseek (fd, long long 0, seek_set); + assert (offset = long long 0); + assert (errno = 0); + offset := lseek (fd, long long 0, seek_end); + long long int offset2 = lseek (fd, offset, seek_set); + assert (offset = offset2); + long long int file_size = fsize (fd); + assert (errno = 0); + assert (offset = file_size) +end diff --git a/gcc/testsuite/algol68/execute/posix-perror-1.a68 b/gcc/testsuite/algol68/execute/posix-perror-1.a68 new file mode 100644 index 000000000000..a349dd72ad88 --- /dev/null +++ b/gcc/testsuite/algol68/execute/posix-perror-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# { dg-output "^something unique: " } # +BEGIN INT fd = fopen ("doesn''t exist", file o default); + IF fd = -1 THEN + ASSERT (strerror (errno) /= ""); + perror ("something unique") + FI +END diff --git a/gcc/testsuite/algol68/execute/posix-putchar-1.a68 b/gcc/testsuite/algol68/execute/posix-putchar-1.a68 new file mode 100644 index 000000000000..01bfbbd371e2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/posix-putchar-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN putchar ("X"); + putchar ("Y"); + putchar ("Z"); + puts ("\n") +END diff --git a/gcc/testsuite/algol68/execute/posix-stdinouterr-1.a68 b/gcc/testsuite/algol68/execute/posix-stdinouterr-1.a68 new file mode 100644 index 000000000000..dc5b373d9380 --- /dev/null +++ b/gcc/testsuite/algol68/execute/posix-stdinouterr-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (stdin = 0); + ASSERT (stdout = 1); + ASSERT (stderr = 2) +END diff --git a/gcc/testsuite/algol68/execute/posix-strerror-1.a68 b/gcc/testsuite/algol68/execute/posix-strerror-1.a68 new file mode 100644 index 000000000000..607e40d0b9da --- /dev/null +++ b/gcc/testsuite/algol68/execute/posix-strerror-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT fd = fopen ("doesn''t exist", file o default); + IF fd = -1 THEN ASSERT (strerror (errno) /= "") FI +END diff --git a/gcc/testsuite/algol68/execute/posix-stride-1.a68 b/gcc/testsuite/algol68/execute/posix-stride-1.a68 new file mode 100644 index 000000000000..6e7a79d2640d --- /dev/null +++ b/gcc/testsuite/algol68/execute/posix-stride-1.a68 @@ -0,0 +1,14 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]CHAR matrix = (("1","H","3"), + ("4","O","6"), + ("7","M","9"), + ("8","E","0")); + []CHAR column = matrix[1:4,2]; + puts (column); + fputs (stdout, matrix[3,2:3]); + puts ("\n"); + fputs (stdout, matrix[1:3,1]); + puts ("\n"); + puts (getenv (matrix[,2])); + perror (matrix[,3]) +END diff --git a/gcc/testsuite/algol68/execute/pow-int-1.a68 b/gcc/testsuite/algol68/execute/pow-int-1.a68 new file mode 100644 index 000000000000..7d929d714ff4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/pow-int-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 2; + LONG INT ii = LONG 2, LONG LONG INT iii = LONG LONG 2; + SHORT INT ss = SHORT 2, SHORT SHORT INT sss = SHORT SHORT 2; + ASSERT (i ** 2 = 4); + ASSERT (ii ** 2 = LONG 4); + ASSERT (iii ** 2 = LONG LONG 4); + ASSERT (ss ** 2 = SHORT 4); + ASSERT (sss ** 2 = SHORT SHORT 4) +END diff --git a/gcc/testsuite/algol68/execute/pow-real-1.a68 b/gcc/testsuite/algol68/execute/pow-real-1.a68 new file mode 100644 index 000000000000..810287064851 --- /dev/null +++ b/gcc/testsuite/algol68/execute/pow-real-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r0 = 2.0; LONG REAL rr0 = LONG 2.0; LONG LONG REAL rrr0 = LONG LONG 2.0; + REAL r1 = r0 ^ 2; REAL r2 = r0 ^ 3.0; + LONG REAL rr1 = rr0 ^ LONG 2; LONG REAL rr2 = rr0 ^ LONG 3.0; + LONG LONG REAL rrr1 = rrr0 ^ LONG LONG 2; LONG LONG REAL rrr2 = rrr0 ^ LONG LONG 3.0; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/proc-1.a68 b/gcc/testsuite/algol68/execute/proc-1.a68 new file mode 100644 index 000000000000..3085f4b73607 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC foo = INT: 100; + ASSERT (foo = 100) +END diff --git a/gcc/testsuite/algol68/execute/proc-10.a68 b/gcc/testsuite/algol68/execute/proc-10.a68 new file mode 100644 index 000000000000..bcc86d851405 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-10.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC(INT,INT)INT foo = (INT i, j) INT: i + j; + ASSERT (foo (10, 20) = 30) +END diff --git a/gcc/testsuite/algol68/execute/proc-12.a68 b/gcc/testsuite/algol68/execute/proc-12.a68 new file mode 100644 index 000000000000..be75e7948db6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-12.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC(INT)INT foo = baz; + PROC bar = (INT i) INT: i + 1; + PROC baz = (INT i) INT: i - 1; + ASSERT (foo (10) = 9) +END diff --git a/gcc/testsuite/algol68/execute/proc-13.a68 b/gcc/testsuite/algol68/execute/proc-13.a68 new file mode 100644 index 000000000000..c23c08612c95 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-13.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC is even := (INT n) BOOL: n %* 2 = 0; + ASSERT (is even (40)); + PROC no args := BOOL: TRUE; + ASSERT (no args) +END diff --git a/gcc/testsuite/algol68/execute/proc-14.a68 b/gcc/testsuite/algol68/execute/proc-14.a68 new file mode 100644 index 000000000000..b653bbe148b4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-14.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC is even := (INT n) BOOL: n %* 2 = 0; + PROC is odd := (INT n) BOOL: n %* 2 /= 0; + PROC(INT)BOOL f = is even; + PROC(INT)BOOL g = is odd; + ASSERT (f (40)); + ASSERT (g (3)) +END diff --git a/gcc/testsuite/algol68/execute/proc-15.a68 b/gcc/testsuite/algol68/execute/proc-15.a68 new file mode 100644 index 000000000000..63c5a557704a --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-15.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# Nested procedures. # +BEGIN PROC foo = (INT i) INT: + BEGIN PROC bar = (INT i) INT: i - 1; + bar (i) * 10 + END; + ASSERT (foo (10) = 90) +END diff --git a/gcc/testsuite/algol68/execute/proc-16.a68 b/gcc/testsuite/algol68/execute/proc-16.a68 new file mode 100644 index 000000000000..bb1b1e25d89e --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-16.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC bar = (INT i) INT: i - 1; + PROC foo = (INT i) INT: + BEGIN + bar (i) * 10 + END; + ASSERT (foo (10) = 90) +END diff --git a/gcc/testsuite/algol68/execute/proc-17.a68 b/gcc/testsuite/algol68/execute/proc-17.a68 new file mode 100644 index 000000000000..24ac5a8c5eda --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-17.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +# Identity declarations and procedures. # +BEGIN PROC foo = (INT i) INT: i + 1; + ASSERT (foo (10) = 11); + PROC(INT)INT bar = (INT i) INT: i + 1; + ASSERT (bar (10) = 11); + PROC(INT)INT baz = foo; + ASSERT (baz (10) = 11); + PROC(INT)INT quux = IF 10 > 1 THEN baz ELSE foo FI; + ASSERT (quux (10) = 11) +END diff --git a/gcc/testsuite/algol68/execute/proc-18.a68 b/gcc/testsuite/algol68/execute/proc-18.a68 new file mode 100644 index 000000000000..34568828be77 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-18.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC foo = (INT i) INT: i + 1; + PROC(INT)INT bar; + bar := foo; + ASSERT (bar (10) = 11) +END diff --git a/gcc/testsuite/algol68/execute/proc-19.a68 b/gcc/testsuite/algol68/execute/proc-19.a68 new file mode 100644 index 000000000000..0846fdca8dac --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-19.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC foo = (INT i) INT: i + 1; + PROC(INT)INT bar := foo; + ASSERT (bar (10) = 11) +END diff --git a/gcc/testsuite/algol68/execute/proc-2.a68 b/gcc/testsuite/algol68/execute/proc-2.a68 new file mode 100644 index 000000000000..39346fe35677 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Call a non-variable procedure before declaration. # +BEGIN ASSERT (foo = 100); + PROC foo = INT: 100; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/proc-20.a68 b/gcc/testsuite/algol68/execute/proc-20.a68 new file mode 100644 index 000000000000..3bf66eea53a9 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-20.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC foo := (INT i) INT: i + 1; + PROC(INT)INT bar := foo; + ASSERT (bar (10) = 11) +END diff --git a/gcc/testsuite/algol68/execute/proc-21.a68 b/gcc/testsuite/algol68/execute/proc-21.a68 new file mode 100644 index 000000000000..c1ac9807c23a --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-21.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# REF REF PROC # +BEGIN PROC foo = (INT i) INT: i + 1; + PROC(INT)INT bar := foo; + REF PROC(INT)INT baz; + baz := bar; + ASSERT (baz (10) = 11) +END diff --git a/gcc/testsuite/algol68/execute/proc-22.a68 b/gcc/testsuite/algol68/execute/proc-22.a68 new file mode 100644 index 000000000000..fa23d531aa51 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-22.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# REF REF PROC # +BEGIN PROC foo = (INT i) INT: i + 1; + PROC(INT)INT bar := foo; + REF PROC(INT)INT baz := bar; + ASSERT (baz (10) = 11) +END diff --git a/gcc/testsuite/algol68/execute/proc-23.a68 b/gcc/testsuite/algol68/execute/proc-23.a68 new file mode 100644 index 000000000000..7fa1257eca7a --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-23.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC increment = (INT a) INT: a + 1; + PROC getproc = PROC(INT)INT: + BEGIN increment + END; + # getproc below gets deprocedured to yield increment. # + ASSERT (getproc (10) = 11) +END diff --git a/gcc/testsuite/algol68/execute/proc-25.a68 b/gcc/testsuite/algol68/execute/proc-25.a68 new file mode 100644 index 000000000000..5b46e8914e6f --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-25.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC increment := (INT a) INT: a + 1; + PROC getproc := PROC(INT)INT: + BEGIN increment + END; + # getproc below gets deprocedured to yield increment. # + ASSERT (getproc (10) = 11) +END diff --git a/gcc/testsuite/algol68/execute/proc-26.a68 b/gcc/testsuite/algol68/execute/proc-26.a68 new file mode 100644 index 000000000000..833cbb34a4b2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-26.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC sum = (INT a, b) INT: a + b, + minus = (INT a, b) INT: a - b; + ASSERT (sum (1, 2) = 3); + ASSERT (minus (1, 2) = -1) +END diff --git a/gcc/testsuite/algol68/execute/proc-27.a68 b/gcc/testsuite/algol68/execute/proc-27.a68 new file mode 100644 index 000000000000..49c4c6a242c7 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-27.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC reciprocal = (REAL a) REAL: 1/a; + REAL x; + x := reciprocal (3.14) +END diff --git a/gcc/testsuite/algol68/execute/proc-28.a68 b/gcc/testsuite/algol68/execute/proc-28.a68 new file mode 100644 index 000000000000..d909219d72a8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-28.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC hcf = (INT m, n) INT: + IF m < n + THEN hcf (n, m) + ELIF n = 0 + THEN m + ELSE hcf (n, m MOD n) + FI; + ASSERT (hcf (10, 20) = 10) +END diff --git a/gcc/testsuite/algol68/execute/proc-29.a68 b/gcc/testsuite/algol68/execute/proc-29.a68 new file mode 100644 index 000000000000..51ea5fccf933 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-29.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# A heap proc variable. # +BEGIN HEAP PROC foo := INT: 666; + ASSERT (foo = 666) +END diff --git a/gcc/testsuite/algol68/execute/proc-3.a68 b/gcc/testsuite/algol68/execute/proc-3.a68 new file mode 100644 index 000000000000..bd9ce053485b --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-3.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC foo = (INT i, j) INT: i + j + 1; + ASSERT (foo (10, 11) = 22) +END diff --git a/gcc/testsuite/algol68/execute/proc-4.a68 b/gcc/testsuite/algol68/execute/proc-4.a68 new file mode 100644 index 000000000000..bce68cf3f161 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-4.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (foo (10, 11) = 22); + PROC foo = (INT i, j) INT: i + j + 1; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/proc-5.a68 b/gcc/testsuite/algol68/execute/proc-5.a68 new file mode 100644 index 000000000000..1893dc35179d --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-5.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Recursive function. # +BEGIN PROC foo = (INT i) INT: (i > 0 | i + foo (i - 1) | 0); + ASSERT (foo (10) = 55) +END diff --git a/gcc/testsuite/algol68/execute/proc-6.a68 b/gcc/testsuite/algol68/execute/proc-6.a68 new file mode 100644 index 000000000000..894f53e05250 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-6.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Recursive function, used before declared. # +BEGIN ASSERT (foo (10) = 55); + PROC foo = (INT i) INT: BEGIN (i > 0 | i + foo (i - 1) | 0) END; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/proc-7.a68 b/gcc/testsuite/algol68/execute/proc-7.a68 new file mode 100644 index 000000000000..9f39e2d0d043 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-7.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC foo = (INT i) INT: i + 1; + PROC(INT)INT bar = foo; + ASSERT (bar (10) = 11) +END diff --git a/gcc/testsuite/algol68/execute/proc-8.a68 b/gcc/testsuite/algol68/execute/proc-8.a68 new file mode 100644 index 000000000000..ee548c6b3745 --- /dev/null +++ b/gcc/testsuite/algol68/execute/proc-8.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC INT foo = INT: 100; + ASSERT (foo = 100) +END diff --git a/gcc/testsuite/algol68/execute/procedured-goto-1.a68 b/gcc/testsuite/algol68/execute/procedured-goto-1.a68 new file mode 100644 index 000000000000..8d3dc21c782d --- /dev/null +++ b/gcc/testsuite/algol68/execute/procedured-goto-1.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 4; +beg: WHILE i > 0 + DO []PROC VOID table = (l3,l1,l2,end); + table[i]; +l1: puts ("uno\n"); i -:= 1; beg; +l2: puts ("dos\n"); i -:= 1; beg; +l3: puts ("tres\n"); i -:= 1; beg; +end: puts ("cuatro\n"); i -:= 1; beg + OD +END diff --git a/gcc/testsuite/algol68/execute/quine.a68 b/gcc/testsuite/algol68/execute/quine.a68 new file mode 100644 index 000000000000..9fd9e422fdc1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/quine.a68 @@ -0,0 +1,2 @@ +# { dg-options "-fstropping=upper" } # +(STRING a="(STRING a="";puts(2*a[:19]+2*a[19:]);0)";puts(2*a[:19]+2*a[19:])) diff --git a/gcc/testsuite/algol68/execute/random-1.a68 b/gcc/testsuite/algol68/execute/random-1.a68 new file mode 100644 index 000000000000..82cc6e3a576b --- /dev/null +++ b/gcc/testsuite/algol68/execute/random-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN IF random > 0.5 THEN puts ("yes\n") ELSE puts ("no\n") FI; + LONG REAL rr = long random; + IF rr > LONG 0.5 THEN puts ("long yes\n") ELSE puts ("long no\n") FI; + LONG LONG REAL rrr = long long random; + IF rrr > LONG LONG 0.5 THEN puts ("long long yes\n") ELSE puts ("long long no\n") FI +END diff --git a/gcc/testsuite/algol68/execute/re-im-1.a68 b/gcc/testsuite/algol68/execute/re-im-1.a68 new file mode 100644 index 000000000000..7801b769057f --- /dev/null +++ b/gcc/testsuite/algol68/execute/re-im-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN COMPL z = 4.0I5.0; + ASSERT (RE z = 4.0 AND IM z = 5.0); + LONG COMPL zz = LONG 4.0 I LONG 6.0; + ASSERT (RE zz = LONG 4.0 AND IM zz = LONG 6.0); + LONG LONG COMPL zzz = LONG LONG 4.0 I LONG LONG 7.0; + ASSERT (RE zzz = LONG LONG 4.0 AND IM zzz = LONG LONG 7.0) +END diff --git a/gcc/testsuite/algol68/execute/rela-string-1.a68 b/gcc/testsuite/algol68/execute/rela-string-1.a68 new file mode 100644 index 000000000000..92648578dabd --- /dev/null +++ b/gcc/testsuite/algol68/execute/rela-string-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT ("" >= ""); + ASSERT ("" <= ""); + ASSERT ("zzz" > "aaa"); + ASSERT ("zzz" >= "aaa"); + ASSERT ("HelloA" < "HelloB") +END diff --git a/gcc/testsuite/algol68/execute/repr-1.a68 b/gcc/testsuite/algol68/execute/repr-1.a68 new file mode 100644 index 000000000000..2b92a3e7de01 --- /dev/null +++ b/gcc/testsuite/algol68/execute/repr-1.a68 @@ -0,0 +1,3 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (REPR ABS "x" = "x") +END diff --git a/gcc/testsuite/algol68/execute/round-1.a68 b/gcc/testsuite/algol68/execute/round-1.a68 new file mode 100644 index 000000000000..632e38223320 --- /dev/null +++ b/gcc/testsuite/algol68/execute/round-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL x = 3.14, y = 3.80; + LONG REAL xx = LONG 3.14, yy = LONG 3.80; + LONG LONG REAL xxx = LONG LONG 3.14, yyy = LONG LONG 3.80; + ASSERT (ROUND x = 3 AND ROUND y = 4); + ASSERT (ROUND xx = LONG 3 AND ROUND yy = LONG 4); + ASSERT (ROUND xxx = LONG LONG 3 AND ROUND yyy = LONG LONG 4) +END diff --git a/gcc/testsuite/algol68/execute/row-display-1.a68 b/gcc/testsuite/algol68/execute/row-display-1.a68 new file mode 100644 index 000000000000..82540d700dcc --- /dev/null +++ b/gcc/testsuite/algol68/execute/row-display-1.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT foo = (7,8,9); + [,]INT bar = ((1,2,3),(4,5,6),foo); + ASSERT (bar[1,1] = 1); + ASSERT (bar[1,2] = 2); + ASSERT (bar[1,3] = 3); + ASSERT (bar[2,1] = 4); + ASSERT (bar[2,2] = 5); + ASSERT (bar[2,3] = 6); + ASSERT (bar[3,1] = 7); + ASSERT (bar[3,2] = 8); + ASSERT (bar[3,3] = 9) +END diff --git a/gcc/testsuite/algol68/execute/row-display-2.a68 b/gcc/testsuite/algol68/execute/row-display-2.a68 new file mode 100644 index 000000000000..f8a07a4d162a --- /dev/null +++ b/gcc/testsuite/algol68/execute/row-display-2.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT foo = (7,8,9); + [3,3]INT bar := ((1,2,3),(4,5,6),foo); + ASSERT (bar[1,1] = 1); + ASSERT (bar[1,2] = 2); + ASSERT (bar[1,3] = 3); + ASSERT (bar[2,1] = 4); + ASSERT (bar[2,2] = 5); + ASSERT (bar[2,3] = 6); + ASSERT (bar[3,1] = 7); + ASSERT (bar[3,2] = 8); + ASSERT (bar[3,3] = 9) +END diff --git a/gcc/testsuite/algol68/execute/row-display-3.a68 b/gcc/testsuite/algol68/execute/row-display-3.a68 new file mode 100644 index 000000000000..73f3ff82a466 --- /dev/null +++ b/gcc/testsuite/algol68/execute/row-display-3.a68 @@ -0,0 +1,15 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE FOO = STRUCT (INT i, STRING s); + [,]FOO matrix = (((10, "foo"), (20, "bar"), (30, "baz")), + ((40, "uno"), (50, "dos"), (60, "tres")), + ((70, "cuatro"), (80, "cinco"), (90, "seis"))); + ASSERT (i OF matrix[1,1] = 10); + ASSERT (i OF matrix[1,2] = 20); + ASSERT (i OF matrix[1,3] = 30); + ASSERT (i OF matrix[2,1] = 40); + ASSERT (i OF matrix[2,2] = 50); + ASSERT (i OF matrix[2,3] = 60); + ASSERT (i OF matrix[3,1] = 70); + ASSERT (i OF matrix[3,2] = 80); + ASSERT (i OF matrix[3,3] = 90) +END diff --git a/gcc/testsuite/algol68/execute/row-display-4.a68 b/gcc/testsuite/algol68/execute/row-display-4.a68 new file mode 100644 index 000000000000..464d6fb48e78 --- /dev/null +++ b/gcc/testsuite/algol68/execute/row-display-4.a68 @@ -0,0 +1,16 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,][]INT duples = (((1,2), (3,4), (5,6)), + ((7,8), (9,10), (11,12))); + ASSERT (duples[1,1][1] = 1); + ASSERT (duples[1,1][2] = 2); + ASSERT (duples[1,2][1] = 3); + ASSERT (duples[1,2][2] = 4); + ASSERT (duples[1,3][1] = 5); + ASSERT (duples[1,3][2] = 6); + ASSERT (duples[2,1][1] = 7); + ASSERT (duples[2,1][2] = 8); + ASSERT (duples[2,2][1] = 9); + ASSERT (duples[2,2][2] = 10); + ASSERT (duples[2,3][1] = 11); + ASSERT (duples[2,3][2] = 12) +END diff --git a/gcc/testsuite/algol68/execute/row-display-5.a68 b/gcc/testsuite/algol68/execute/row-display-5.a68 new file mode 100644 index 000000000000..9d6b34bd0f73 --- /dev/null +++ b/gcc/testsuite/algol68/execute/row-display-5.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT list1 = (1,2,3), + list2 = (4,5,6), + list3 = (7,8,9); + [,]INT matrix = (list1, list2, list3); + [,,]INT cube = (matrix, matrix, matrix); + ASSERT (cube[1,1,1] = 1); + ASSERT (cube[2,2,2] = 5); + ASSERT (cube[3,3,3] = 9) +END diff --git a/gcc/testsuite/algol68/execute/rowing-1.a68 b/gcc/testsuite/algol68/execute/rowing-1.a68 new file mode 100644 index 000000000000..792b7afbb849 --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT a = 10; + ASSERT (LWB a = 1 AND UPB a = 1 AND ELEMS a = 1); + ASSERT (a[1] = 10) +END diff --git a/gcc/testsuite/algol68/execute/rowing-10.a68 b/gcc/testsuite/algol68/execute/rowing-10.a68 new file mode 100644 index 000000000000..8ae0caae95de --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-10.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 10; + REF[,]INT a = i; + ASSERT (1 LWB a = 1 AND 1 UPB a = 1 AND 1 ELEMS a = 1); + ASSERT (2 LWB a = 1 AND 2 UPB a = 1 AND 2 ELEMS a = 1); + a[1,1] := a[1,1] + 1; + ASSERT (a[1,1] = 11) +END diff --git a/gcc/testsuite/algol68/execute/rowing-11.a68 b/gcc/testsuite/algol68/execute/rowing-11.a68 new file mode 100644 index 000000000000..c34342cf2d42 --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-11.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 10; + REF[,,]INT a = i; + ASSERT (1 LWB a = 1 AND 1 UPB a = 1 AND 1 ELEMS a = 1); + ASSERT (2 LWB a = 1 AND 2 UPB a = 1 AND 2 ELEMS a = 1); + ASSERT (3 LWB a = 1 AND 3 UPB a = 1 AND 3 ELEMS a = 1); + a[1,1,1] := a[1,1,1] + 1; + ASSERT (a[1,1,1] = 11) +END diff --git a/gcc/testsuite/algol68/execute/rowing-12.a68 b/gcc/testsuite/algol68/execute/rowing-12.a68 new file mode 100644 index 000000000000..d0bb7b4d7d3d --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-12.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Rowing of NIL yields NIL. # +BEGIN REF INT i = NIL; + REF[]INT a = i; + ASSERT (a :=: NIL) +END diff --git a/gcc/testsuite/algol68/execute/rowing-13.a68 b/gcc/testsuite/algol68/execute/rowing-13.a68 new file mode 100644 index 000000000000..9ac2517b3b1c --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-13.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# Rowing of NIL yields NIL. # +BEGIN REF INT i = (NIL); + REF[,,]INT a = (i); + ASSERT (a :=: NIL) +END diff --git a/gcc/testsuite/algol68/execute/rowing-2.a68 b/gcc/testsuite/algol68/execute/rowing-2.a68 new file mode 100644 index 000000000000..d8c66deaa5ee --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [][]INT a = 10; + ASSERT (a[1][1] = 10); + ASSERT (LWB a = 1 AND UPB a = 1 AND ELEMS a = 1); + ASSERT (LWB a[1] = 1 AND UPB a[1] = 1 AND ELEMS a[1] = 1) +END diff --git a/gcc/testsuite/algol68/execute/rowing-3.a68 b/gcc/testsuite/algol68/execute/rowing-3.a68 new file mode 100644 index 000000000000..bfb8fd30af4c --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-3.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [][][]INT a = 10; + ASSERT (a[1][1][1] = 10); + ASSERT (LWB a = 1 AND UPB a = 1 AND ELEMS a = 1); + ASSERT (LWB a[1] = 1 AND UPB a[1] = 1 AND ELEMS a[1] = 1); + ASSERT (LWB a[1][1] = 1 AND UPB a[1][1] = 1 AND ELEMS a[1][1] = 1) +END diff --git a/gcc/testsuite/algol68/execute/rowing-4.a68 b/gcc/testsuite/algol68/execute/rowing-4.a68 new file mode 100644 index 000000000000..0dd540d28d7d --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-4.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE FOO = STRUCT (INT i, REAL r); + FOO foo = (10, 3.14); + [][]FOO a = foo; + ASSERT (LWB a = 1 AND UPB a = 1 AND ELEMS a = 1); + ASSERT (LWB a[1] = 1 AND UPB a[1] = 1 AND ELEMS a[1] = 1); + ASSERT (i OF a[1][1] = 10) +END diff --git a/gcc/testsuite/algol68/execute/rowing-5.a68 b/gcc/testsuite/algol68/execute/rowing-5.a68 new file mode 100644 index 000000000000..2172617b640b --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-5.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +# Rowing of a name. # +BEGIN INT i := 10; + REF[]INT a = i; + ASSERT (LWB a = 1 AND UPB a = 1 AND ELEMS a = 1); + a[1] := a[1] + 1; + ASSERT (a[1] = 11) +END diff --git a/gcc/testsuite/algol68/execute/rowing-6.a68 b/gcc/testsuite/algol68/execute/rowing-6.a68 new file mode 100644 index 000000000000..9fb050ab5863 --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-6.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Rowing of NIL yields NIL. # +BEGIN REF[]INT a = REF INT(NIL); + ASSERT (a :=: NIL) +END diff --git a/gcc/testsuite/algol68/execute/rowing-7.a68 b/gcc/testsuite/algol68/execute/rowing-7.a68 new file mode 100644 index 000000000000..dde8392f253e --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-7.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]INT a = 10; + ASSERT (1 LWB a = 1 AND 1 UPB a = 1 AND 1 ELEMS a = 1); + ASSERT (2 LWB a = 1 AND 2 UPB a = 1 AND 2 ELEMS a = 1); + ASSERT (a[1,1] = 10) +END diff --git a/gcc/testsuite/algol68/execute/rowing-8.a68 b/gcc/testsuite/algol68/execute/rowing-8.a68 new file mode 100644 index 000000000000..069ee3e21c96 --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-8.a68 @@ -0,0 +1,12 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT a = 10; + ASSERT (1 LWB a = 1 AND 1 UPB a = 1 AND 1 ELEMS a = 1); + [,]INT aa = a; + ASSERT (1 LWB aa = 1 AND 1 UPB aa = 1 AND 1 ELEMS aa = 1); + ASSERT (2 LWB aa = 1 AND 2 UPB aa = 1 AND 2 ELEMS aa = 1); + [,,]INT aaa = aa; + ASSERT (1 LWB aaa = 1 AND 1 UPB aaa = 1 AND 1 ELEMS aaa = 1); + ASSERT (2 LWB aaa = 1 AND 2 UPB aaa = 1 AND 2 ELEMS aaa = 1); + ASSERT (3 LWB aaa = 1 AND 3 UPB aaa = 1 AND 3 ELEMS aaa = 1); + ASSERT (aaa[1,1,1] = 10) +END diff --git a/gcc/testsuite/algol68/execute/rowing-9.a68 b/gcc/testsuite/algol68/execute/rowing-9.a68 new file mode 100644 index 000000000000..5e347216d30d --- /dev/null +++ b/gcc/testsuite/algol68/execute/rowing-9.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,,]INT aaa = 10; + ASSERT (1 LWB aaa = 1 AND 1 UPB aaa = 1 AND 1 ELEMS aaa = 1); + ASSERT (2 LWB aaa = 1 AND 2 UPB aaa = 1 AND 2 ELEMS aaa = 1); + ASSERT (3 LWB aaa = 1 AND 3 UPB aaa = 1 AND 3 ELEMS aaa = 1); + ASSERT (aaa[1,1,1] = 10) +END diff --git a/gcc/testsuite/algol68/execute/selection-1.a68 b/gcc/testsuite/algol68/execute/selection-1.a68 new file mode 100644 index 000000000000..c7087b2eeab5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/selection-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Selecting a struct results in a sub-value. # +BEGIN MODE PERSON = STRUCT (INT age, REAL income, INT num children); + PERSON person = (44, 999.99, 0); + ASSERT (age OF person = 44); + ASSERT (num children OF person = 0) +END diff --git a/gcc/testsuite/algol68/execute/selection-2.a68 b/gcc/testsuite/algol68/execute/selection-2.a68 new file mode 100644 index 000000000000..0d7b6c6730b5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/selection-2.a68 @@ -0,0 +1,14 @@ +# { dg-options "-fstropping=upper" } # +# Selecting a struct name results in sub-names. # +BEGIN MODE PERSON = STRUCT (INT age, REAL income, INT num children); + PERSON person; + age OF person := 44; + income OF person := 999.99; + num children OF person := 0; + ASSERT (age OF person = 44); + ASSERT (num children OF person = 0); + REF INT ptr to age := age OF person; + ASSERT (ptr to age = 44); + age OF person := 55; + ASSERT (ptr to age = 55) +END diff --git a/gcc/testsuite/algol68/execute/selection-3.a68 b/gcc/testsuite/algol68/execute/selection-3.a68 new file mode 100644 index 000000000000..8648003ad23b --- /dev/null +++ b/gcc/testsuite/algol68/execute/selection-3.a68 @@ -0,0 +1,12 @@ +# { dg-options "-fstropping=upper" } # +# Structs can be nested in other structs. # +BEGIN MODE INCOME = STRUCT (REAL salary, stock, INT code); + MODE PERSON = STRUCT (INT age, INCOME income, INT num children); + + PERSON person = (44, (999.99, 0.0, 10), 3); + + ASSERT (age OF person = 44); + ASSERT (code OF income OF person = 10); + ASSERT (num children OF person = 3); + ASSERT (num children OF person * code OF income OF person = 30) +END diff --git a/gcc/testsuite/algol68/execute/selection-4.a68 b/gcc/testsuite/algol68/execute/selection-4.a68 new file mode 100644 index 000000000000..9e81db222c1a --- /dev/null +++ b/gcc/testsuite/algol68/execute/selection-4.a68 @@ -0,0 +1,19 @@ +# { dg-options "-fstropping=upper" } # +# Structs can be nested in other structs. Version with subnames. # +BEGIN MODE INCOME = STRUCT (REAL salary, stock, INT code); + MODE PERSON = STRUCT (INT age, INCOME income, INT num children); + + PERSON person; + + age OF person := 44; + salary OF income OF person := 999.99; + stock OF income OF person := 0.0; + num children OF person := 3; + code OF income OF person := num children OF person; + + ASSERT (age OF person = 44); + ASSERT (code OF income OF person = num children OF person); + ASSERT (code OF income OF person = 3); + ASSERT (num children OF person = 3); + ASSERT (num children OF person * code OF income OF person = 9) +END diff --git a/gcc/testsuite/algol68/execute/selection-5.a68 b/gcc/testsuite/algol68/execute/selection-5.a68 new file mode 100644 index 000000000000..fde72d53ade5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/selection-5.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +# pr UPPER pr # +BEGIN MODE JORL = STRUCT (INT i, REAL r); + REF JORL jorl = LOC JORL := (10, 3.14); + ASSERT (i OF jorl = 10) +END diff --git a/gcc/testsuite/algol68/execute/selection-multiple-1.a68 b/gcc/testsuite/algol68/execute/selection-multiple-1.a68 new file mode 100644 index 000000000000..1dc67eae28e3 --- /dev/null +++ b/gcc/testsuite/algol68/execute/selection-multiple-1.a68 @@ -0,0 +1,12 @@ +begin [10]struct (int age, string name) persons; + + for i to UPB persons + do age of persons[i] := 20 + i; + name of persons[i] := "x" * i + od; + + for i to UPB name of persons + do assert ((age of persons)[i] = 20 + i); + assert ((name of persons)[i] = "x" * i) + od +end diff --git a/gcc/testsuite/algol68/execute/selection-multiple-2.a68 b/gcc/testsuite/algol68/execute/selection-multiple-2.a68 new file mode 100644 index 000000000000..89f848df60b2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/selection-multiple-2.a68 @@ -0,0 +1,18 @@ +begin [10,5]struct (int age, string name) persons; + + for i to 1 UPB persons + do for j to 2 UPB persons + do age of persons[i,j] := 20 + i + j; + name of persons[i,j] := "x" * (i + j) + od + od; + + assert (1 UPB name of persons = 10); + assert (2 UPB name of persons = 5); + for i to 1 UPB name of persons + do for j to 2 UPB name of persons + do assert ((age of persons)[i,j] = 20 + i + j); + assert ((name of persons)[i,j] = "x" * (i + j)) + od + od +end diff --git a/gcc/testsuite/algol68/execute/serial-clause-1.a68 b/gcc/testsuite/algol68/execute/serial-clause-1.a68 new file mode 100644 index 000000000000..7253f3f4af15 --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-clause-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 10; + BEGIN INT i = 20; # { dg-warning "hides" } # + ASSERT (i = 20); + i + END; + ASSERT (i = 10) +END diff --git a/gcc/testsuite/algol68/execute/serial-clause-10.a68 b/gcc/testsuite/algol68/execute/serial-clause-10.a68 new file mode 100644 index 000000000000..294fc6c7295e --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-clause-10.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# NIL is not voided and can appear in a context requiring VOID. # +BEGIN (NIL); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/serial-clause-2.a68 b/gcc/testsuite/algol68/execute/serial-clause-2.a68 new file mode 100644 index 000000000000..e333c5c22319 --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-clause-2.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN BEGIN ASSERT (i = 0); + i + END; + INT i = 10; + ASSERT (i = 10) +END diff --git a/gcc/testsuite/algol68/execute/serial-clause-3.a68 b/gcc/testsuite/algol68/execute/serial-clause-3.a68 new file mode 100644 index 000000000000..821c4dc9a79d --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-clause-3.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (i = 0); + INT i = 10; + ASSERT (i = 10) +END diff --git a/gcc/testsuite/algol68/execute/serial-clause-4.a68 b/gcc/testsuite/algol68/execute/serial-clause-4.a68 new file mode 100644 index 000000000000..2a03f65a8a1c --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-clause-4.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i := 10; + BEGIN ASSERT (i = 10); + i +:= 1 + END; + ASSERT (i = 11) +END diff --git a/gcc/testsuite/algol68/execute/serial-clause-5.a68 b/gcc/testsuite/algol68/execute/serial-clause-5.a68 new file mode 100644 index 000000000000..89ab26e38f91 --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-clause-5.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN BEGIN ASSERT (i = 0); + i + END; + INT i := 10; + ASSERT (i = 10) +END diff --git a/gcc/testsuite/algol68/execute/serial-clause-6.a68 b/gcc/testsuite/algol68/execute/serial-clause-6.a68 new file mode 100644 index 000000000000..13a132f404c3 --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-clause-6.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT ((INT y := 10; + INT x := 20; + REF INT yy; + (REF INT xx := x; + yy := y; + xx := yy + ) + ) = 10) +END diff --git a/gcc/testsuite/algol68/execute/serial-clause-7.a68 b/gcc/testsuite/algol68/execute/serial-clause-7.a68 new file mode 100644 index 000000000000..a33da4adea44 --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-clause-7.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT ((INT y := 10; + INT x := 20; + REF INT yy; + (REF INT xx := x; + yy := y; + xx + yy + ) + ) = 30) +END diff --git a/gcc/testsuite/algol68/execute/serial-clause-8.a68 b/gcc/testsuite/algol68/execute/serial-clause-8.a68 new file mode 100644 index 000000000000..9d32e85285c3 --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-clause-8.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT ((INT y := 10; + INT x := 20; + REF INT yy; + (REF INT xx := x; + yy := y; + xx + ) + ) = 20) +END diff --git a/gcc/testsuite/algol68/execute/serial-clause-9.a68 b/gcc/testsuite/algol68/execute/serial-clause-9.a68 new file mode 100644 index 000000000000..d8fe7c4d40d9 --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-clause-9.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +# Serial clause with jump at the end. # + +BEGIN INT i := BEGIN BOOL cont := TRUE; + back: cont := FALSE; + IF cont THEN GOTO back FI + END; + ASSERT (i = 0) +END diff --git a/gcc/testsuite/algol68/execute/serial-dsa-1.a68 b/gcc/testsuite/algol68/execute/serial-dsa-1.a68 new file mode 100644 index 000000000000..b27ad8c7793a --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-dsa-1.a68 @@ -0,0 +1,18 @@ +{ This tests stack management for DSA serial clauses. + If it fails a stack overflow happens. } +begin { DSA due to stack allocated multiple. } + to 10000 + do [10000]int foo; + skip + od; + { DSA due to stack allocated multiple. Explicit loc. } + to 10000 + do loc[10000]int foo; + skip + od; + { DSA due to loc generator. } + to 10000 + do ref[]int jorl = loc [10000]int; + skip + od +end diff --git a/gcc/testsuite/algol68/execute/serial-dsa-2.a68 b/gcc/testsuite/algol68/execute/serial-dsa-2.a68 new file mode 100644 index 000000000000..ca8594d29c86 --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-dsa-2.a68 @@ -0,0 +1,6 @@ +{ Check value yielding of DSA serial clauses. } +begin assert ((ref int foo = loc int := 100; + foo) = 100); + []int a = ([10000]int foo; foo[10] := 666; foo); + assert (a[10] = 666) +end diff --git a/gcc/testsuite/algol68/execute/serial-dsa-3.a68 b/gcc/testsuite/algol68/execute/serial-dsa-3.a68 new file mode 100644 index 000000000000..7cb96dde3c6c --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-dsa-3.a68 @@ -0,0 +1,12 @@ +{ The jump to leak should not leak stack. } +begin by 10000 + do + by 10000 + do [10000]int foo; + skip; + goto leak + od; + leak: + skip + od +end diff --git a/gcc/testsuite/algol68/execute/serial-dsa-4.a68 b/gcc/testsuite/algol68/execute/serial-dsa-4.a68 new file mode 100644 index 000000000000..b132af8ba1de --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-dsa-4.a68 @@ -0,0 +1,4 @@ +begin (ref int a = loc int := 10; goto leak; a); +leak: + skip +end diff --git a/gcc/testsuite/algol68/execute/serial-dsa-5.a68 b/gcc/testsuite/algol68/execute/serial-dsa-5.a68 new file mode 100644 index 000000000000..fb57d5ef1e54 --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-dsa-5.a68 @@ -0,0 +1,3 @@ +begin assert ((ref int a = loc int := 10; a) + 1 = 11); + skip +end diff --git a/gcc/testsuite/algol68/execute/serial-dsa-6.a68 b/gcc/testsuite/algol68/execute/serial-dsa-6.a68 new file mode 100644 index 000000000000..fb17d2d64428 --- /dev/null +++ b/gcc/testsuite/algol68/execute/serial-dsa-6.a68 @@ -0,0 +1,4 @@ +{ DSA and completers in a serial clause. } +begin assert ((ref int a = loc int := 10; a exit foo: a +:= 1) + 1 = 11); + skip +end diff --git a/gcc/testsuite/algol68/execute/sign-int-1.a68 b/gcc/testsuite/algol68/execute/sign-int-1.a68 new file mode 100644 index 000000000000..3c6d317e0634 --- /dev/null +++ b/gcc/testsuite/algol68/execute/sign-int-1.a68 @@ -0,0 +1,28 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT zero = 0; + SHORT INT short zero = SHORT 0; + SHORT SHORT INT short short zero = SHORT SHORT 0; + LONG INT long zero = LONG 0; + LONG LONG INT long long zero = LONG LONG 0; + INT ten = 10; + SHORT INT short ten = SHORT 10; + SHORT SHORT INT short short ten = SHORT SHORT 10; + LONG INT long ten = LONG 10; + LONG LONG INT long long ten = LONG LONG 10; + ASSERT (SIGN zero = 0); + ASSERT (SIGN short zero = 0); + ASSERT (SIGN short short zero = 0); + ASSERT (SIGN long zero = 0); + ASSERT (SIGN long long zero = 0); + ASSERT (SIGN ten = 1); + ASSERT (SIGN short ten = 1); + ASSERT (SIGN short short ten = 1); + ASSERT (SIGN long ten = 1); + ASSERT (SIGN long long ten = 1); + ASSERT (SIGN -ten = -1); + ASSERT (SIGN -short ten = -1); + ASSERT (SIGN -short short ten = -1); + ASSERT (SIGN -long ten = -1); + ASSERT (SIGN -long long ten = -1) +END + diff --git a/gcc/testsuite/algol68/execute/sign-real-1.a68 b/gcc/testsuite/algol68/execute/sign-real-1.a68 new file mode 100644 index 000000000000..f15fe963c23e --- /dev/null +++ b/gcc/testsuite/algol68/execute/sign-real-1.a68 @@ -0,0 +1,17 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL zero = 0.0; + LONG REAL long zero = LONG 0.0; + LONG LONG REAL long long zero = LONG LONG 0.0; + REAL ten = 10.0; + LONG REAL long ten = LONG 10.0; + LONG LONG REAL long long ten = LONG LONG 10.0; + ASSERT (SIGN zero = 0); + ASSERT (SIGN long zero = 0); + ASSERT (SIGN long long zero = 0); + ASSERT (SIGN ten = 1); + ASSERT (SIGN long ten = 1); + ASSERT (SIGN long long ten = 1); + ASSERT (SIGN -ten = -1); + ASSERT (SIGN -long ten = -1); + ASSERT (SIGN -long long ten = -1) +END diff --git a/gcc/testsuite/algol68/execute/sin-1.a68 b/gcc/testsuite/algol68/execute/sin-1.a68 new file mode 100644 index 000000000000..aac74f98b02f --- /dev/null +++ b/gcc/testsuite/algol68/execute/sin-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r = 0.0; + LONG REAL rr = LONG 45.0; + LONG LONG REAL rrr = LONG LONG 60.0; + ASSERT (sin (r) = 0.0); + long sin (rr); + long long sin (rrr) +END diff --git a/gcc/testsuite/algol68/execute/skip-1.a68 b/gcc/testsuite/algol68/execute/skip-1.a68 new file mode 100644 index 000000000000..a36de4ff6a4d --- /dev/null +++ b/gcc/testsuite/algol68/execute/skip-1.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +# Check SKIPs for INT modes # +BEGIN INT int skip = SKIP; + ASSERT (int skip = 0); + SHORT INT short int skip = SKIP; + ASSERT (short int skip = SHORT 0); + SHORT SHORT INT short short int skip = SKIP; + ASSERT (short short int skip = SHORT SHORT 0); + LONG INT long int skip = SKIP; + ASSERT (long int skip = LONG 0); + LONG LONG INT long long int skip = SKIP; + ASSERT (long long int skip = LONG LONG 0) +END diff --git a/gcc/testsuite/algol68/execute/skip-2.a68 b/gcc/testsuite/algol68/execute/skip-2.a68 new file mode 100644 index 000000000000..5cefe400b9c3 --- /dev/null +++ b/gcc/testsuite/algol68/execute/skip-2.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# Check SKIP values for BOOL and CHAR. # +BEGIN BOOL bool skip = SKIP; + ASSERT (bool skip = FALSE); + CHAR char skip = SKIP; + ASSERT (char skip = " ") +END diff --git a/gcc/testsuite/algol68/execute/skip-struct-1.a68 b/gcc/testsuite/algol68/execute/skip-struct-1.a68 new file mode 100644 index 000000000000..72e9a1137e6e --- /dev/null +++ b/gcc/testsuite/algol68/execute/skip-struct-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE INCOME = STRUCT (REAL salary, stock, INT jorl); + MODE PERSON = STRUCT (INT age, INCOME income, INT num children); + PERSON person = SKIP; + ASSERT (age OF person = 0); + ASSERT (jorl OF income OF person = 0) +END diff --git a/gcc/testsuite/algol68/execute/slice-indexing-1.a68 b/gcc/testsuite/algol68/execute/slice-indexing-1.a68 new file mode 100644 index 000000000000..53d14fa982fe --- /dev/null +++ b/gcc/testsuite/algol68/execute/slice-indexing-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING foo = "foo"; + ASSERT (foo[1] = "f"); + ASSERT (foo[2] = "o"); + ASSERT (foo[3] = "o"); + STRING bar := "foo"; + ASSERT (bar[1] = "f"); + ASSERT (bar[2] = "o"); + ASSERT (bar[3] = "o") +END diff --git a/gcc/testsuite/algol68/execute/slice-indexing-2.a68 b/gcc/testsuite/algol68/execute/slice-indexing-2.a68 new file mode 100644 index 000000000000..defb675d3a32 --- /dev/null +++ b/gcc/testsuite/algol68/execute/slice-indexing-2.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT foo = (1,2,3); + ASSERT (foo[1] = 1); + ASSERT (foo[2] = 2); + ASSERT (foo[3] = 3); + [3]INT bar := (1,2,3); + ASSERT (bar[1] = 1); + ASSERT (bar[2] = 2); + ASSERT (bar[3] = 3) +END diff --git a/gcc/testsuite/algol68/execute/slice-indexing-3.a68 b/gcc/testsuite/algol68/execute/slice-indexing-3.a68 new file mode 100644 index 000000000000..593bd71766eb --- /dev/null +++ b/gcc/testsuite/algol68/execute/slice-indexing-3.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT foo = (10,20,30); + ASSERT (foo[1] = 10); + ASSERT (foo[2] = 20); + ASSERT (foo[3] = 30); + [3]INT bar := (100,200,300); + ASSERT (bar[1] = 100); + ASSERT (bar[2] = 200); + ASSERT (bar[3] = 300) +END diff --git a/gcc/testsuite/algol68/execute/slice-indexing-4.a68 b/gcc/testsuite/algol68/execute/slice-indexing-4.a68 new file mode 100644 index 000000000000..bf3a3b18d70e --- /dev/null +++ b/gcc/testsuite/algol68/execute/slice-indexing-4.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE PERSON = STRUCT (INT i, STRING s); + []PERSON persons = ((10, "foo"), (20, "barbar"), (30, "baz")); + puts (s OF persons[1]); + puts (s OF persons[2]); + puts (s OF persons[3]); + ASSERT (i OF persons[1] = 10); + ASSERT (i OF persons[2] = 20); + ASSERT (i OF persons[3] = 30) +END diff --git a/gcc/testsuite/algol68/execute/slice-indexing-5.a68 b/gcc/testsuite/algol68/execute/slice-indexing-5.a68 new file mode 100644 index 000000000000..f236eeffd155 --- /dev/null +++ b/gcc/testsuite/algol68/execute/slice-indexing-5.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRUCT([]INT i, REAL r) s = ((1,2,3), 3.14); + ASSERT ((i OF s)[1] = 1) +END diff --git a/gcc/testsuite/algol68/execute/slice-indexing-6.a68 b/gcc/testsuite/algol68/execute/slice-indexing-6.a68 new file mode 100644 index 000000000000..8d795560deed --- /dev/null +++ b/gcc/testsuite/algol68/execute/slice-indexing-6.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT rsp := 5; + [10]INT run stack; + run stack [(rsp -:= 1) + 1] +END diff --git a/gcc/testsuite/algol68/execute/slice-indexing-7.a68 b/gcc/testsuite/algol68/execute/slice-indexing-7.a68 new file mode 100644 index 000000000000..d3870f6119f9 --- /dev/null +++ b/gcc/testsuite/algol68/execute/slice-indexing-7.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING s := "foo"; + s[2] := "x" +END diff --git a/gcc/testsuite/algol68/execute/sqrt-1.a68 b/gcc/testsuite/algol68/execute/sqrt-1.a68 new file mode 100644 index 000000000000..725a7727112e --- /dev/null +++ b/gcc/testsuite/algol68/execute/sqrt-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r = 100.0; + LONG REAL rr = LONG 25.0; + LONG LONG REAL rrr = LONG LONG 25.0; + ASSERT (sqrt (r) = 10.0); + ASSERT (long sqrt (rr) = LONG 5.0); + ASSERT (long long sqrt (rrr) = LONG LONG 5.0) +END diff --git a/gcc/testsuite/algol68/execute/string-1.a68 b/gcc/testsuite/algol68/execute/string-1.a68 new file mode 100644 index 000000000000..28e44fe18fef --- /dev/null +++ b/gcc/testsuite/algol68/execute/string-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING s = ""; + ASSERT (LWB s = 1 AND UPB s = 0); + STRING t = (); + ASSERT (LWB t = 1 AND UPB t = 0) +END diff --git a/gcc/testsuite/algol68/execute/string-2.a68 b/gcc/testsuite/algol68/execute/string-2.a68 new file mode 100644 index 000000000000..b0b898a51ef1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/string-2.a68 @@ -0,0 +1,13 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING s; + ASSERT (LWB s = 1 AND UPB s = 0 AND ELEMS s = 0); + s := "foo"; + puts (s); + ASSERT (LWB s = 1 AND UPB s = 3 AND s[1] = "f" AND s[2] = "o" AND s[3] = "o"); + s := "bar"; + puts (s); + ASSERT (LWB s = 1 AND UPB s = 3 AND s[1] = "b" AND s[2] = "a" AND s[3] = "r"); + s := "x"; + ASSERT (LWB s = 1 AND UPB s = 1 AND s[1] = "x"); + puts (s) +END diff --git a/gcc/testsuite/algol68/execute/string-4.a68 b/gcc/testsuite/algol68/execute/string-4.a68 new file mode 100644 index 000000000000..984d6625d909 --- /dev/null +++ b/gcc/testsuite/algol68/execute/string-4.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING s; + ASSERT (LWB s = 1 AND UPB s = 0 AND ELEMS s = 0); + s +:= "foo"; + ASSERT (LWB s = 1 AND UPB s = 3 AND ELEMS s = 3) +END diff --git a/gcc/testsuite/algol68/execute/string-break-1.a68 b/gcc/testsuite/algol68/execute/string-break-1.a68 new file mode 100644 index 000000000000..e99cfe9ebad4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/string-break-1.a68 @@ -0,0 +1,8 @@ +begin assert (UPB "foo'nbar" = 7 AND "foo'nbar"[4] = REPR 10); + assert (UPB "foo'tbar" = 7 AND "foo'tbar"[4] = REPR 9); + assert (UPB "foo'rbar" = 7 AND "foo'rbar"[4] = REPR 13); + assert (UPB "foo'fbar" = 7 AND "foo'fbar"[4] = REPR 12); + assert (UPB "foo''bar" = 7 AND "foo''bar"[4] = REPR 39); + assert ("'(u0048,u0065,U0000006c,u006c,U0000006f)" = "Hello"); + assert ("'( u0048, u0065, U0000006c,u006c, U0000006f )" = "Hello") +end diff --git a/gcc/testsuite/algol68/execute/struct-self-1.a68 b/gcc/testsuite/algol68/execute/struct-self-1.a68 new file mode 100644 index 000000000000..94622aaecd27 --- /dev/null +++ b/gcc/testsuite/algol68/execute/struct-self-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE NODE = STRUCT (INT code, REF NODE next); + NODE top; + ASSERT (next OF top :=: REF NODE (NIL)) +END diff --git a/gcc/testsuite/algol68/execute/struct-self-2.a68 b/gcc/testsuite/algol68/execute/struct-self-2.a68 new file mode 100644 index 000000000000..a1127ebf3b8a --- /dev/null +++ b/gcc/testsuite/algol68/execute/struct-self-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE NODE = STRUCT (INT code, REF NODE next); + NODE top = (20, NIL); + ASSERT (code OF top = 20); + ASSERT (next OF top :=: NIL) +END diff --git a/gcc/testsuite/algol68/execute/struct-self-3.a68 b/gcc/testsuite/algol68/execute/struct-self-3.a68 new file mode 100644 index 000000000000..3829daf68481 --- /dev/null +++ b/gcc/testsuite/algol68/execute/struct-self-3.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE NODE = STRUCT (INT code, REF NODE next); + NODE top := (10, NIL); + NODE next := (20, NIL); + next OF top := next; + ASSERT (code OF next OF top = 20) +END diff --git a/gcc/testsuite/algol68/execute/structure-display-1.a68 b/gcc/testsuite/algol68/execute/structure-display-1.a68 new file mode 100644 index 000000000000..a53c247e1af1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/structure-display-1.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE INCOME = STRUCT (REAL salary, stock, INT code); + MODE PERSON = STRUCT (INT age, INCOME income, INT num children); + INCOME income = (100.0, 200.0, 300); + ASSERT (code OF income = 300); + PERSON person := (24, (1000.0, 2000.0, 3000), 3); + ASSERT (code OF income OF person = 3000); + ASSERT (num children OF person = 3) +END diff --git a/gcc/testsuite/algol68/execute/structure-display-2.a68 b/gcc/testsuite/algol68/execute/structure-display-2.a68 new file mode 100644 index 000000000000..563f979e3218 --- /dev/null +++ b/gcc/testsuite/algol68/execute/structure-display-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE NODE = STRUCT (INT code, REF INT next); + INT val := 20; + NODE top = (10, val); + ASSERT (val = 20) +END diff --git a/gcc/testsuite/algol68/execute/structure-display-3.a68 b/gcc/testsuite/algol68/execute/structure-display-3.a68 new file mode 100644 index 000000000000..178463f60dc8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/structure-display-3.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE FOO = STRUCT (INT i, REF INT j); + INT x := 10; + FOO foo; + foo := (10, x); + ASSERT (j OF foo = 10) +END diff --git a/gcc/testsuite/algol68/execute/structure-display-4.a68 b/gcc/testsuite/algol68/execute/structure-display-4.a68 new file mode 100644 index 000000000000..2a69172b8805 --- /dev/null +++ b/gcc/testsuite/algol68/execute/structure-display-4.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE FOO = STRUCT (INT i, REF INT j); + INT x := 10; + REF INT xx; + FOO foo; + foo := (10, xx := x); + ASSERT (j OF foo = 10) +END diff --git a/gcc/testsuite/algol68/execute/structure-display-5.a68 b/gcc/testsuite/algol68/execute/structure-display-5.a68 new file mode 100644 index 000000000000..0b99113f160c --- /dev/null +++ b/gcc/testsuite/algol68/execute/structure-display-5.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE VEC = STRUCT (REAL xcoord, ycoord, zcoord); + VEC v1, v2, v3; + v1 := (1,1,1); + ASSERT (xcoord OF v1 = 1); + ASSERT (ycoord OF v1 = 1); + ASSERT (zcoord OF v1 = 1); + REAL x = 3.14, i = 3; + v2 := (x + 2, 3.4, i - 3) +END diff --git a/gcc/testsuite/algol68/execute/tan-1.a68 b/gcc/testsuite/algol68/execute/tan-1.a68 new file mode 100644 index 000000000000..a7aede697498 --- /dev/null +++ b/gcc/testsuite/algol68/execute/tan-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REAL r = 0.0; + LONG REAL rr = LONG 50.0; + LONG LONG REAL rrr = LONG LONG 50.0; + ASSERT (tan (r) = 0.0); + long tan (rr); + long long tan (rrr) +END diff --git a/gcc/testsuite/algol68/execute/timesab-string-1.a68 b/gcc/testsuite/algol68/execute/timesab-string-1.a68 new file mode 100644 index 000000000000..3ff48fe91f53 --- /dev/null +++ b/gcc/testsuite/algol68/execute/timesab-string-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN STRING foo := "foo"; + foo TIMESAB 1; + ASSERT (foo = "foo"); + foo *:= 3; + ASSERT (foo = "foofoofoo") +END diff --git a/gcc/testsuite/algol68/execute/trimmer-1.a68 b/gcc/testsuite/algol68/execute/trimmer-1.a68 new file mode 100644 index 000000000000..feae4cefb786 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [2:4]INT arr := []INT(1,2,3)[@2]; + ASSERT (arr[3] = 2 AND arr[4] = 3); + []INT jorl = arr[2:3@20]; + ASSERT (LWB jorl = 20 AND UPB jorl = 21); + ASSERT (jorl[20] = 1 AND jorl [21] = 2) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-10.a68 b/gcc/testsuite/algol68/execute/trimmer-10.a68 new file mode 100644 index 000000000000..66db83af5fb6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-10.a68 @@ -0,0 +1,14 @@ +# { dg-options "-fstropping=upper" } # +# Trimming with flat descriptors should lead to flat multiples. # +BEGIN []INT a = (1,2,3); + + ASSERT (UPB a[2:1] < LWB a[2:1]); + ASSERT (UPB a[20:2] < LWB a[20:2]); + + [,]INT aa = ((1,2,3), + (4,5,6), + (7,8,9)); + + ASSERT ((1 UPB aa[1,2:1]) < ((1 LWB aa[1,2:1]))); + ASSERT ((1 UPB aa[1,20:]) < ((1 LWB aa[1,20:]))) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-2.a68 b/gcc/testsuite/algol68/execute/trimmer-2.a68 new file mode 100644 index 000000000000..68996d22bc16 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-2.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [2:4]INT arr := []INT(1,2,3)[@2]; + ASSERT (arr[3] = 2 AND arr[4] = 3); + []INT jorl = arr[2:3]; + ASSERT (LWB jorl = 1 AND UPB jorl = 2); + ASSERT (jorl[1] = 1 AND jorl [2] = 2) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-3.a68 b/gcc/testsuite/algol68/execute/trimmer-3.a68 new file mode 100644 index 000000000000..8af69db6b8df --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-3.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [2:4]INT arr := []INT(1,2,3)[@2]; + ASSERT (arr[3] = 2 AND arr[4] = 3); + []INT jorl = arr[:@20]; + ASSERT (LWB jorl = 20 AND UPB jorl = 22); + ASSERT (jorl[20] = 1 AND jorl[21] = 2 AND jorl[22] = 3) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-4.a68 b/gcc/testsuite/algol68/execute/trimmer-4.a68 new file mode 100644 index 000000000000..fdcd37094d68 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-4.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [2:4]INT arr := []INT(1,2,3)[@2]; + ASSERT (arr[3] = 2 AND arr[4] = 3); + []INT jorl = arr[3:]; + ASSERT (LWB jorl = 1 AND UPB jorl = 2); + ASSERT (jorl[1] = 2 AND jorl[2] = 3) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-5.a68 b/gcc/testsuite/algol68/execute/trimmer-5.a68 new file mode 100644 index 000000000000..892fea7d2697 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-5.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [2:4]INT arr := []INT(1,2,3)[@2]; + ASSERT (arr[3] = 2 AND arr[4] = 3); + []INT jorl = arr[:3 AT 10]; + ASSERT (LWB jorl = 10 AND UPB jorl = 11); + ASSERT (jorl[10] = 1 AND jorl[11] = 2) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-6.a68 b/gcc/testsuite/algol68/execute/trimmer-6.a68 new file mode 100644 index 000000000000..3e9f293e0159 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-6.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [2:4]INT arr := []INT(1,2,3)[@2]; + ASSERT (arr[3] = 2 AND arr[4] = 3); + []INT jorl = arr[:3@10]; + ASSERT (LWB jorl = 10 AND UPB jorl = 11); + ASSERT (jorl[10] = 1 AND jorl[11] = 2) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-7.a68 b/gcc/testsuite/algol68/execute/trimmer-7.a68 new file mode 100644 index 000000000000..8d3ebf9293f1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-7.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT arr = (1,2,3); + ASSERT (arr[2] = 2 AND arr[3] = 3); + []INT jorl = arr[2:3@20]; + ASSERT (LWB jorl = 20 AND UPB jorl = 21); + ASSERT (jorl[20] = 2 AND jorl [21] = 3) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-8.a68 b/gcc/testsuite/algol68/execute/trimmer-8.a68 new file mode 100644 index 000000000000..50842efb27e6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-8.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [2:4]INT arr := []INT(1,2,3)[@2]; + ASSERT (arr[3] = 2 AND arr[4] = 3); + [10:11]INT jorl := arr[:3 AT 10]; + ASSERT (LWB jorl = 10 AND UPB jorl = 11); + ASSERT (jorl[10] = 1 AND jorl[11] = 2); + jorl[10] := 100; + ASSERT (jorl[10] = 100 AND jorl[11] = 2) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-9.a68 b/gcc/testsuite/algol68/execute/trimmer-9.a68 new file mode 100644 index 000000000000..aa0d52d2a086 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-9.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT arr = (1,2,3); + ASSERT (arr[2] = 2 AND arr[3] = 3); + []INT jorl = arr[@20]; + ASSERT (LWB jorl = 20 AND UPB jorl = 22); + ASSERT (jorl[20] = 1 AND jorl [21] = 2 AND jorl [22] = 3) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-1.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-1.a68 new file mode 100644 index 000000000000..2cec8a858e71 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-matrix-1.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]INT matrix = ((1,2,3), + (4,5,6), + (7,8,9)); + [2]INT column := matrix[3,2:3]; + ASSERT (column[1] = 8); + ASSERT (column[2] = 9) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-2.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-2.a68 new file mode 100644 index 000000000000..6ca961fe1be6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-matrix-2.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]INT matrix = ((1,2,3), + (4,5,6), + (7,8,9)); + [2]INT column := matrix[2,1:2]; + ASSERT (column[1] = 4); + ASSERT (column[2] = 5) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-3.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-3.a68 new file mode 100644 index 000000000000..5de2bee3a37b --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-matrix-3.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]INT matrix = ((1,2,3), + (4,5,6), + (7,8,9)); + [3]INT column := matrix[2,1:3]; + ASSERT (column[1] = 4); + ASSERT (column[2] = 5); + ASSERT (column[3] = 6) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-4.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-4.a68 new file mode 100644 index 000000000000..71168ad6df84 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-matrix-4.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]INT matrix = ((1,2,3), + (4,5,6), + (7,8,9)); + []INT column = matrix[1:3,2]; + ASSERT (LWB column = 1); + ASSERT (UPB column = 3); + ASSERT (column[1] = 2 AND column[2] = 5 AND column[3] = 8) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-5.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-5.a68 new file mode 100644 index 000000000000..6d5f69bc53ea --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-matrix-5.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]INT matrix = ((1,2,3), + (4,5,6), + (7,8,9)); + []INT column = matrix[2:3,2]; + ASSERT (LWB column = 1); + ASSERT (UPB column = 2); + ASSERT (column[1] = 5 AND column[2] = 8) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-6.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-6.a68 new file mode 100644 index 000000000000..59a33896bf61 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-matrix-6.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [,]INT matrix = ((1,2,3), + (4,5,6), + (7,8,9)); + []INT row = matrix[3,1:3]; + ASSERT (LWB row = 1); + ASSERT (UPB row = 3); + ASSERT (row[1] = 7 AND row[2] = 8 AND row[3] = 9) +END diff --git a/gcc/testsuite/algol68/execute/trimmer-name-1.a68 b/gcc/testsuite/algol68/execute/trimmer-name-1.a68 new file mode 100644 index 000000000000..6b4601c64c73 --- /dev/null +++ b/gcc/testsuite/algol68/execute/trimmer-name-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +BEGIN REF[]CHAR t; + PROC foo = VOID: (HEAP[3]CHAR ss := ("1","2","3"); t := ss[1:3]); + foo; + ASSERT (LWB t = 1 AND UPB t = 3); + ASSERT (t[1] = "1" AND t[2] = "2" AND t[3] = "3") +END diff --git a/gcc/testsuite/algol68/execute/undefined-1.a68 b/gcc/testsuite/algol68/execute/undefined-1.a68 new file mode 100644 index 000000000000..af97a0c0e837 --- /dev/null +++ b/gcc/testsuite/algol68/execute/undefined-1.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +# j's value is undefined (defined to be 0 in GNU Algol) # +BEGIN INT x := 0; + FOR i TO 5 + DO ASSERT (j = 0); + IF j > 20 THEN stop FI; + INT j = x + i; + x +:= 1 + OD +END diff --git a/gcc/testsuite/algol68/execute/undefined-2.a68 b/gcc/testsuite/algol68/execute/undefined-2.a68 new file mode 100644 index 000000000000..54addde1fd00 --- /dev/null +++ b/gcc/testsuite/algol68/execute/undefined-2.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +# The undefined value of the multiple `a' is an empty multiple. # +BEGIN ASSERT (i = 0); + ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0); + []INT a = (1, 2, 3); + INT i = 10; + ASSERT (i = 10); + ASSERT (LWB a = 1 AND UPB a = 3 AND ELEMS a = 3) +END diff --git a/gcc/testsuite/algol68/execute/undefined-3.a68 b/gcc/testsuite/algol68/execute/undefined-3.a68 new file mode 100644 index 000000000000..2a746ad7eb44 --- /dev/null +++ b/gcc/testsuite/algol68/execute/undefined-3.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (sum = 1); + PROC sum = INT: i + 1; + INT i = 10; + ASSERT (sum = 11) +END diff --git a/gcc/testsuite/algol68/execute/undefined-4.a68 b/gcc/testsuite/algol68/execute/undefined-4.a68 new file mode 100644 index 000000000000..c602c052bfc8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/undefined-4.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC is even = (INT n) BOOL: (n = zero | TRUE | is odd (n - 1)); + PROC is odd = (INT n) BOOL: (n = zero | FALSE | is even (n - 1)); + ASSERT (is even (20)); + ASSERT (is odd (13)); + INT zero := 0; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/undefined-5.a68 b/gcc/testsuite/algol68/execute/undefined-5.a68 new file mode 100644 index 000000000000..3cbb41416d27 --- /dev/null +++ b/gcc/testsuite/algol68/execute/undefined-5.a68 @@ -0,0 +1,9 @@ +# { dg-options "-fstropping=upper" } # +BEGIN PROC is even = (INT n) BOOL: (n = zero | TRUE | is odd (DECR n)); + PROC is odd = (INT n) BOOL: (n = zero | FALSE | is even (DECR n)); + OP DECR = (INT a) INT: a - 1; + ASSERT (is even (20)); + ASSERT (is odd (13)); + INT zero := 0; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/uniting-1.a68 b/gcc/testsuite/algol68/execute/uniting-1.a68 new file mode 100644 index 000000000000..dee0b50b282f --- /dev/null +++ b/gcc/testsuite/algol68/execute/uniting-1.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN UNION(INT,REAL,CHAR) datum := 3.14; + UNION(INT,REAL,[]INT,CHAR) datux; + datux := datum; + ASSERT (CASE datux + IN (INT): 10, + (REAL): 20, + (CHAR c): 30 + ESAC = 20); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/uniting-2.a68 b/gcc/testsuite/algol68/execute/uniting-2.a68 new file mode 100644 index 000000000000..565005010e31 --- /dev/null +++ b/gcc/testsuite/algol68/execute/uniting-2.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN UNION(INT,REAL,CHAR) datum := "X"; + UNION(INT,REAL,[]INT,CHAR) datux; + datux := datum; + ASSERT (CASE datux + IN (INT): 10, + (REAL): 20, + (CHAR c): 30 + ESAC = 30); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/uniting-3.a68 b/gcc/testsuite/algol68/execute/uniting-3.a68 new file mode 100644 index 000000000000..cb73c2f85317 --- /dev/null +++ b/gcc/testsuite/algol68/execute/uniting-3.a68 @@ -0,0 +1,11 @@ +# { dg-options "-fstropping=upper" } # +BEGIN UNION(INT,REAL,CHAR) datum := 10; + UNION(INT,REAL,[]INT,CHAR) datux; + datux := datum; + ASSERT (CASE datux + IN (INT): 10, + (REAL): 20, + (CHAR c): 30 + ESAC = 10); + SKIP +END diff --git a/gcc/testsuite/algol68/execute/uniting-4.a68 b/gcc/testsuite/algol68/execute/uniting-4.a68 new file mode 100644 index 000000000000..c7b82b8310c4 --- /dev/null +++ b/gcc/testsuite/algol68/execute/uniting-4.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +# Uniting STRING to ROWS. # +BEGIN PROC strlen = (STRING s) INT: ELEMS s; + ASSERT (strlen ("foo") = 3) +END diff --git a/gcc/testsuite/algol68/execute/up-down-bits-1.a68 b/gcc/testsuite/algol68/execute/up-down-bits-1.a68 new file mode 100644 index 000000000000..b13c05599e58 --- /dev/null +++ b/gcc/testsuite/algol68/execute/up-down-bits-1.a68 @@ -0,0 +1,33 @@ +# { dg-options "-fstropping=upper" } # +# SHORTEN and LENG on SIZETY BITS # +BEGIN BITS b = 16rff; + ASSERT (b UP 4 = 16rff0); + ASSERT (b SHL 4 = 16rff0); + ASSERT (b DOWN 4 = 16r0f); + ASSERT (b SHR 4 = 16r0f); + + LONG BITS bb = LONG 16rff; + ASSERT (bb UP 4 = LONG 16rff0); + ASSERT (bb SHL 4 = LONG 16rff0); + ASSERT (bb DOWN 4 = LONG 16r0f); + ASSERT (bb SHR 4 = LONG 16r0f); + + LONG LONG BITS bbb = LONG LONG 16rff; + ASSERT (bbb UP 4 = LONG LONG 16rff0); + ASSERT (bbb SHL 4 = LONG LONG 16rff0); + ASSERT (bbb DOWN 4 = LONG LONG 16r0f); + ASSERT (bbb SHR 4 = LONG LONG 16r0f); + + SHORT BITS ss = SHORT 16rff; + ASSERT (ss UP 4 = SHORT 16rff0); + ASSERT (ss SHL 4 = SHORT 16rff0); + ASSERT (ss DOWN 4 = SHORT 16r0f); + ASSERT (ss SHR 4 = SHORT 16r0f); + + SHORT SHORT BITS sss = SHORT SHORT 16r0f; + ASSERT (sss UP 4 = SHORT SHORT 16rf0); + ASSERT (sss SHL 4 = SHORT SHORT 16rf0); + ASSERT (sss DOWN 2 = SHORT SHORT 16r03); + ASSERT (sss SHR 2 = SHORT SHORT 16r03) +END + diff --git a/gcc/testsuite/algol68/execute/upb-1.a68 b/gcc/testsuite/algol68/execute/upb-1.a68 new file mode 100644 index 000000000000..d74ffa5b33b6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/upb-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN ASSERT (UPB "foo" = 3); + ASSERT (1 UPB "foo" = 3); + ASSERT (UPB "" = 0); + ASSERT ((INT i = 1; UPB "") = 0) +END diff --git a/gcc/testsuite/algol68/execute/vacuum-1.a68 b/gcc/testsuite/algol68/execute/vacuum-1.a68 new file mode 100644 index 000000000000..c4472c53c1fe --- /dev/null +++ b/gcc/testsuite/algol68/execute/vacuum-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN []INT a = (); + ASSERT (LWB a = 1 AND UPB a = 0) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-1.a68 b/gcc/testsuite/algol68/execute/variable-declaration-1.a68 new file mode 100644 index 000000000000..0b1f4fce83b6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx := x := 20; + ASSERT (xx = 20) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-2.a68 b/gcc/testsuite/algol68/execute/variable-declaration-2.a68 new file mode 100644 index 000000000000..6b80f7b82147 --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-2.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx := x; + ASSERT (xx = 10) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-3.a68 b/gcc/testsuite/algol68/execute/variable-declaration-3.a68 new file mode 100644 index 000000000000..4b1f08023475 --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-3.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx := (x := 20); + ASSERT (xx = 20) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-4.a68 b/gcc/testsuite/algol68/execute/variable-declaration-4.a68 new file mode 100644 index 000000000000..0c66d9e1fb0d --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-4.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF INT xx := ((x)); + ASSERT (xx = 10) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-5.a68 b/gcc/testsuite/algol68/execute/variable-declaration-5.a68 new file mode 100644 index 000000000000..993bbe7c1fcf --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-5.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT x := 10; + REF REF INT xx := LOC REF INT := x := 20; + ASSERT (xx = 20) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-6.a68 b/gcc/testsuite/algol68/execute/variable-declaration-6.a68 new file mode 100644 index 000000000000..4f8b1c37ec2a --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-6.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN MODE FOO = STRUCT (STRING s, INT i); + FOO f1 := ("foo", 10); + ASSERT (i OF f1 = 10) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-heap-1.a68 b/gcc/testsuite/algol68/execute/variable-declaration-heap-1.a68 new file mode 100644 index 000000000000..e7b40a19a99d --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-heap-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN HEAP INT a := 10; + ASSERT (a = 10) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-heap-2.a68 b/gcc/testsuite/algol68/execute/variable-declaration-heap-2.a68 new file mode 100644 index 000000000000..406e8c570d61 --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-heap-2.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN HEAP INT x, y; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-1.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-1.a68 new file mode 100644 index 000000000000..17864f9293f8 --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-1.a68 @@ -0,0 +1,5 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [10,3]INT arr; + ASSERT (1 LWB arr = 1 AND 1 UPB arr = 10 AND 1 ELEMS arr = 10); + ASSERT (2 LWB arr = 1 AND 2 UPB arr = 3 AND 2 ELEMS arr = 3) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-2.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-2.a68 new file mode 100644 index 000000000000..d400ee87dfd5 --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n = 10; + [n,3]INT arr; + ASSERT (1 LWB arr = 1 AND 1 UPB arr = 10 AND 1 ELEMS arr = 10); + ASSERT (2 LWB arr = 1 AND 2 UPB arr = 3 AND 2 ELEMS arr = 3) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-3.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-3.a68 new file mode 100644 index 000000000000..a006feddce5c --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-3.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := 10, m := 3; + [n,m]INT arr; + ASSERT (1 LWB arr = 1 AND 1 UPB arr = 10 AND 1 ELEMS arr = 10); + ASSERT (2 LWB arr = 1 AND 2 UPB arr = 3 AND 2 ELEMS arr = 3) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-4.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-4.a68 new file mode 100644 index 000000000000..8e0467b965f1 --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-4.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := -4, m := 0; + [n:m,2]INT arr; + ASSERT (1 LWB arr = -4 AND 1 UPB arr = 0 AND 1 ELEMS arr = 5); + ASSERT (2 LWB arr = 1 AND 2 UPB arr = 2 AND 2 ELEMS arr = 2) +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-5.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-5.a68 new file mode 100644 index 000000000000..0a1889f55cc9 --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-5.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := -4, m := 0; + [n:m,2]INT arr; + FOR i FROM 1 LWB arr TO 1 UPB arr + DO FOR j FROM 2 LWB arr TO 2 UPB arr + DO ASSERT (arr[i,j] = INT(SKIP)) OD + OD +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-6.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-6.a68 new file mode 100644 index 000000000000..3dde91c5ffc2 --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-6.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := -4, m := 0; + [n:m,2]REF INT arr; + FOR i FROM 1 LWB arr TO 1 UPB arr + DO FOR j FROM 2 LWB arr TO 2 UPB arr + DO ASSERT (REF INT (arr[i,j]) :=: REF INT(SKIP)) OD + OD +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-7.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-7.a68 new file mode 100644 index 000000000000..75ee9a4516f3 --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-7.a68 @@ -0,0 +1,8 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := 2, m := 3; + [n][m]INT arr; + FOR i FROM LWB arr TO UPB arr + DO FOR j FROM LWB arr[i] TO UPB arr[i] + DO ASSERT (arr[i][j] = INT(SKIP)) OD + OD +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-8.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-8.a68 new file mode 100644 index 000000000000..391d282a9cbb --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-8.a68 @@ -0,0 +1,10 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT n := -4, m := 0; + [10][n:m,2]INT arr; + FOR k FROM LWB arr TO UPB arr + DO FOR i FROM 1 LWB arr[k] TO 1 UPB arr[k] + DO FOR j FROM 2 LWB arr[k] TO 2 UPB arr[k] + DO ASSERT (arr[k][i,j] = INT(SKIP)) OD + OD + OD +END diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-9.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-9.a68 new file mode 100644 index 000000000000..21c20eaed2bd --- /dev/null +++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-9.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN [4]INT x, y; + SKIP +END diff --git a/gcc/testsuite/algol68/execute/voiding-1.a68 b/gcc/testsuite/algol68/execute/voiding-1.a68 new file mode 100644 index 000000000000..ec6088d88fef --- /dev/null +++ b/gcc/testsuite/algol68/execute/voiding-1.a68 @@ -0,0 +1,4 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i; + 2 = i +END diff --git a/gcc/testsuite/algol68/execute/widening-1.a68 b/gcc/testsuite/algol68/execute/widening-1.a68 new file mode 100644 index 000000000000..642b226926e0 --- /dev/null +++ b/gcc/testsuite/algol68/execute/widening-1.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN INT i = 10; + REAL foo = i; + ASSERT (foo > 9.9); + ASSERT (foo < 10.1) +END diff --git a/gcc/testsuite/algol68/execute/widening-2.a68 b/gcc/testsuite/algol68/execute/widening-2.a68 new file mode 100644 index 000000000000..9ac6aae53967 --- /dev/null +++ b/gcc/testsuite/algol68/execute/widening-2.a68 @@ -0,0 +1,6 @@ +# { dg-options "-fstropping=upper" } # +BEGIN LONG INT i = LONG 10; + LONG REAL foo = i; + ASSERT (foo > LONG 9.9); + ASSERT (foo < LONG 10.1) +END diff --git a/gcc/testsuite/algol68/execute/widening-bits-1.a68 b/gcc/testsuite/algol68/execute/widening-bits-1.a68 new file mode 100644 index 000000000000..6940a23cb36e --- /dev/null +++ b/gcc/testsuite/algol68/execute/widening-bits-1.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# XXX use environment enquiry for actual size of BITS # +BEGIN []BOOL foo = 16rffff; + ASSERT (LWB foo = 1 AND UPB foo = 32); + FOR i TO 16 DO ASSERT (foo[i] = FALSE) OD; + FOR i FROM 17 TO 32 DO ASSERT (foo[i] = TRUE) OD +END diff --git a/gcc/testsuite/algol68/execute/widening-bits-2.a68 b/gcc/testsuite/algol68/execute/widening-bits-2.a68 new file mode 100644 index 000000000000..ea47b7051b10 --- /dev/null +++ b/gcc/testsuite/algol68/execute/widening-bits-2.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# XXX use environment enquiry for actual size of LONG BITS # +BEGIN []BOOL foo = LONG 16rffffffff; + ASSERT (LWB foo = 1 AND UPB foo = 64); + FOR i TO 32 DO ASSERT (foo[i] = FALSE) OD; + FOR i FROM 33 TO 64 DO ASSERT (foo[i] = TRUE) OD +END diff --git a/gcc/testsuite/algol68/execute/widening-bits-3.a68 b/gcc/testsuite/algol68/execute/widening-bits-3.a68 new file mode 100644 index 000000000000..61e49da41e4c --- /dev/null +++ b/gcc/testsuite/algol68/execute/widening-bits-3.a68 @@ -0,0 +1,7 @@ +# { dg-options "-fstropping=upper" } # +# XXX use environment enquiry for actual size of LONG LONG BITS # +BEGIN []BOOL foo = LONG LONG 16rffffffff; + ASSERT (LWB foo = 1 AND UPB foo = 64); + FOR i TO 32 DO ASSERT (foo[i] = FALSE) OD; + FOR i FROM 33 TO 64 DO ASSERT (foo[i] = TRUE) OD +END diff --git a/gcc/testsuite/algol68/execute/xor-bits-1.a68 b/gcc/testsuite/algol68/execute/xor-bits-1.a68 new file mode 100644 index 000000000000..beeafb592fb6 --- /dev/null +++ b/gcc/testsuite/algol68/execute/xor-bits-1.a68 @@ -0,0 +1,18 @@ +# { dg-options "-fstropping=upper" } # +# XOR for SIZETY BITS. # +BEGIN BITS b = 16rf0f0; + ASSERT ((b XOR 16r0f0f) = 16rffff); + ASSERT ((b XOR 16r00ff) = 16rf00f); + LONG BITS bb = LONG 16rf0f0; + ASSERT ((bb XOR LONG 16r0f0f) = LONG 16rffff); + ASSERT ((bb XOR LONG 16r00ff) = LONG 16rf00f); + LONG LONG BITS bbb = LONG LONG 16rf0f0; + ASSERT ((bbb XOR LONG LONG 16r0f0f) = LONG LONG 16rffff); + ASSERT ((bbb XOR LONG LONG 16r00ff) = LONG LONG 16rf00f); + SHORT BITS ss = SHORT 16rf0f0; + ASSERT ((ss XOR SHORT 16r0f0f) = SHORT 16rffff); + ASSERT ((ss XOR SHORT 16r00ff) = SHORT 16rf00f); + SHORT SHORT BITS sss = SHORT SHORT 16rf0; + ASSERT ((sss XOR SHORT SHORT 16r0f) = SHORT SHORT 16rff); + ASSERT ((sss XOR SHORT SHORT 16rff) = SHORT SHORT 16r0f) +END diff --git a/gcc/testsuite/c-c++-common/Wstringop-overflow.c b/gcc/testsuite/c-c++-common/Wstringop-overflow.c index 5757a23141ed..9829fe14116f 100644 --- a/gcc/testsuite/c-c++-common/Wstringop-overflow.c +++ b/gcc/testsuite/c-c++-common/Wstringop-overflow.c @@ -90,8 +90,8 @@ void test_strncat (char **d, const char* s, int i) } { - size_t n = i < strlen (s) ? i : strlen (s); /* { dg-message "length computed here" } */ - T (d, s, n); /* { dg-message ".strncat\[^\n\r\]* specified bound depends on the length of the source argument" } */ + size_t n = i < strlen (s) ? i : strlen (s); /* { dg-message "length computed here" "PR122881" { xfail *-*-* } } */ + T (d, s, n); /* { dg-message ".strncat\[^\n\r\]* specified bound depends on the length of the source argument" "PR122881" { xfail *-*-* } } */ } } diff --git a/gcc/testsuite/g++.dg/cpp0x/pr122465.C b/gcc/testsuite/g++.dg/cpp0x/pr122465.C new file mode 100644 index 000000000000..b8de3d417b40 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/pr122465.C @@ -0,0 +1,10 @@ +// PR c++/122465 +// { dg-do compile { target c++11 } } + +void +foo () +{ + int x = 0; + for (const T i = { i } : x) // { dg-error "'T' does not name a type" } + ; +} diff --git a/gcc/testsuite/g++.dg/cpp26/erroneous5.C b/gcc/testsuite/g++.dg/cpp26/erroneous5.C new file mode 100644 index 000000000000..0ee624bda86b --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp26/erroneous5.C @@ -0,0 +1,241 @@ +// C++ 26 P2795R5 - Erroneous behaviour for uninitialized reads +// { dg-do compile } +// { dg-skip-if "" { *-*-* } { "-ftrivial-auto-var-init=*" } { "" } } +// { dg-options "-O2 -fdump-tree-gimple" } +// All the s1..s24 variables and i1 need .DEFERRED_INIT call on their +// declarations. +// Plus, forward gotos to l1 & l2 labels need up to s1-s4 and s6-s9 vars to +// be .DEFERRED_INITed (and backward gotos up to that minus the first two). +// switch to case 15 skips over s12, switch to case 16/17 skip +// over s12 and s13 but the adjacent l3 label needs to also skip over s3-s4 +// and s6-s9 and s11. switch to case 18 skips over s12-s14 and switch to +// default in the same switch skips over s12-s15. +// goto l4; skips over s19 initialization. +// goto l5; skips over s20-s22 initialization. +// switch to case 32/33 skips over s23 but goto to adjacent l6 skips also +// over s20-s22. switch to default in that switch skips over s23-s24. +// { dg-final { scan-tree-dump-times " s1 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s2 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s3 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s4 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s5 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s6 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s7 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s8 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s9 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s10 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s11 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s12 = \.DEFERRED_INIT \\\(" 5 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s13 = \.DEFERRED_INIT \\\(" 4 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s14 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s15 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s16 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s17 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s18 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s19 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s20 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s21 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s22 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s23 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s24 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " i1 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } + +struct S { int a, b, c; }; + +template +int +foo (int x) +{ + int r = 0; + if (x == 1) + goto l1; + S s1; + if (x == 2) + goto l1; + S s2; + { + S s10; + if (x == 12) + goto l1; + s10.a = 1; + r += s10.a; + int i1; + if (x == 13) + goto l1; + i1 = 2; + r += i1; + } + if (x == 3) + goto l2; + if (x == 4) + goto l1; + { + S s3; + if (x == 5) + goto l2; + S s4; + if (x == 6) + goto l1; + { + S s5; + if (x == 7) + goto l1; + s5.a = 5; + r += s5.a; + } + S s6; + { + S s7; + S s8; + if (x == 8) + goto l1; + S s9; + if (x == 9) + goto l2; + if (x == 10) + goto l2; + if (x == 11) + goto l2; + l1: + l2: + s1.a = 1; + s2.b = 2; + s3.c = 3; + s4.a = 4; + s6.b = 6; + s7.c = 7; + s8.a = 8; + s9.b = 9; + r += s1.a + s2.b + s3.c; + r += s4.a + s6.b + s7.c; + r += s8.a + s9.b; + if (x == 14) + goto l3; + S s11; + switch (x) + { + S s12; + case 15: + S s13; + // FALLTHRU + l3: + case 16: + case 17: + S s14; + s11.a = 1; + s12.b = 2; + s13.c = 3; + s14.a = 4; + r += s11.a + s12.b + s13.c; + r += s14.a; + return r; + case 18: + S s15; + s11.a = 1; + s12.b = 2; + s13.c = 3; + s14.a = 4; + s15.b = 5; + r += s11.a + s12.b + s13.c; + r += s14.a + s15.b; + return r; + default: + if (x != 19 && x != 20) + break; + S s16; + s11.a = 1; + s12.b = 2; + s13.c = 3; + s14.a = 4; + s15.b = 5; + s16.c = 6; + r += s11.a + s12.b + s13.c; + r += s14.a + s15.b + s16.c; + return r; + } + if (x == 21) + goto l3; + } + S s17; + if (x == 22) + goto l3; + if (x == 23) + goto l1; + if (x == 24) + goto l2; + s17.a = 1; + r += s17.a; + } + S s18; + if (x == 25) + { + S s19; + s19.c = 2; + r += s19.c; + if (x == 29) + l4:; + goto l3; + } + if (x == 26) + goto l1; + if (x == 27) + goto l2; + s18.b = 1; + r += s18.b; + if (x == 28) + goto l4; + { + S s20; + { + S s21; + if (x == 29) + goto l1; + S s22; + if (x == 30) + goto l2; + l5: + s20.a = 1; + s21.b = 2; + s22.c = 3; + r += s20.a + s21.b + s22.c; + switch (x) + { + case 31: + S s23; + // FALLTHRU + l6: + case 32: + case 33: + S s24; + s23.a = 1; + s24.b = 2; + r += s23.a + s24.b; + return r; + default: + if (x >= 34 && x <= 35) + return r; + break; + } + if (x == 34) + goto l5; + if (x == 35) + goto l6; + return r; + } + if (x == 36) + goto l5; + if (x == 37) + goto l6; + } + if (x == 38) + goto l5; + if (x == 39) + goto l6; + return r; +} + +int +bar (int x) +{ + return foo <42> (x); +} diff --git a/gcc/testsuite/g++.dg/cpp26/erroneous6.C b/gcc/testsuite/g++.dg/cpp26/erroneous6.C new file mode 100644 index 000000000000..e3ddf35b037a --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp26/erroneous6.C @@ -0,0 +1,241 @@ +// C++ 26 P2795R5 - Erroneous behaviour for uninitialized reads +// { dg-do compile } +// { dg-skip-if "" { *-*-* } { "-ftrivial-auto-var-init=*" } { "" } } +// { dg-options "-O2 -fdump-tree-gimple" } +// All the s1..s24 variables and i1 need .DEFERRED_INIT call on their +// declarations. +// Plus, forward gotos to l1 & l2 labels need up to s1-s4 and s6-s9 vars to +// be .DEFERRED_INITed (and backward gotos up to that minus the first two). +// switch to case 15 skips over s12, switch to case 16/17 skip +// over s12 and s13 but the adjacent l3 label needs to also skip over s3-s4 +// and s6-s9 and s11. switch to case 18 skips over s12-s14 and switch to +// default in the same switch skips over s12-s15. +// goto l4; skips over s19 initialization. +// goto l5; skips over s20-s22 initialization. +// switch to case 32/33 skips over s23 but goto to adjacent l6 skips also +// over s20-s22. switch to default in that switch skips over s23-s24. +// { dg-final { scan-tree-dump-times " s1 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s2 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s3 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s4 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s5 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s6 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s7 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s8 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s9 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s10 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s11 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s12 = \.DEFERRED_INIT \\\(" 5 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s13 = \.DEFERRED_INIT \\\(" 4 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s14 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s15 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s16 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s17 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s18 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s19 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s20 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s21 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s22 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s23 = \.DEFERRED_INIT \\\(" 3 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " s24 = \.DEFERRED_INIT \\\(" 2 "gimple" { target c++26 } } } +// { dg-final { scan-tree-dump-times " i1 = \.DEFERRED_INIT \\\(" 1 "gimple" { target c++26 } } } + +struct S { int a, b, c; }; + +template +int +foo (int x) +{ + int r = 0; + if (x == 1) + goto l1; + S s1; + if (x == 2) + goto l1; + S s2; + { + S s10; + if (x == 12) + goto l1; + s10.a = 1; + r += s10.a; + int i1; + if (x == 13) + goto l1; + i1 = 2; + r += i1; + } + if (x == 3) + goto l2; + if (x == 4) + goto l1; + { + S s3; + if (x == 5) + goto l2; + S s4; + if (x == 6) + goto l1; + { + S s5; + if (x == 7) + goto l1; + s5.a = 5; + r += s5.a; + } + S s6; + { + S s7; + S s8; + if (x == 8) + goto l1; + S s9; + if (x == 9) + goto l2; + if (x == 10) + goto l2; + if (x == 11) + goto l2; + l1: + l2: + s1.a = 1; + s2.b = 2; + s3.c = 3; + s4.a = 4; + s6.b = 6; + s7.c = 7; + s8.a = 8; + s9.b = 9; + r += s1.a + s2.b + s3.c; + r += s4.a + s6.b + s7.c; + r += s8.a + s9.b; + if (x == 14) + goto l3; + S s11; + switch (x) + { + S s12; + case 15: + S s13; + // FALLTHRU + l3: + case 16: + case 17: + S s14; + s11.a = 1; + s12.b = 2; + s13.c = 3; + s14.a = 4; + r += s11.a + s12.b + s13.c; + r += s14.a; + return r; + case 18: + S s15; + s11.a = 1; + s12.b = 2; + s13.c = 3; + s14.a = 4; + s15.b = 5; + r += s11.a + s12.b + s13.c; + r += s14.a + s15.b; + return r; + default: + if (x != 19 && x != 20) + break; + S s16; + s11.a = 1; + s12.b = 2; + s13.c = 3; + s14.a = 4; + s15.b = 5; + s16.c = 6; + r += s11.a + s12.b + s13.c; + r += s14.a + s15.b + s16.c; + return r; + } + if (x == 21) + goto l3; + } + S s17; + if (x == 22) + goto l3; + if (x == 23) + goto l1; + if (x == 24) + goto l2; + s17.a = 1; + r += s17.a; + } + S s18; + if (x == 25) + { + S s19; + s19.c = 2; + r += s19.c; + if (x == 29) + l4:; + goto l3; + } + if (x == 26) + goto l1; + if (x == 27) + goto l2; + s18.b = 1; + r += s18.b; + if (x == 28) + goto l4; + { + S s20; + { + S s21; + if (x == 29) + goto l1; + S s22; + if (x == 30) + goto l2; + l5: + s20.a = 1; + s21.b = 2; + s22.c = 3; + r += s20.a + s21.b + s22.c; + switch (x) + { + case 31: + S s23; + // FALLTHRU + l6: + case 32: + case 33: + S s24; + s23.a = 1; + s24.b = 2; + r += s23.a + s24.b; + return r; + default: + if (x >= 34 && x <= 35) + return r; + break; + } + if (x == 34) + goto l5; + if (x == 35) + goto l6; + return r; + } + if (x == 36) + goto l5; + if (x == 37) + goto l6; + } + if (x == 38) + goto l5; + if (x == 39) + goto l6; + return r; +} + +int +bar (int x) +{ + return foo (x); +} diff --git a/gcc/testsuite/g++.dg/cpp26/pack-indexing18.C b/gcc/testsuite/g++.dg/cpp26/pack-indexing18.C new file mode 100644 index 000000000000..d3e3730408cb --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp26/pack-indexing18.C @@ -0,0 +1,32 @@ +// PR c++/121325 +// { dg-do compile { target c++26 } } + +void f(auto... a) requires requires { [] noexcept(noexcept(a...[i])) { }(); } {} +void g(auto... a) requires requires { [] { static_assert(noexcept(a...[i])); }(); } {} + +void +h () +{ + f (0); + g (0); +} + +void foo () {} +void bar () noexcept {} +template +void baz () noexcept(B) {} + +template +void +x (Ts... ts) noexcept (noexcept (ts...[0]())) +{ +} + +void +y () +{ + static_assert (!noexcept (x (foo))); + static_assert (noexcept (x (bar))); + static_assert (noexcept (x (baz))); + static_assert (!noexcept (x (baz))); +} diff --git a/gcc/testsuite/g++.dg/cpp2a/lambda-uneval14.C b/gcc/testsuite/g++.dg/cpp2a/lambda-uneval14.C index a18035954e16..d0e74e3c8057 100644 --- a/gcc/testsuite/g++.dg/cpp2a/lambda-uneval14.C +++ b/gcc/testsuite/g++.dg/cpp2a/lambda-uneval14.C @@ -1,6 +1,6 @@ // PR c++/99478 // { dg-do compile { target c++20 } } -template auto f() {} // { dg-error "lambda" } +template auto f() {} -int main() { f<{}>(); } // { dg-prune-output "no match" } +int main() { f<{}>(); } diff --git a/gcc/testsuite/g++.dg/cpp2a/lambda-uneval29.C b/gcc/testsuite/g++.dg/cpp2a/lambda-uneval29.C new file mode 100644 index 000000000000..76e743fedcef --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/lambda-uneval29.C @@ -0,0 +1,5 @@ +// PR c++/116952 +// { dg-do compile { target c++20 } } + +template concept A = true; +template> int x; diff --git a/gcc/testsuite/g++.dg/debug/pr80461.C b/gcc/testsuite/g++.dg/debug/pr80461.C index b472e62c8037..440241da5e8b 100644 --- a/gcc/testsuite/g++.dg/debug/pr80461.C +++ b/gcc/testsuite/g++.dg/debug/pr80461.C @@ -30,7 +30,7 @@ bar () { O q; A

f = q; - v++; + v = v + 1; } void diff --git a/gcc/testsuite/g++.dg/debug/pr94459.C b/gcc/testsuite/g++.dg/debug/pr94459.C index ebc0cf45cc64..6886bdb6e438 100644 --- a/gcc/testsuite/g++.dg/debug/pr94459.C +++ b/gcc/testsuite/g++.dg/debug/pr94459.C @@ -1,6 +1,6 @@ // PR debug/94459 // { dg-do compile { target c++14 } } -// { dg-options "-g -dA" } +// { dg-options "-g -dA -std=gnu++17" } template struct S diff --git a/gcc/testsuite/g++.dg/diagnostic/virtual-constexpr.C b/gcc/testsuite/g++.dg/diagnostic/virtual-constexpr.C index 9223c6927376..1daa86dd902f 100644 --- a/gcc/testsuite/g++.dg/diagnostic/virtual-constexpr.C +++ b/gcc/testsuite/g++.dg/diagnostic/virtual-constexpr.C @@ -1,6 +1,5 @@ // { dg-options "-fdiagnostics-show-caret -pedantic-errors" } -// { dg-do compile { target c++11 } } -// { dg-skip-if "virtual constexpr" { *-*-* } { "-std=gnu++2a" } { "" } } +// { dg-do compile { target { c++11 && c++17_down } } } struct S { diff --git a/gcc/testsuite/g++.dg/gcov/pr16855-priority.C b/gcc/testsuite/g++.dg/gcov/pr16855-priority.C index c7a58397bb91..ebdcad5d94fb 100644 --- a/gcc/testsuite/g++.dg/gcov/pr16855-priority.C +++ b/gcc/testsuite/g++.dg/gcov/pr16855-priority.C @@ -20,7 +20,7 @@ class Test public: Test (void) { fprintf (stderr, "In Test::Test\n"); /* count(1) */ } ~Test (void) { - fprintf (stderr, "In Test::~Test\n"); /* count(1) { xfail *-*-dragonfly* } */ + fprintf (stderr, "In Test::~Test\n"); /* count(1) { xfail *-*-dragonfly* *-*-solaris2* } */ } } T1; @@ -78,4 +78,4 @@ static void __attribute__ ((destructor ((65535)))) dtor_65535 () fprintf (stderr, "in destructor((65535))\n"); /* count(1) */ } -/* { dg-final { run-gcov branches { -b pr16855-priority.C } { xfail *-*-dragonfly* } } } */ +/* { dg-final { run-gcov branches { -b pr16855-priority.C } { xfail *-*-dragonfly* *-*-solaris2* } } } */ diff --git a/gcc/testsuite/g++.dg/gcov/pr16855.C b/gcc/testsuite/g++.dg/gcov/pr16855.C index f9b86a40001f..724ee02813a9 100644 --- a/gcc/testsuite/g++.dg/gcov/pr16855.C +++ b/gcc/testsuite/g++.dg/gcov/pr16855.C @@ -1,7 +1,8 @@ /* { dg-options "-fprofile-arcs -ftest-coverage" } */ /* { dg-do run { target native } } */ -/* See PR91087 for information on Darwin xfails. */ +/* See PR91087 for information on Darwin xfails. Also PR81337 for Solaris + ones.*/ #include #include @@ -21,7 +22,7 @@ class Test public: Test (void) { fprintf (stderr, "In Test::Test\n"); /* count(1) */ } ~Test (void) { - fprintf (stderr, "In Test::~Test\n"); /* count(1) { xfail *-*-darwin* *-*-dragonfly* } */ + fprintf (stderr, "In Test::~Test\n"); /* count(1) { xfail *-*-darwin* *-*-dragonfly* *-*-solaris2* } */ } } T1; @@ -49,4 +50,4 @@ static void __attribute__ ((destructor)) dtor_default () fprintf (stderr, "in destructor(())\n"); /* count(1) { xfail *-*-darwin* } */ } -/* { dg-final { run-gcov branches { -b pr16855.C } { xfail *-*-darwin* *-*-dragonfly* } } } */ +/* { dg-final { run-gcov branches { -b pr16855.C } { xfail *-*-darwin* *-*-dragonfly* *-*-solaris2* } } } */ diff --git a/gcc/testsuite/g++.dg/guality/pr67192.C b/gcc/testsuite/g++.dg/guality/pr67192.C index c09ecf8dc817..9c30dd7ca9d2 100644 --- a/gcc/testsuite/g++.dg/guality/pr67192.C +++ b/gcc/testsuite/g++.dg/guality/pr67192.C @@ -1,6 +1,6 @@ /* PR debug/67192 */ /* { dg-do run } */ -/* { dg-options "-x c++ -g -Wmisleading-indentation" } */ +/* { dg-options "-x c++ -g -Wmisleading-indentation -std=gnu++17" } */ volatile int cnt = 0; diff --git a/gcc/testsuite/g++.dg/lto/pr122905.h b/gcc/testsuite/g++.dg/lto/pr122905.h new file mode 100644 index 000000000000..f345e18418f2 --- /dev/null +++ b/gcc/testsuite/g++.dg/lto/pr122905.h @@ -0,0 +1,9 @@ +struct A { + typedef char *B; + struct C { C (B x) {} }; + C c; + enum { D = 15 }; + union { char e[16]; }; + A (const char *x) : c {e} {} +}; +A foo (); diff --git a/gcc/testsuite/g++.dg/lto/pr122905_0.C b/gcc/testsuite/g++.dg/lto/pr122905_0.C new file mode 100644 index 000000000000..6cde9bcc278a --- /dev/null +++ b/gcc/testsuite/g++.dg/lto/pr122905_0.C @@ -0,0 +1,16 @@ +/* PR c++/122905 */ +/* { dg-lto-do link } */ +/* { dg-lto-options { { -O2 -flto -std=c++20 } } } */ + +#include "pr122905.h" + +A +foo () +{ + return "foo"; +} + +int +main () +{ +} diff --git a/gcc/testsuite/g++.dg/lto/pr122905_1.C b/gcc/testsuite/g++.dg/lto/pr122905_1.C new file mode 100644 index 000000000000..549c3732bfdc --- /dev/null +++ b/gcc/testsuite/g++.dg/lto/pr122905_1.C @@ -0,0 +1,5 @@ +// { dg-options "-O2 -flto -std=c++17" } + +#include "pr122905.h" + +volatile auto v = foo (); diff --git a/gcc/testsuite/g++.dg/modules/omp-4_a.C b/gcc/testsuite/g++.dg/modules/omp-4_a.C new file mode 100644 index 000000000000..948966e657f3 --- /dev/null +++ b/gcc/testsuite/g++.dg/modules/omp-4_a.C @@ -0,0 +1,30 @@ +// PR c++/119864 +// { dg-additional-options "-fmodules -fopenmp" } +// { dg-module-cmi p1 } + +export module p1; + +export +template +struct T +{ + double d; + + T &operator +=(T const &x) { d += x.d; return *this; } +}; + +export +template +T sum(T const *p, unsigned N) +{ +T Sum = {}; + +#pragma omp declare reduction(Op: T: omp_out += omp_in) initializer(omp_priv = {}) +#pragma omp parallel for reduction(Op: Sum) +for (unsigned i = 0u; i < N; ++i) + { + Sum += *p; + ++p; + } +return Sum; +} diff --git a/gcc/testsuite/g++.dg/modules/omp-4_b.C b/gcc/testsuite/g++.dg/modules/omp-4_b.C new file mode 100644 index 000000000000..c1ca279a97e0 --- /dev/null +++ b/gcc/testsuite/g++.dg/modules/omp-4_b.C @@ -0,0 +1,11 @@ +// PR c++/119864 +// { dg-additional-options "-fmodules -fopenmp" } + +import p1; + +int main() +{ + T<1u> v[3u] = {}; + + T s = sum(v, 3u); +} diff --git a/gcc/testsuite/g++.dg/torture/pr119969.C b/gcc/testsuite/g++.dg/torture/pr119969.C new file mode 100644 index 000000000000..25a4053c3f87 --- /dev/null +++ b/gcc/testsuite/g++.dg/torture/pr119969.C @@ -0,0 +1,46 @@ +// PR c++/119969 +// { dg-do run } + +struct S {}; +using PMF = void (S::*)(); +using Block = PMF[16]; +using BlockPtr = Block*; + +struct IteratorImp { + Block** d_blockPtr_p; + PMF* d_value_p; + + void operator++(); + PMF& operator*() const { return *d_value_p; } +}; + +void IteratorImp::operator++() { + int offset = 1 + (d_value_p - **d_blockPtr_p); + d_blockPtr_p += offset / 16; + d_value_p = **d_blockPtr_p + (offset % 16); +} + +struct iterator { + IteratorImp d_imp; +}; + +struct D { + Block* d_blockPtrs[1]; + Block d_block; + PMF* d_start_p; +}; + +D mX; + +void privateInit(int numElements) { + mX.d_blockPtrs[0] = &mX.d_block; + mX.d_start_p = mX.d_block + (numElements + 7); +} + +int main() { + privateInit(0); + iterator cbgn = {{mX.d_blockPtrs, mX.d_block + 7}}; + auto clast = cbgn; + ++clast.d_imp; + if (&*cbgn.d_imp == &*clast.d_imp) return 1; +} diff --git a/gcc/testsuite/g++.dg/torture/pr51482.C b/gcc/testsuite/g++.dg/torture/pr51482.C index 4032703f7208..d4d6ae45d1f5 100644 --- a/gcc/testsuite/g++.dg/torture/pr51482.C +++ b/gcc/testsuite/g++.dg/torture/pr51482.C @@ -22,7 +22,7 @@ WVECT * anim_track_bez_wvect::tangent(int kn, BEZIER_KEY_CLASS key_class, WVECT g1.y = (p_p1->y - p_p0->y)*bp1; g1.z = (p_p1->z - p_p0->z)*bp1; g1.w = (p_p1->w - p_p0->w)*bp1; - bp1 = (0.5f + key_class*0.5f*continuity); + bp1 = (0.5f + ((int)key_class)*0.5f*continuity); p_tn->x = (g1.x + g3.x*bp1)*tn1; p_tn->y = (g1.y + g3.y*bp1)*tn1; p_tn->z = (g1.z + g3.z*bp1)*tn1; diff --git a/gcc/testsuite/g++.dg/torture/pr84961-1.C b/gcc/testsuite/g++.dg/torture/pr84961-1.C index 6a72ad5134fc..2c372c5e31e5 100644 --- a/gcc/testsuite/g++.dg/torture/pr84961-1.C +++ b/gcc/testsuite/g++.dg/torture/pr84961-1.C @@ -1,5 +1,6 @@ // PR c++/84961 // { dg-do compile } +// { dg-options "-std=gnu++17" } short a; volatile int b; diff --git a/gcc/testsuite/g++.dg/torture/pr84961-2.C b/gcc/testsuite/g++.dg/torture/pr84961-2.C index 0909eedb7f96..7f4fe69d103f 100644 --- a/gcc/testsuite/g++.dg/torture/pr84961-2.C +++ b/gcc/testsuite/g++.dg/torture/pr84961-2.C @@ -1,5 +1,6 @@ // PR c++/84961 // { dg-do compile } +// { dg-options "-std=gnu++17" } short a; volatile int b; diff --git a/gcc/testsuite/g++.dg/torture/stackalign/unwind-4.C b/gcc/testsuite/g++.dg/torture/stackalign/unwind-4.C index fddf27625705..6b9339e7e7ff 100644 --- a/gcc/testsuite/g++.dg/torture/stackalign/unwind-4.C +++ b/gcc/testsuite/g++.dg/torture/stackalign/unwind-4.C @@ -11,7 +11,7 @@ foo() int i; ALTER_REGS(); for (i=0; i < 10; i++) - g_a++; + g_a = g_a + 1; throw g_a; } #endif diff --git a/gcc/testsuite/g++.dg/tree-prof/partition1.C b/gcc/testsuite/g++.dg/tree-prof/partition1.C index 8dd64aa27a51..b3095bd6a508 100644 --- a/gcc/testsuite/g++.dg/tree-prof/partition1.C +++ b/gcc/testsuite/g++.dg/tree-prof/partition1.C @@ -16,7 +16,8 @@ int bar (int i) void *p = __builtin_alloca (i); asm volatile ("" : : "r" (i), "r" (p) : "memory"); if (k) throw 6; - return ++l; + l = l + 1; + return l; } void foo () diff --git a/gcc/testsuite/g++.target/aarch64/pr122890.C b/gcc/testsuite/g++.target/aarch64/pr122890.C new file mode 100644 index 000000000000..2b7426486d42 --- /dev/null +++ b/gcc/testsuite/g++.target/aarch64/pr122890.C @@ -0,0 +1,16 @@ +/* { dg-do compile } */ +/* { dg-options "-march=armv8-a -std=c++11 -Ofast" } */ + +#include + +int foo() +{ + bool xs[] = { true, true, false, true }; + bool s[] = { true, true, false }; + std::vector x(xs, xs+4); + std::vector g(s, s+3); + g.push_back(true); + if (g != x) + __builtin_abort(); + return 0; +} diff --git a/gcc/testsuite/g++.target/i386/pr122906-1.C b/gcc/testsuite/g++.target/i386/pr122906-1.C new file mode 100644 index 000000000000..6c4be38d892d --- /dev/null +++ b/gcc/testsuite/g++.target/i386/pr122906-1.C @@ -0,0 +1,1065 @@ +// { dg-do compile { target *-*-linux* } } +// { dg-options "-O3 -std=c++20 -ftrivial-auto-var-init=zero -march=x86-64-v3 -fPIC -w -mtls-dialect=gnu " } + +template using b = int; +template struct e; +struct m {}; +template struct aa; +template struct j; +using h = aa>; +template using a = h; +template using k = h; +template struct p { + d ad; +}; +struct ac {}; +template struct al; +template struct al { + typedef g &ah; +}; +template z ::i q(z); +struct w { + e *l; + al *>::ah operator*() { return *l; } + bool operator==(w) { return l; } +}; +template struct n { + using af = g[o]; +}; +template struct ak { + n::af am; +}; +void ab(); +template void ar(ai r, ac) { + ai ag; + for (; r != ag; ++r) + ab(), *r; +} +template void as(ai r, ac) { ar(r, q(r)); } +struct { + template void aj(ai r, ai) { as(r, q(r)); } +} ao; +namespace ap { +template struct bb { + static const bool ax = at; +}; +} // namespace ap +using ap::bb; +namespace av { +template struct c; +template struct c { + static const bool ax = au; + operator bb() { + void *bc; + return *reinterpret_cast *>(bc); + } +}; +template struct ae : c {}; +template struct ae : c {}; +namespace aw { +using namespace ap; +} +} // namespace av +namespace ap { +template struct bd { + typedef bd<1> bh; +}; +} // namespace ap +namespace av { +namespace aw { +template struct be; +template struct bn : bb {}; +template +struct bn : bn> {}; +template <> +struct bn, bb, bb, bb> : bb {}; +template , + typename az = bb, typename bl = bb> +struct br : bn {}; +} // namespace aw +template struct bi { + typedef aq h; +}; +template bi::h bf(); +template struct ba : c {}; +template struct ba : c {}; +template struct bk { + typedef aq const h; +}; +template struct bq { + typedef aq h; +}; +template struct bu { + typedef aq::h h; +}; +template struct by { + typedef bo ::ah h; +}; +template struct bm { + typedef aq h; +}; +template struct bm { + typedef aq h; +}; +namespace aw { +template struct bp { + typedef bg h; +}; +template struct bp { + typedef bj h; +}; +template struct cg { + typedef bp::h h; +}; +template struct bs { + typedef cg::h ::h h; +}; +template struct bx; +template +struct bx : bx> {}; +template <> +struct bx, bb, bb, bb> : bb {}; +template +struct bw : bx, bb, bb> {}; +} // namespace aw +template struct cb { + template static void ca(cc); + template static decltype(ca(bf())) cr(int); + template static int cr(...); + static const bool ax = sizeof(cr(0)) == 1; +}; +template struct cm { + static const bool ax = cb::ax; +}; +template struct cl { + typedef cm h; +}; +template struct ci { + typedef cl::h h; +}; +template struct co : ci::h {}; +template struct ce : c::ax> {}; +namespace aw { +template struct cf { + typedef aq h; +}; +} // namespace aw +template struct arg { + template struct apply { + typedef ck h; + }; +}; +template <> struct arg<2> { + template struct apply { + typedef cu h; + }; +}; +struct cj {}; +template struct cx : aw::bs, aw::cf> {}; +template struct cw : cx {}; +template +struct cn : aw::bs, ce>, aw::cf> {}; +template struct dd : aw::br, ce> {}; +template struct cz : cs, ct {}; +template struct da { + typedef cn::h category; + typedef aw::cg, category, cz>::h h; +}; +template +struct s : aw::bs, aw::cf, da> {}; +namespace aw { +template struct de : df::apply {}; +template +struct u : df::apply {}; +template +struct db : df::apply {}; +template struct bh { + typedef aq::bh h; +}; +template struct cv; +template +struct cv, ck, cu, dm> { + typedef db, ck, cu>::h h; +}; +template struct dh { + template struct apply { + typedef de::h>::h h; + }; +}; +template +struct cv, ck, cu, dm> { + typedef db, ck, cu>::h h; +}; +template struct dg { + template struct apply { + typedef u::h, + typename cv::h>::h h; + }; +}; +template struct di { + typedef aq::h h; +}; +template