algol68g-2.8/0000777000175000001440000000000012224301440007777 500000000000000algol68g-2.8/configure0000755000175000001440000405240712224300601011634 00000000000000#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.63 for algol68g 2.8. # # Report bugs to >. # # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, # 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in *posix*) set -o posix ;; esac fi # PATH needs CR # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo if (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. case $0 in *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 { (exit 1); exit 1; } fi # Work around bugs in pre-3.0 UWIN ksh. for as_var in ENV MAIL MAILPATH do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # Required to use basename. if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi # Name of the executable. as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # CDPATH. $as_unset CDPATH if test "x$CONFIG_SHELL" = x; then if (eval ":") 2>/dev/null; then as_have_required=yes else as_have_required=no fi if test $as_have_required = yes && (eval ": (as_func_return () { (exit \$1) } as_func_success () { as_func_return 0 } as_func_failure () { as_func_return 1 } as_func_ret_success () { return 0 } as_func_ret_failure () { return 1 } exitcode=0 if as_func_success; then : else exitcode=1 echo as_func_success failed. fi if as_func_failure; then exitcode=1 echo as_func_failure succeeded. fi if as_func_ret_success; then : else exitcode=1 echo as_func_ret_success failed. fi if as_func_ret_failure; then exitcode=1 echo as_func_ret_failure succeeded. fi if ( set x; as_func_ret_success y && test x = \"\$1\" ); then : else exitcode=1 echo positional parameters were not saved. fi test \$exitcode = 0) || { (exit 1); exit 1; } ( as_lineno_1=\$LINENO as_lineno_2=\$LINENO test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" && test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; } ") 2> /dev/null; then : else as_candidate_shells= as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. case $as_dir in /*) for as_base in sh bash ksh sh5; do as_candidate_shells="$as_candidate_shells $as_dir/$as_base" done;; esac done IFS=$as_save_IFS for as_shell in $as_candidate_shells $SHELL; do # Try only shells that exist, to save several forks. if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { ("$as_shell") 2> /dev/null <<\_ASEOF if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in *posix*) set -o posix ;; esac fi : _ASEOF }; then CONFIG_SHELL=$as_shell as_have_required=yes if { "$as_shell" 2> /dev/null <<\_ASEOF if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in *posix*) set -o posix ;; esac fi : (as_func_return () { (exit $1) } as_func_success () { as_func_return 0 } as_func_failure () { as_func_return 1 } as_func_ret_success () { return 0 } as_func_ret_failure () { return 1 } exitcode=0 if as_func_success; then : else exitcode=1 echo as_func_success failed. fi if as_func_failure; then exitcode=1 echo as_func_failure succeeded. fi if as_func_ret_success; then : else exitcode=1 echo as_func_ret_success failed. fi if as_func_ret_failure; then exitcode=1 echo as_func_ret_failure succeeded. fi if ( set x; as_func_ret_success y && test x = "$1" ); then : else exitcode=1 echo positional parameters were not saved. fi test $exitcode = 0) || { (exit 1); exit 1; } ( as_lineno_1=$LINENO as_lineno_2=$LINENO test "x$as_lineno_1" != "x$as_lineno_2" && test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; } _ASEOF }; then break fi fi done if test "x$CONFIG_SHELL" != x; then for as_var in BASH_ENV ENV do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var done export CONFIG_SHELL exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} fi if test $as_have_required = no; then echo This script requires a shell more modern than all the echo shells that I found on your system. Please install a echo modern shell, or manually run the script under such a echo shell if you do have one. { (exit 1); exit 1; } fi fi fi (eval "as_func_return () { (exit \$1) } as_func_success () { as_func_return 0 } as_func_failure () { as_func_return 1 } as_func_ret_success () { return 0 } as_func_ret_failure () { return 1 } exitcode=0 if as_func_success; then : else exitcode=1 echo as_func_success failed. fi if as_func_failure; then exitcode=1 echo as_func_failure succeeded. fi if as_func_ret_success; then : else exitcode=1 echo as_func_ret_success failed. fi if as_func_ret_failure; then exitcode=1 echo as_func_ret_failure succeeded. fi if ( set x; as_func_ret_success y && test x = \"\$1\" ); then : else exitcode=1 echo positional parameters were not saved. fi test \$exitcode = 0") || { echo No shell found that supports shell functions. echo Please tell bug-autoconf@gnu.org about your system, echo including any error possibly output before this message. echo This can help us improve future autoconf versions. echo Configuration will now proceed without shell functions. } as_lineno_1=$LINENO as_lineno_2=$LINENO test "x$as_lineno_1" != "x$as_lineno_2" && test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || { # Create $as_me.lineno as a copy of $as_myself, but with $LINENO # uniformly replaced by the line number. The first 'sed' inserts a # line-number line after each line using $LINENO; the second 'sed' # does the real work. The second script uses 'N' to pair each # line-number line with the line containing $LINENO, and appends # trailing '-' during substitution so that $LINENO is not a special # case at line end. # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the # scripts with optimization help from Paolo Bonzini. Blame Lee # E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 { (exit 1); exit 1; }; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in -n*) case `echo 'x\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. *) ECHO_C='\c';; esac;; *) ECHO_N='-n';; esac if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= SHELL=${CONFIG_SHELL-/bin/sh} # Identity of this package. PACKAGE_NAME='algol68g' PACKAGE_TARNAME='algol68g' PACKAGE_VERSION='2.8' PACKAGE_STRING='algol68g 2.8' PACKAGE_BUGREPORT='Marcel van der Veer ' ac_default_prefix=/usr/local ac_unique_file="source/a68g.h" # Factoring default headers for most tests. ac_includes_default="\ #include #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef STDC_HEADERS # include # include #else # ifdef HAVE_STDLIB_H # include # endif #endif #ifdef HAVE_STRING_H # if !defined STDC_HEADERS && defined HAVE_MEMORY_H # include # endif # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_subst_vars='LTLIBOBJS LIBOBJS EGREP GREP CPP EXPORT_DYNAMIC_FALSE EXPORT_DYNAMIC_TRUE am__fastdepCC_FALSE am__fastdepCC_TRUE CCDEPMODE AMDEPBACKSLASH AMDEP_FALSE AMDEP_TRUE am__quote am__include DEPDIR OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC a68g_exists am__untar am__tar AMTAR am__leading_dot SET_MAKE AWK mkdir_p MKDIR_P INSTALL_STRIP_PROGRAM STRIP install_sh MAKEINFO AUTOHEADER AUTOMAKE AUTOCONF ACLOCAL VERSION PACKAGE CYGPATH_W am__isrc INSTALL_DATA INSTALL_SCRIPT INSTALL_PROGRAM target_os target_vendor target_cpu target host_os host_vendor host_cpu host build_os build_vendor build_cpu build target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking enable_arch enable_compiler enable_curses enable_readline enable_gsl enable_parallel enable_pic enable_prescott enable_plotutils enable_postgresql enable_dependency_tracking enable_assert ' ac_precious_vars='build_alias host_alias target_alias CC CFLAGS LDFLAGS LIBS CPPFLAGS CPP' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && { $as_echo "$as_me: error: invalid feature name: $ac_useropt" >&2 { (exit 1); exit 1; }; } ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && { $as_echo "$as_me: error: invalid feature name: $ac_useropt" >&2 { (exit 1); exit 1; }; } ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && { $as_echo "$as_me: error: invalid package name: $ac_useropt" >&2 { (exit 1); exit 1; }; } ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && { $as_echo "$as_me: error: invalid package name: $ac_useropt" >&2 { (exit 1); exit 1; }; } ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) { $as_echo "$as_me: error: unrecognized option: $ac_option Try \`$0 --help' for more information." >&2 { (exit 1); exit 1; }; } ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && { $as_echo "$as_me: error: invalid variable name: $ac_envvar" >&2 { (exit 1); exit 1; }; } eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` { $as_echo "$as_me: error: missing argument to $ac_option" >&2 { (exit 1); exit 1; }; } fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) { $as_echo "$as_me: error: unrecognized options: $ac_unrecognized_opts" >&2 { (exit 1); exit 1; }; } ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac { $as_echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; } done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || { $as_echo "$as_me: error: working directory cannot be determined" >&2 { (exit 1); exit 1; }; } test "X$ac_ls_di" = "X$ac_pwd_ls_di" || { $as_echo "$as_me: error: pwd does not report name of working directory" >&2 { (exit 1); exit 1; }; } # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." { $as_echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 { (exit 1); exit 1; }; } fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || { $as_echo "$as_me: error: $ac_msg" >&2 { (exit 1); exit 1; }; } pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures algol68g 2.8 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/algol68g] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF Program names: --program-prefix=PREFIX prepend PREFIX to installed program names --program-suffix=SUFFIX append SUFFIX to installed program names --program-transform-name=PROGRAM run sed PROGRAM on installed program names System types: --build=BUILD configure for building on BUILD [guessed] --host=HOST cross-compile to build programs to run on HOST [BUILD] --target=TARGET configure for building compilers for TARGET [HOST] _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of algol68g 2.8:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-arch=cpu if using gcc, enable emitting architecture-tuned assembly code (default is "no") --enable-compiler enable unit compiler (default is "yes") --enable-curses if installed, enable curses library (default is "yes") --enable-readline if installed, enable readline library (default is "yes") --enable-gsl if installed, enable GNU Scientific Library (default is "yes") --enable-parallel enable Algol 68 parallel-clause (default is "yes") --enable-pic=option if using gcc, enable option to generate PIC (default is "-fPIC") --enable-prescott if using gcc, enable optimisation for P4 Prescott (default is "no") --enable-plotutils if installed, enable GNU plotting utilities (default is "yes") --enable-postgresql if installed, enable PostgreSQL (default is "yes") --disable-dependency-tracking speeds up one-time build --enable-dependency-tracking do not reject slow dependency extractors --disable-assert turn off assertions Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS C/C++/Objective C preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to >. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF algol68g configure 2.8 generated by GNU Autoconf 2.63 Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by algol68g $as_me 2.8, which was generated by GNU Autoconf 2.63. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi ac_configure_args="$ac_configure_args '$ac_arg'" ;; esac done done $as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } $as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo cat <<\_ASBOX ## ---------------- ## ## Cache variables. ## ## ---------------- ## _ASBOX echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:$LINENO: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) $as_unset $ac_var ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo cat <<\_ASBOX ## ----------------- ## ## Output variables. ## ## ----------------- ## _ASBOX echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then cat <<\_ASBOX ## ------------------- ## ## File substitutions. ## ## ------------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then cat <<\_ASBOX ## ----------- ## ## confdefs.h. ## ## ----------- ## _ASBOX echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then ac_site_file1=$CONFIG_SITE elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test -r "$ac_site_file"; then { $as_echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special # files actually), so we avoid doing that. if test -f "$cache_file"; then { $as_echo "$as_me:$LINENO: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:$LINENO: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:$LINENO: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:$LINENO: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:$LINENO: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} { { $as_echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 $as_echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} { (exit 1); exit 1; }; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # # Algol 68 Genie "configure.ac" from "a68g-tools". # # Check whether compiler supports $1 as a command-line option. # If it does, add the string to CFLAGS. # Check whether $1 is in GNU plotutils. # Check whether $1 is in GNU GSL. # Check whether $1 is in PostgreSQL. # Check whether $1 is in pthread. # Check whether $1 is in dl. # # Platform ids. # { $as_echo "$as_me:$LINENO: host system..." >&5 $as_echo "$as_me: host system..." >&6;} ac_aux_dir= for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do if test -f "$ac_dir/install-sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f "$ac_dir/install.sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break elif test -f "$ac_dir/shtool"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/shtool install -c" break fi done if test -z "$ac_aux_dir"; then { { $as_echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&5 $as_echo "$as_me: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&2;} { (exit 1); exit 1; }; } fi # These three variables are undocumented and unsupported, # and are intended to be withdrawn in a future Autoconf release. # They can cause serious problems if a builder's source tree is in a directory # whose full name contains unusual characters. ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. # Make sure we can run config.sub. $SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || { { $as_echo "$as_me:$LINENO: error: cannot run $SHELL $ac_aux_dir/config.sub" >&5 $as_echo "$as_me: error: cannot run $SHELL $ac_aux_dir/config.sub" >&2;} { (exit 1); exit 1; }; } { $as_echo "$as_me:$LINENO: checking build system type" >&5 $as_echo_n "checking build system type... " >&6; } if test "${ac_cv_build+set}" = set; then $as_echo_n "(cached) " >&6 else ac_build_alias=$build_alias test "x$ac_build_alias" = x && ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` test "x$ac_build_alias" = x && { { $as_echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5 $as_echo "$as_me: error: cannot guess build type; you must specify one" >&2;} { (exit 1); exit 1; }; } ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || { { $as_echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&5 $as_echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $ac_build_alias failed" >&2;} { (exit 1); exit 1; }; } fi { $as_echo "$as_me:$LINENO: result: $ac_cv_build" >&5 $as_echo "$ac_cv_build" >&6; } case $ac_cv_build in *-*-*) ;; *) { { $as_echo "$as_me:$LINENO: error: invalid value of canonical build" >&5 $as_echo "$as_me: error: invalid value of canonical build" >&2;} { (exit 1); exit 1; }; };; esac build=$ac_cv_build ac_save_IFS=$IFS; IFS='-' set x $ac_cv_build shift build_cpu=$1 build_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: build_os=$* IFS=$ac_save_IFS case $build_os in *\ *) build_os=`echo "$build_os" | sed 's/ /-/g'`;; esac { $as_echo "$as_me:$LINENO: checking host system type" >&5 $as_echo_n "checking host system type... " >&6; } if test "${ac_cv_host+set}" = set; then $as_echo_n "(cached) " >&6 else if test "x$host_alias" = x; then ac_cv_host=$ac_cv_build else ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || { { $as_echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&5 $as_echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $host_alias failed" >&2;} { (exit 1); exit 1; }; } fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_host" >&5 $as_echo "$ac_cv_host" >&6; } case $ac_cv_host in *-*-*) ;; *) { { $as_echo "$as_me:$LINENO: error: invalid value of canonical host" >&5 $as_echo "$as_me: error: invalid value of canonical host" >&2;} { (exit 1); exit 1; }; };; esac host=$ac_cv_host ac_save_IFS=$IFS; IFS='-' set x $ac_cv_host shift host_cpu=$1 host_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: host_os=$* IFS=$ac_save_IFS case $host_os in *\ *) host_os=`echo "$host_os" | sed 's/ /-/g'`;; esac { $as_echo "$as_me:$LINENO: checking target system type" >&5 $as_echo_n "checking target system type... " >&6; } if test "${ac_cv_target+set}" = set; then $as_echo_n "(cached) " >&6 else if test "x$target_alias" = x; then ac_cv_target=$ac_cv_host else ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` || { { $as_echo "$as_me:$LINENO: error: $SHELL $ac_aux_dir/config.sub $target_alias failed" >&5 $as_echo "$as_me: error: $SHELL $ac_aux_dir/config.sub $target_alias failed" >&2;} { (exit 1); exit 1; }; } fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_target" >&5 $as_echo "$ac_cv_target" >&6; } case $ac_cv_target in *-*-*) ;; *) { { $as_echo "$as_me:$LINENO: error: invalid value of canonical target" >&5 $as_echo "$as_me: error: invalid value of canonical target" >&2;} { (exit 1); exit 1; }; };; esac target=$ac_cv_target ac_save_IFS=$IFS; IFS='-' set x $ac_cv_target shift target_cpu=$1 target_vendor=$2 shift; shift # Remember, the first character of IFS is used to create $*, # except with old shells: target_os=$* IFS=$ac_save_IFS case $target_os in *\ *) target_os=`echo "$target_os" | sed 's/ /-/g'`;; esac # The aliases save the names the user supplied, while $host etc. # will get canonicalized. test -n "$target_alias" && test "$program_prefix$program_suffix$program_transform_name" = \ NONENONEs,x,x, && program_prefix=${target_alias}- { $as_echo "$as_me:$LINENO: checking platform" >&5 $as_echo_n "checking platform... " >&6; } case "$host" in # # Linux. # *86-*-gnu | *86_64-*-gnu | *86-*-linux* | *86_64-*-linux* | arm*-*-linux*) cat >>confdefs.h <<\_ACEOF #define HAVE_LINUX 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define HAVE_IEEE_754 1 _ACEOF { $as_echo "$as_me:$LINENO: result: linux" >&5 $as_echo "linux" >&6; } ;; # # Cygwin. # *86-*-cygwin* | *86_64-*-cygwin*) cat >>confdefs.h <<\_ACEOF #define HAVE_IEEE_754 1 _ACEOF { $as_echo "$as_me:$LINENO: result: cygwin" >&5 $as_echo "cygwin" >&6; } ;; # # Mac OS X. # *86-*-*darwin* | *86_64-*-*darwin*) cat >>confdefs.h <<\_ACEOF #define HAVE_MAC_OS_X 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define HAVE_IEEE_754 1 _ACEOF { $as_echo "$as_me:$LINENO: result: mac os x" >&5 $as_echo "mac os x" >&6; } ;; # # FreeBSD. # *86-*-freebsd* | *86_64-*-freebsd*) cat >>confdefs.h <<\_ACEOF #define HAVE_FREEBSD 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define HAVE_IEEE_754 1 _ACEOF { $as_echo "$as_me:$LINENO: result: freebsd" >&5 $as_echo "freebsd" >&6; } ;; # # NetBSD. # *86-*-netbsd* | *86_64-*-netbsd*) cat >>confdefs.h <<\_ACEOF #define HAVE_NETBSD 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define HAVE_IEEE_754 1 _ACEOF { $as_echo "$as_me:$LINENO: result: netbsd" >&5 $as_echo "netbsd" >&6; } ;; # # OpenBSD. # *86-*-openbsd* | *86_64-*-openbsd*) cat >>confdefs.h <<\_ACEOF #define HAVE_OPENBSD 1 _ACEOF { $as_echo "$as_me:$LINENO: WARNING: configuring interpreter-only on OpenBSD" >&5 $as_echo "$as_me: WARNING: configuring interpreter-only on OpenBSD" >&2;} { $as_echo "$as_me:$LINENO: result: openbsd" >&5 $as_echo "openbsd" >&6; } enable_compiler=no ;; # # Others, untested. # *) cat >>confdefs.h <<\_ACEOF #define HAVE_UNTESTED 1 _ACEOF { $as_echo "$as_me:$LINENO: WARNING: configuring interpreter-only on untested platform" >&5 $as_echo "$as_me: WARNING: configuring interpreter-only on untested platform" >&2;} { $as_echo "$as_me:$LINENO: result: interpreter-only" >&5 $as_echo "interpreter-only" >&6; } enable_compiler=no ;; esac # # Extra options. # # Check whether --enable-arch was given. if test "${enable_arch+set}" = set; then enableval=$enable_arch; else enable_arch=no fi # Check whether --enable-compiler was given. if test "${enable_compiler+set}" = set; then enableval=$enable_compiler; else enable_compiler=yes fi # Check whether --enable-curses was given. if test "${enable_curses+set}" = set; then enableval=$enable_curses; else enable_curses=yes fi # Check whether --enable-readline was given. if test "${enable_readline+set}" = set; then enableval=$enable_readline; else enable_readline=yes fi # Check whether --enable-gsl was given. if test "${enable_gsl+set}" = set; then enableval=$enable_gsl; else enable_gsl=yes fi # Check whether --enable-parallel was given. if test "${enable_parallel+set}" = set; then enableval=$enable_parallel; else enable_parallel=yes fi # Check whether --enable-pic was given. if test "${enable_pic+set}" = set; then enableval=$enable_pic; else enable_pic="-fPIC" fi # Check whether --enable-prescott was given. if test "${enable_prescott+set}" = set; then enableval=$enable_prescott; else enable_prescott=no fi # Check whether --enable-plotutils was given. if test "${enable_plotutils+set}" = set; then enableval=$enable_plotutils; else enable_plotutils=yes fi # Check whether --enable-postgresql was given. if test "${enable_postgresql+set}" = set; then enableval=$enable_postgresql; else enable_postgresql=yes fi # # Initialisation. # { $as_echo "$as_me:$LINENO: initialising..." >&5 $as_echo "$as_me: initialising..." >&6;} am__api_version='1.10' # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. { $as_echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if test "${ac_cv_path_install+set}" = set; then $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. # Account for people who put trailing slashes in PATH elements. case $as_dir/ in ./ | .// | /cC/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else rm -rf conftest.one conftest.two conftest.dir echo one > conftest.one echo two > conftest.two mkdir conftest.dir if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && test -s conftest.one && test -s conftest.two && test -s conftest.dir/conftest.one && test -s conftest.dir/conftest.two then ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi fi done done ;; esac done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir fi if test "${ac_cv_path_install+set}" = set; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. Don't cache a # value for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. INSTALL=$ac_install_sh fi fi { $as_echo "$as_me:$LINENO: result: $INSTALL" >&5 $as_echo "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' { $as_echo "$as_me:$LINENO: checking whether build environment is sane" >&5 $as_echo_n "checking whether build environment is sane... " >&6; } # Just in case sleep 1 echo timestamp > conftest.file # Do `set' in a subshell so we don't clobber the current shell's # arguments. Must try -L first in case configure is actually a # symlink; some systems play weird games with the mod time of symlinks # (eg FreeBSD returns the mod time of the symlink's containing # directory). if ( set X `ls -Lt $srcdir/configure conftest.file 2> /dev/null` if test "$*" = "X"; then # -L didn't work. set X `ls -t $srcdir/configure conftest.file` fi rm -f conftest.file if test "$*" != "X $srcdir/configure conftest.file" \ && test "$*" != "X conftest.file $srcdir/configure"; then # If neither matched, then we have a broken ls. This can happen # if, for instance, CONFIG_SHELL is bash and it inherits a # broken ls alias from the environment. This has actually # happened. Such a system could not be considered "sane". { { $as_echo "$as_me:$LINENO: error: ls -t appears to fail. Make sure there is not a broken alias in your environment" >&5 $as_echo "$as_me: error: ls -t appears to fail. Make sure there is not a broken alias in your environment" >&2;} { (exit 1); exit 1; }; } fi test "$2" = conftest.file ) then # Ok. : else { { $as_echo "$as_me:$LINENO: error: newly created file is older than distributed files! Check your system clock" >&5 $as_echo "$as_me: error: newly created file is older than distributed files! Check your system clock" >&2;} { (exit 1); exit 1; }; } fi { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } test "$program_prefix" != NONE && program_transform_name="s&^&$program_prefix&;$program_transform_name" # Use a double $ so make ignores it. test "$program_suffix" != NONE && program_transform_name="s&\$&$program_suffix&;$program_transform_name" # Double any \ or $. # By default was `s,x,x', remove it if useless. ac_script='s/[\\$]/&&/g;s/;s,x,x,$//' program_transform_name=`$as_echo "$program_transform_name" | sed "$ac_script"` # expand $ac_aux_dir to an absolute path am_aux_dir=`cd $ac_aux_dir && pwd` test x"${MISSING+set}" = xset || MISSING="\${SHELL} $am_aux_dir/missing" # Use eval to expand $SHELL if eval "$MISSING --run true"; then am_missing_run="$MISSING --run " else am_missing_run= { $as_echo "$as_me:$LINENO: WARNING: \`missing' script is too old or missing" >&5 $as_echo "$as_me: WARNING: \`missing' script is too old or missing" >&2;} fi { $as_echo "$as_me:$LINENO: checking for a thread-safe mkdir -p" >&5 $as_echo_n "checking for a thread-safe mkdir -p... " >&6; } if test -z "$MKDIR_P"; then if test "${ac_cv_path_mkdir+set}" = set; then $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in mkdir gmkdir; do for ac_exec_ext in '' $ac_executable_extensions; do { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; } || continue case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #( 'mkdir (GNU coreutils) '* | \ 'mkdir (coreutils) '* | \ 'mkdir (fileutils) '4.1*) ac_cv_path_mkdir=$as_dir/$ac_prog$ac_exec_ext break 3;; esac done done done IFS=$as_save_IFS fi if test "${ac_cv_path_mkdir+set}" = set; then MKDIR_P="$ac_cv_path_mkdir -p" else # As a last resort, use the slow shell script. Don't cache a # value for MKDIR_P within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. test -d ./--version && rmdir ./--version MKDIR_P="$ac_install_sh -d" fi fi { $as_echo "$as_me:$LINENO: result: $MKDIR_P" >&5 $as_echo "$MKDIR_P" >&6; } mkdir_p="$MKDIR_P" case $mkdir_p in [\\/$]* | ?:[\\/]*) ;; */*) mkdir_p="\$(top_builddir)/$mkdir_p" ;; esac for ac_prog in gawk mawk nawk awk do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_AWK+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$AWK"; then ac_cv_prog_AWK="$AWK" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_AWK="$ac_prog" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi AWK=$ac_cv_prog_AWK if test -n "$AWK"; then { $as_echo "$as_me:$LINENO: result: $AWK" >&5 $as_echo "$AWK" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi test -n "$AWK" && break done { $as_echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 $as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if { as_var=ac_cv_prog_make_${ac_make}_set; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi rm -rf .tst 2>/dev/null mkdir .tst 2>/dev/null if test -d .tst; then am__leading_dot=. else am__leading_dot=_ fi rmdir .tst 2>/dev/null if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." am__isrc=' -I$(srcdir)' # test to see if srcdir already configured if test -f $srcdir/config.status; then { { $as_echo "$as_me:$LINENO: error: source directory already configured; run \"make distclean\" there first" >&5 $as_echo "$as_me: error: source directory already configured; run \"make distclean\" there first" >&2;} { (exit 1); exit 1; }; } fi fi # test whether we have cygpath if test -z "$CYGPATH_W"; then if (cygpath --version) >/dev/null 2>/dev/null; then CYGPATH_W='cygpath -w' else CYGPATH_W=echo fi fi # Define the identity of the package. PACKAGE='algol68g' VERSION='2.8' cat >>confdefs.h <<_ACEOF #define PACKAGE "$PACKAGE" _ACEOF cat >>confdefs.h <<_ACEOF #define VERSION "$VERSION" _ACEOF # Some tools Automake needs. ACLOCAL=${ACLOCAL-"${am_missing_run}aclocal-${am__api_version}"} AUTOCONF=${AUTOCONF-"${am_missing_run}autoconf"} AUTOMAKE=${AUTOMAKE-"${am_missing_run}automake-${am__api_version}"} AUTOHEADER=${AUTOHEADER-"${am_missing_run}autoheader"} MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"} install_sh=${install_sh-"\$(SHELL) $am_aux_dir/install-sh"} # Installed binaries are usually stripped using `strip' when the user # run `make install-strip'. However `strip' might not be the right # tool to use in cross-compilation environments, therefore Automake # will honor the `STRIP' environment variable to overrule this program. if test "$cross_compiling" != no; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args. set dummy ${ac_tool_prefix}strip; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_STRIP+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$STRIP"; then ac_cv_prog_STRIP="$STRIP" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_STRIP="${ac_tool_prefix}strip" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi STRIP=$ac_cv_prog_STRIP if test -n "$STRIP"; then { $as_echo "$as_me:$LINENO: result: $STRIP" >&5 $as_echo "$STRIP" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_STRIP"; then ac_ct_STRIP=$STRIP # Extract the first word of "strip", so it can be a program name with args. set dummy strip; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_STRIP+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_STRIP"; then ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_STRIP="strip" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP if test -n "$ac_ct_STRIP"; then { $as_echo "$as_me:$LINENO: result: $ac_ct_STRIP" >&5 $as_echo "$ac_ct_STRIP" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_STRIP" = x; then STRIP=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:$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 STRIP=$ac_ct_STRIP fi else STRIP="$ac_cv_prog_STRIP" fi fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" # We need awk for the "check" target. The system "awk" is bad on # some platforms. # Always define AMTAR for backward compatibility. AMTAR=${AMTAR-"${am_missing_run}tar"} am__tar='${AMTAR} chof - "$$tardir"'; am__untar='${AMTAR} xf -' ac_config_headers="$ac_config_headers source/a68g-config.h" # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. { $as_echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if test "${ac_cv_path_install+set}" = set; then $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. # Account for people who put trailing slashes in PATH elements. case $as_dir/ in ./ | .// | /cC/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else rm -rf conftest.one conftest.two conftest.dir echo one > conftest.one echo two > conftest.two mkdir conftest.dir if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && test -s conftest.one && test -s conftest.two && test -s conftest.dir/conftest.one && test -s conftest.dir/conftest.two then ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi fi done done ;; esac done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir fi if test "${ac_cv_path_install+set}" = set; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. Don't cache a # value for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. INSTALL=$ac_install_sh fi fi { $as_echo "$as_me:$LINENO: result: $INSTALL" >&5 $as_echo "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' # Extract the first word of "a68g", so it can be a program name with args. set dummy a68g; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_a68g_exists+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$a68g_exists"; then ac_cv_prog_a68g_exists="$a68g_exists" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_a68g_exists=""yes"" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi a68g_exists=$ac_cv_prog_a68g_exists if test -n "$a68g_exists"; then { $as_echo "$as_me:$LINENO: result: $a68g_exists" >&5 $as_echo "$a68g_exists" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi # # C compiler. # { $as_echo "$as_me:$LINENO: C compiler..." >&5 $as_echo "$as_me: C compiler..." >&6;} ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then for ac_prog in clang gcc cc do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_CC+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:$LINENO: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in clang gcc cc do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if test "${ac_cv_prog_ac_ct_CC+set}" = set; then $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # 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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:$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 CC=$ac_ct_CC fi fi test -z "$CC" && { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH See \`config.log' for more details." >&5 $as_echo "$as_me: error: no acceptable C compiler found in \$PATH See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; }; } # Provide some information about the compiler. $as_echo "$as_me:$LINENO: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 { (ac_try="$ac_compiler --version >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compiler --version >&5") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } { (ac_try="$ac_compiler -v >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compiler -v >&5") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } { (ac_try="$ac_compiler -V >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compiler -V >&5") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { $as_echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 $as_echo_n "checking for C compiler default output file name... " >&6; } ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { (ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else ac_file='' fi { $as_echo "$as_me:$LINENO: result: $ac_file" >&5 $as_echo "$ac_file" >&6; } if test -z "$ac_file"; then $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: C compiler cannot create executables See \`config.log' for more details." >&5 $as_echo "$as_me: error: C compiler cannot create executables See \`config.log' for more details." >&2;} { (exit 77); exit 77; }; }; } fi ac_exeext=$ac_cv_exeext # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:$LINENO: checking whether the C compiler works" >&5 $as_echo_n "checking whether the C compiler works... " >&6; } # FIXME: These cross compiler hacks should be removed for Autoconf 3.0 # If not cross compiling, check that we can run a simple program. if test "$cross_compiling" != yes; then if { ac_try='./$ac_file' { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details." >&5 $as_echo "$as_me: error: cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; }; } fi fi fi { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 $as_echo_n "checking whether we are cross compiling... " >&6; } { $as_echo "$as_me:$LINENO: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } { $as_echo "$as_me:$LINENO: checking for suffix of executables" >&5 $as_echo_n "checking for suffix of executables... " >&6; } if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." >&5 $as_echo "$as_me: error: cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; }; } fi rm -f conftest$ac_cv_exeext { $as_echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT { $as_echo "$as_me:$LINENO: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if test "${ac_cv_objext+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile See \`config.log' for more details." >&5 $as_echo "$as_me: error: cannot compute suffix of object files: cannot compile See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; }; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { $as_echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if test "${ac_cv_c_compiler_gnu+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_compiler_gnu=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if test "${ac_cv_prog_cc_g+set}" = set; then $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_prog_cc_g=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_prog_cc_g=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi { $as_echo "$as_me:$LINENO: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if test "${ac_cv_prog_cc_c89+set}" = set; then $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) 'x' int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_prog_cc_c89=$ac_arg else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:$LINENO: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:$LINENO: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu DEPDIR="${am__leading_dot}deps" ac_config_commands="$ac_config_commands depfiles" am_make=${MAKE-make} cat > confinc << 'END' am__doit: @echo done .PHONY: am__doit END # If we don't find an include directive, just comment out the code. { $as_echo "$as_me:$LINENO: checking for style of include used by $am_make" >&5 $as_echo_n "checking for style of include used by $am_make... " >&6; } am__include="#" am__quote= _am_result=none # First try GNU make style include. echo "include confinc" > confmf # We grep out `Entering directory' and `Leaving directory' # messages which can occur if `w' ends up in MAKEFLAGS. # In particular we don't look at `^make:' because GNU make might # be invoked under some other name (usually "gmake"), in which # case it prints its new name instead of `make'. if test "`$am_make -s -f confmf 2> /dev/null | grep -v 'ing directory'`" = "done"; then am__include=include am__quote= _am_result=GNU fi # Now try BSD make style include. if test "$am__include" = "#"; then echo '.include "confinc"' > confmf if test "`$am_make -s -f confmf 2> /dev/null`" = "done"; then am__include=.include am__quote="\"" _am_result=BSD fi fi { $as_echo "$as_me:$LINENO: result: $_am_result" >&5 $as_echo "$_am_result" >&6; } rm -f confinc confmf # Check whether --enable-dependency-tracking was given. if test "${enable_dependency_tracking+set}" = set; then enableval=$enable_dependency_tracking; fi if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' fi if test "x$enable_dependency_tracking" != xno; then AMDEP_TRUE= AMDEP_FALSE='#' else AMDEP_TRUE='#' AMDEP_FALSE= fi depcc="$CC" am_compiler_list= { $as_echo "$as_me:$LINENO: checking dependency style of $depcc" >&5 $as_echo_n "checking dependency style of $depcc... " >&6; } if test "${am_cv_CC_dependencies_compiler_type+set}" = set; then $as_echo_n "(cached) " >&6 else if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named `D' -- because `-MD' means `put the output # in D'. mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_CC_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` fi for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using `: > sub/conftst$i.h' creates only sub/conftst1.h with # Solaris 8's {/usr,}/bin/sh. touch sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf case $depmode in nosideeffect) # after this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; none) break ;; esac # We check with `-c' and `-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle `-M -o', and we need to detect this. if depmode=$depmode \ source=sub/conftest.c object=sub/conftest.${OBJEXT-o} \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c -o sub/conftest.${OBJEXT-o} sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftest.${OBJEXT-o} sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thusly: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_CC_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_CC_dependencies_compiler_type=none fi fi { $as_echo "$as_me:$LINENO: result: $am_cv_CC_dependencies_compiler_type" >&5 $as_echo "$am_cv_CC_dependencies_compiler_type" >&6; } CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type if test "x$enable_dependency_tracking" != xno \ && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then am__fastdepCC_TRUE= am__fastdepCC_FALSE='#' else am__fastdepCC_TRUE='#' am__fastdepCC_FALSE= fi if test "x$GCC" != "xyes"; then a68g_ac_compiler=no { $as_echo "$as_me:$LINENO: WARNING: gcc is the preferred C compiler; configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: gcc is the preferred C compiler; configuring interpreter-only" >&2;} else cat >>confdefs.h <<\_ACEOF #define HAVE_GCC 1 _ACEOF if test "x$enable_prescott" != "xno"; then CFLAGS="-O3 -fomit-frame-pointer -march=prescott -funroll-loops" enable_pic="no" fi { $as_echo "$as_me:$LINENO: checking whether $CC accepts -pedantic" >&5 $as_echo_n "checking whether $CC accepts -pedantic... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -pedantic" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking whether $CC accepts -W" >&5 $as_echo_n "checking whether $CC accepts -W... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -W" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking whether $CC accepts -Wall" >&5 $as_echo_n "checking whether $CC accepts -Wall... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wall" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking whether $CC accepts -Wextra" >&5 $as_echo_n "checking whether $CC accepts -Wextra... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wextra" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking whether $CC accepts -Wshadow" >&5 $as_echo_n "checking whether $CC accepts -Wshadow... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wshadow" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # A68G_AC_PROG_CC_CFLAGS([-Wconversion]) Too much warnings! { $as_echo "$as_me:$LINENO: checking whether $CC accepts -Wstrict-prototypes" >&5 $as_echo_n "checking whether $CC accepts -Wstrict-prototypes... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wstrict-prototypes" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking whether $CC accepts -Wchar-subscripts" >&5 $as_echo_n "checking whether $CC accepts -Wchar-subscripts... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS -Wchar-subscripts" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 CFLAGS="$a68g_ac_save_CFLAGS" { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # # Test on gcc capabilities. # # # Check -Wl,--export-dynamic, needed for creating shared objects. # # Check whether we can link to a particular function, not just whether we can link. # In fact, we must actually check that the resulting program runs. # a68g_ac_arg="-Wl,--export-dynamic" { $as_echo "$as_me:$LINENO: checking if $CC accepts $a68g_ac_arg" >&5 $as_echo_n "checking if $CC accepts $a68g_ac_arg... " >&6; } a68g_ac_save_LDFLAGS=$LDFLAGS LDFLAGS="$a68g_ac_save_LDFLAGS $a68g_ac_arg" if test "$cross_compiling" = yes; then { $as_echo "$as_me:$LINENO: result: assuming no" >&5 $as_echo "assuming no" >&6; } { $as_echo "$as_me:$LINENO: WARNING: --export-dynamic is not accepted; configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: --export-dynamic is not accepted; configuring interpreter-only" >&2;} a68g_ac_compiler=no LDFLAGS=$a68g_ac_save_LDFLAGS else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ extern void exit (); void (*fptr) () = exit; int main () { ; return 0; } _ACEOF rm -f conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } cat >>confdefs.h <<\_ACEOF #define HAVE_EXPORT_DYNAMIC 1 _ACEOF else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:$LINENO: WARNING: --export-dynamic is not accepted; configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: --export-dynamic is not accepted; configuring interpreter-only" >&2;} a68g_ac_compiler=no LDFLAGS=$a68g_ac_save_LDFLAGS fi rm -rf conftest.dSYM rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi if test "x$a68g_ac_compiler" = "xyes"; then EXPORT_DYNAMIC_TRUE= EXPORT_DYNAMIC_FALSE='#' else EXPORT_DYNAMIC_TRUE='#' EXPORT_DYNAMIC_FALSE= fi # # Optionally, tune for a specific processor. # if test "x$enable_arch" != "xno"; then { $as_echo "$as_me:$LINENO: checking whether $CC accepts -march=$enable_arch" >&5 $as_echo_n "checking whether $CC accepts -march=$enable_arch... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS a68g_ac_march="-march=$enable_arch" CFLAGS="$a68g_ac_save_CFLAGS $a68g_ac_march" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } cat >>confdefs.h <<_ACEOF #define HAVE_TUNING "$a68g_ac_march" _ACEOF else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:$LINENO: WARNING: your CPU name is not accepted; resetting to default" >&5 $as_echo "$as_me: WARNING: your CPU name is not accepted; resetting to default" >&2;} CFLAGS="$a68g_ac_save_CFLAGS" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi # # Some platforms want another or no PIC option. # if test "x$enable_compiler" = "xyes"; then if test "x$enable_pic" != "xno"; then { $as_echo "$as_me:$LINENO: checking whether $CC accepts $enable_pic" >&5 $as_echo_n "checking whether $CC accepts $enable_pic... " >&6; } a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS $enable_pic" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } cat >>confdefs.h <<_ACEOF #define HAVE_PIC "$enable_pic" _ACEOF else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } { $as_echo "$as_me:$LINENO: WARNING: your PIC option is not accepted; configuring interpreter-only" >&5 $as_echo "$as_me: WARNING: your PIC option is not accepted; configuring interpreter-only" >&2;} fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS="$a68g_ac_save_CFLAGS" fi fi if test "x$CC" != xcc; then { $as_echo "$as_me:$LINENO: checking whether $CC and cc understand -c and -o together" >&5 $as_echo_n "checking whether $CC and cc understand -c and -o together... " >&6; } else { $as_echo "$as_me:$LINENO: checking whether cc understands -c and -o together" >&5 $as_echo_n "checking whether cc understands -c and -o together... " >&6; } fi set dummy $CC; ac_cc=`$as_echo "$2" | sed 's/[^a-zA-Z0-9_]/_/g;s/^[0-9]/_/'` if { as_var=ac_cv_prog_cc_${ac_cc}_c_o; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF # Make sure it works both with $CC and with simple cc. # We do the test twice because some compilers refuse to overwrite an # existing .o file with -o, though they will create one. ac_try='$CC -c conftest.$ac_ext -o conftest2.$ac_objext >&5' rm -f conftest2.* if { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && test -f conftest2.$ac_objext && { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then eval ac_cv_prog_cc_${ac_cc}_c_o=yes if test "x$CC" != xcc; then # Test first that cc exists at all. if { ac_try='cc -c conftest.$ac_ext >&5' { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_try='cc -c conftest.$ac_ext -o conftest2.$ac_objext >&5' rm -f conftest2.* if { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && test -f conftest2.$ac_objext && { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # cc works too. : else # cc exists but doesn't like -o. eval ac_cv_prog_cc_${ac_cc}_c_o=no fi fi fi else eval ac_cv_prog_cc_${ac_cc}_c_o=no fi rm -f core conftest* fi if eval test \$ac_cv_prog_cc_${ac_cc}_c_o = yes; then { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } cat >>confdefs.h <<\_ACEOF #define NO_MINUS_C_MINUS_O 1 _ACEOF fi # FIXME: we rely on the cache variable name because # there is no other way. set dummy $CC ac_cc=`echo $2 | sed 's/[^a-zA-Z0-9_]/_/g;s/^[0-9]/_/'` if eval "test \"`echo '$ac_cv_prog_cc_'${ac_cc}_c_o`\" != yes"; then # Losing compiler, so override with the script. # FIXME: It is wrong to rewrite CC. # But if we don't then we get into trouble of one sort or another. # A longer-term fix would be to have automake use am__CC in this case, # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" CC="$am_aux_dir/compile $CC" fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if test "${ac_cv_prog_CPP+set}" = set; then $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then # Broken: success on invalid input. continue else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:$LINENO: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then # Broken: success on invalid input. continue else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { { $as_echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details." >&5 $as_echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; }; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:$LINENO: types..." >&5 $as_echo "$as_me: types..." >&6;} { $as_echo "$as_me:$LINENO: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if test "${ac_cv_path_GREP+set}" = set; then $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break ac_count=`expr $ac_count + 1` if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then { { $as_echo "$as_me:$LINENO: error: no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5 $as_echo "$as_me: error: no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;} { (exit 1); exit 1; }; } fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:$LINENO: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } if test "${ac_cv_path_EGREP+set}" = set; then $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then ac_path_EGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break ac_count=`expr $ac_count + 1` if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then { { $as_echo "$as_me:$LINENO: error: no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5 $as_echo "$as_me: error: no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;} { (exit 1); exit 1; }; } fi else ac_cv_path_EGREP=$EGREP fi fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" { $as_echo "$as_me:$LINENO: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if test "${ac_cv_header_stdc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_header_stdc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF rm -f conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then : else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi rm -rf conftest.dSYM rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then cat >>confdefs.h <<\_ACEOF #define STDC_HEADERS 1 _ACEOF fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then eval "$as_ac_Header=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_Header=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done { $as_echo "$as_me:$LINENO: checking whether char is unsigned" >&5 $as_echo_n "checking whether char is unsigned... " >&6; } if test "${ac_cv_c_char_unsigned+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(((char) -1) < 0)]; test_array [0] = 0 ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_c_char_unsigned=no else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_c_char_unsigned=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_c_char_unsigned" >&5 $as_echo "$ac_cv_c_char_unsigned" >&6; } if test $ac_cv_c_char_unsigned = yes && test "$GCC" != yes; then cat >>confdefs.h <<\_ACEOF #define __CHAR_UNSIGNED__ 1 _ACEOF fi { $as_echo "$as_me:$LINENO: checking for mode_t" >&5 $as_echo_n "checking for mode_t... " >&6; } if test "${ac_cv_type_mode_t+set}" = set; then $as_echo_n "(cached) " >&6 else ac_cv_type_mode_t=no cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof (mode_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof ((mode_t))) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_mode_t=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_type_mode_t" >&5 $as_echo "$ac_cv_type_mode_t" >&6; } if test "x$ac_cv_type_mode_t" = x""yes; then : else cat >>confdefs.h <<_ACEOF #define mode_t int _ACEOF fi { $as_echo "$as_me:$LINENO: checking for size_t" >&5 $as_echo_n "checking for size_t... " >&6; } if test "${ac_cv_type_size_t+set}" = set; then $as_echo_n "(cached) " >&6 else ac_cv_type_size_t=no cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof (size_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof ((size_t))) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_size_t=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_type_size_t" >&5 $as_echo "$ac_cv_type_size_t" >&6; } if test "x$ac_cv_type_size_t" = x""yes; then : else cat >>confdefs.h <<_ACEOF #define size_t unsigned int _ACEOF fi { $as_echo "$as_me:$LINENO: checking for ssize_t" >&5 $as_echo_n "checking for ssize_t... " >&6; } if test "${ac_cv_type_ssize_t+set}" = set; then $as_echo_n "(cached) " >&6 else ac_cv_type_ssize_t=no cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof (ssize_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if (sizeof ((ssize_t))) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_ssize_t=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_type_ssize_t" >&5 $as_echo "$ac_cv_type_ssize_t" >&6; } if test "x$ac_cv_type_ssize_t" = x""yes; then : else cat >>confdefs.h <<_ACEOF #define ssize_t int _ACEOF fi { $as_echo "$as_me:$LINENO: checking for uint16_t" >&5 $as_echo_n "checking for uint16_t... " >&6; } if test "${ac_cv_c_uint16_t+set}" = set; then $as_echo_n "(cached) " >&6 else ac_cv_c_uint16_t=no for ac_type in 'uint16_t' 'unsigned int' 'unsigned long int' \ 'unsigned long long int' 'unsigned short int' 'unsigned char'; do cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(($ac_type) -1 >> (16 - 1) == 1)]; test_array [0] = 0 ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then case $ac_type in uint16_t) ac_cv_c_uint16_t=yes ;; *) ac_cv_c_uint16_t=$ac_type ;; esac else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext test "$ac_cv_c_uint16_t" != no && break done fi { $as_echo "$as_me:$LINENO: result: $ac_cv_c_uint16_t" >&5 $as_echo "$ac_cv_c_uint16_t" >&6; } case $ac_cv_c_uint16_t in #( no|yes) ;; #( *) cat >>confdefs.h <<_ACEOF #define uint16_t $ac_cv_c_uint16_t _ACEOF ;; esac { $as_echo "$as_me:$LINENO: checking __off_t or off_t" >&5 $as_echo_n "checking __off_t or off_t... " >&6; } cat >conftest.$ac_ext <<_ACEOF #include #include __off_t dummy; _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: __off_t" >&5 $as_echo "__off_t" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { $as_echo "$as_me:$LINENO: result: off_t" >&5 $as_echo "off_t" >&6; } cat >>confdefs.h <<\_ACEOF #define __off_t off_t _ACEOF fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking __pid_t or pid_t" >&5 $as_echo_n "checking __pid_t or pid_t... " >&6; } cat >conftest.$ac_ext <<_ACEOF #include #include __pid_t dummy; _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: __pid_t" >&5 $as_echo "__pid_t" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { $as_echo "$as_me:$LINENO: result: pid_t" >&5 $as_echo "pid_t" >&6; } cat >>confdefs.h <<\_ACEOF #define __pid_t pid_t _ACEOF fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: checking __mode_t or mode_t" >&5 $as_echo_n "checking __mode_t or mode_t... " >&6; } cat >conftest.$ac_ext <<_ACEOF #include #include __mode_t dummy; _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then { $as_echo "$as_me:$LINENO: result: __mode_t" >&5 $as_echo "__mode_t" >&6; } else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { $as_echo "$as_me:$LINENO: result: mode_t" >&5 $as_echo "mode_t" >&6; } cat >>confdefs.h <<\_ACEOF #define __mode_t mode_t _ACEOF fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # # Extra include directories. # { $as_echo "$as_me:$LINENO: extra include directories..." >&5 $as_echo "$as_me: extra include directories..." >&6;} if test -d /usr/local/pgsql/include; then cat >>confdefs.h <<\_ACEOF #define HAVE_USR_LOCAL_PGSQL_INCLUDE 1 _ACEOF CFLAGS="$CFLAGS -I/usr/local/pgsql/include" CPPFLAGS="$CPPFLAGS -I/usr/local/pgsql/include" CXXFLAGS="$CXXFLAGS -I/usr/local/pgsql/include" LDFLAGS="$LDFLAGS -L/usr/local/pgsql/lib" fi if test -d /usr/pkg/pgsql/include; then cat >>confdefs.h <<\_ACEOF #define HAVE_USR_PKG_PGSQL_INCLUDE 1 _ACEOF CFLAGS="$CFLAGS -I/usr/pkg/pgsql/include" CPPFLAGS="$CPPFLAGS -I/usr/pkg/pgsql/include" CXXFLAGS="$CXXFLAGS -I/usr/pkg/pgsql/include" LDFLAGS="$LDFLAGS -L/usr/pkg/pgsql/lib" fi if test -d /opt/local/pgsql/include; then cat >>confdefs.h <<\_ACEOF #define HAVE_OPT_LOCAL_PGSQL_INCLUDE 1 _ACEOF CFLAGS="$CFLAGS -I/opt/local/pgsql/include" CPPFLAGS="$CPPFLAGS -I/opt/local/pgsql/include" CXXFLAGS="$CXXFLAGS -I/opt/local/pgsql/include" LDFLAGS="$LDFLAGS -L/opt/local/pgsql/lib" fi # # Checks for header files. # { $as_echo "$as_me:$LINENO: standard header files..." >&5 $as_echo "$as_me: standard header files..." >&6;} # # test is GSL proof. # for ac_header in math.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done { $as_echo "$as_me:$LINENO: checking for cos in -lm" >&5 $as_echo_n "checking for cos in -lm... " >&6; } if test "${ac_cv_lib_m_cos+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lm $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char cos (); int main () { return cos (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_m_cos=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_m_cos=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_m_cos" >&5 $as_echo "$ac_cv_lib_m_cos" >&6; } if test "x$ac_cv_lib_m_cos" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBM 1 _ACEOF LIBS="-lm $LIBS" fi { $as_echo "$as_me:$LINENO: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if test "${ac_cv_header_stdc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_header_stdc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF rm -f conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then : else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi rm -rf conftest.dSYM rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi { $as_echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then cat >>confdefs.h <<\_ACEOF #define STDC_HEADERS 1 _ACEOF fi { $as_echo "$as_me:$LINENO: checking whether to enable assertions" >&5 $as_echo_n "checking whether to enable assertions... " >&6; } # Check whether --enable-assert was given. if test "${enable_assert+set}" = set; then enableval=$enable_assert; { $as_echo "$as_me:$LINENO: result: no" >&5 $as_echo "no" >&6; } cat >>confdefs.h <<\_ACEOF #define NDEBUG 1 _ACEOF else { $as_echo "$as_me:$LINENO: result: yes" >&5 $as_echo "yes" >&6; } fi ac_header_dirent=no for ac_hdr in dirent.h sys/ndir.h sys/dir.h ndir.h; do as_ac_Header=`$as_echo "ac_cv_header_dirent_$ac_hdr" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_hdr that defines DIR" >&5 $as_echo_n "checking for $ac_hdr that defines DIR... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include <$ac_hdr> int main () { if ((DIR *) 0) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then eval "$as_ac_Header=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_Header=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_hdr" | $as_tr_cpp` 1 _ACEOF ac_header_dirent=$ac_hdr; break fi done # Two versions of opendir et al. are in -ldir and -lx on SCO Xenix. if test $ac_header_dirent = dirent.h; then { $as_echo "$as_me:$LINENO: checking for library containing opendir" >&5 $as_echo_n "checking for library containing opendir... " >&6; } if test "${ac_cv_search_opendir+set}" = set; then $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char opendir (); int main () { return opendir (); ; return 0; } _ACEOF for ac_lib in '' dir; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_search_opendir=$ac_res else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext if test "${ac_cv_search_opendir+set}" = set; then break fi done if test "${ac_cv_search_opendir+set}" = set; then : else ac_cv_search_opendir=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_search_opendir" >&5 $as_echo "$ac_cv_search_opendir" >&6; } ac_res=$ac_cv_search_opendir if test "$ac_res" != no; then test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi else { $as_echo "$as_me:$LINENO: checking for library containing opendir" >&5 $as_echo_n "checking for library containing opendir... " >&6; } if test "${ac_cv_search_opendir+set}" = set; then $as_echo_n "(cached) " >&6 else ac_func_search_save_LIBS=$LIBS cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char opendir (); int main () { return opendir (); ; return 0; } _ACEOF for ac_lib in '' x; do if test -z "$ac_lib"; then ac_res="none required" else ac_res=-l$ac_lib LIBS="-l$ac_lib $ac_func_search_save_LIBS" fi rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_search_opendir=$ac_res else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext if test "${ac_cv_search_opendir+set}" = set; then break fi done if test "${ac_cv_search_opendir+set}" = set; then : else ac_cv_search_opendir=no fi rm conftest.$ac_ext LIBS=$ac_func_search_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_search_opendir" >&5 $as_echo "$ac_cv_search_opendir" >&6; } ac_res=$ac_cv_search_opendir if test "$ac_res" != no; then test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" fi fi { $as_echo "$as_me:$LINENO: checking for sys/wait.h that is POSIX.1 compatible" >&5 $as_echo_n "checking for sys/wait.h that is POSIX.1 compatible... " >&6; } if test "${ac_cv_header_sys_wait_h+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #ifndef WEXITSTATUS # define WEXITSTATUS(stat_val) ((unsigned int) (stat_val) >> 8) #endif #ifndef WIFEXITED # define WIFEXITED(stat_val) (((stat_val) & 255) == 0) #endif int main () { int s; wait (&s); s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_header_sys_wait_h=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_sys_wait_h=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_header_sys_wait_h" >&5 $as_echo "$ac_cv_header_sys_wait_h" >&6; } if test $ac_cv_header_sys_wait_h = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_SYS_WAIT_H 1 _ACEOF fi { $as_echo "$as_me:$LINENO: checking whether termios.h defines TIOCGWINSZ" >&5 $as_echo_n "checking whether termios.h defines TIOCGWINSZ... " >&6; } if test "${ac_cv_sys_tiocgwinsz_in_termios_h+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #ifdef TIOCGWINSZ yes #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "yes" >/dev/null 2>&1; then ac_cv_sys_tiocgwinsz_in_termios_h=yes else ac_cv_sys_tiocgwinsz_in_termios_h=no fi rm -f conftest* fi { $as_echo "$as_me:$LINENO: result: $ac_cv_sys_tiocgwinsz_in_termios_h" >&5 $as_echo "$ac_cv_sys_tiocgwinsz_in_termios_h" >&6; } if test $ac_cv_sys_tiocgwinsz_in_termios_h != yes; then { $as_echo "$as_me:$LINENO: checking whether sys/ioctl.h defines TIOCGWINSZ" >&5 $as_echo_n "checking whether sys/ioctl.h defines TIOCGWINSZ... " >&6; } if test "${ac_cv_sys_tiocgwinsz_in_sys_ioctl_h+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #ifdef TIOCGWINSZ yes #endif _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "yes" >/dev/null 2>&1; then ac_cv_sys_tiocgwinsz_in_sys_ioctl_h=yes else ac_cv_sys_tiocgwinsz_in_sys_ioctl_h=no fi rm -f conftest* fi { $as_echo "$as_me:$LINENO: result: $ac_cv_sys_tiocgwinsz_in_sys_ioctl_h" >&5 $as_echo "$ac_cv_sys_tiocgwinsz_in_sys_ioctl_h" >&6; } if test $ac_cv_sys_tiocgwinsz_in_sys_ioctl_h = yes; then cat >>confdefs.h <<\_ACEOF #define GWINSZ_IN_SYS_IOCTL 1 _ACEOF fi fi for ac_header in assert.h ctype.h errno.h fcntl.h float.h limits.h netdb.h netinet/in.h regex.h setjmp.h signal.h stdarg.h stddef.h stdio.h sys/ioctl.h sys/resource.h sys/socket.h sys/time.h termios.h time.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done # # Functions we expect # { $as_echo "$as_me:$LINENO: standard functions..." >&5 $as_echo "$as_me: standard functions..." >&6;} for ac_func in exit do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in fprintf do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in free do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in longjmp do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in malloc do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in memcpy do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in memmove do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in memset do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in printf do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in setjmp do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in signal do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in snprintf do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in strcmp do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in strncmp do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done for ac_func in strncpy do as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` { $as_echo "$as_me:$LINENO: checking for $ac_func" >&5 $as_echo_n "checking for $ac_func... " >&6; } if { as_var=$as_ac_var; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$ac_func || defined __stub___$ac_func choke me #endif int main () { return $ac_func (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then eval "$as_ac_var=yes" else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext fi ac_res=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } as_val=`eval 'as_val=${'$as_ac_var'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done { $as_echo "$as_me:$LINENO: optional headers and libraries..." >&5 $as_echo "$as_me: optional headers and libraries..." >&6;} if test "x$enable_curses" = "xyes"; then for ac_header in curses.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_curses=no fi done if test "x$enable_curses" = "xno"; then for ac_header in ncurses/curses.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF enable_curses=yes fi done fi if test "x$enable_curses" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for initscr in -lncurses" >&5 $as_echo_n "checking for initscr in -lncurses... " >&6; } if test "${ac_cv_lib_ncurses_initscr+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lncurses $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char initscr (); int main () { return initscr (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_ncurses_initscr=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_ncurses_initscr=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_ncurses_initscr" >&5 $as_echo "$ac_cv_lib_ncurses_initscr" >&6; } if test "x$ac_cv_lib_ncurses_initscr" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBNCURSES 1 _ACEOF LIBS="-lncurses $LIBS" else enable_curses=no fi if test "x$enable_curses" = "xyes"; then if test "x$enable_readline" = "xyes"; then for ac_header in readline/readline.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_readline=no fi done for ac_header in readline/history.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_readline=no fi done if test "x$enable_readline" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for readline in -lreadline" >&5 $as_echo_n "checking for readline in -lreadline... " >&6; } if test "${ac_cv_lib_readline_readline+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lreadline -lcurses $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char readline (); int main () { return readline (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_readline_readline=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_readline_readline=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_readline_readline" >&5 $as_echo "$ac_cv_lib_readline_readline" >&6; } if test "x$ac_cv_lib_readline_readline" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBREADLINE 1 _ACEOF LIBS="-lreadline $LIBS" else enable_readline=no fi if test "x$enable_readline" = "xyes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_READLINE 1 _ACEOF fi fi fi fi if test "x$enable_curses" = "xno"; then { $as_echo "$as_me:$LINENO: checking for initscr in -lcurses" >&5 $as_echo_n "checking for initscr in -lcurses... " >&6; } if test "${ac_cv_lib_curses_initscr+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lcurses $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char initscr (); int main () { return initscr (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_curses_initscr=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_curses_initscr=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_curses_initscr" >&5 $as_echo "$ac_cv_lib_curses_initscr" >&6; } if test "x$ac_cv_lib_curses_initscr" = x""yes; then enable_curses=yes fi fi if test "x$enable_curses" = "xyes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_CURSES 1 _ACEOF fi fi fi if test "x$enable_plotutils" = "xyes"; then { $as_echo "$as_me:$LINENO: GNU plotutils..." >&5 $as_echo "$as_me: GNU plotutils..." >&6;} for ac_header in plot.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_plotutils=no fi done { $as_echo "$as_me:$LINENO: checking whether pl_alabel_r is declared" >&5 $as_echo_n "checking whether pl_alabel_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_alabel_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_alabel_r (void) pl_alabel_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_alabel_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_alabel_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_alabel_r" >&5 $as_echo "$ac_cv_have_decl_pl_alabel_r" >&6; } if test "x$ac_cv_have_decl_pl_alabel_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_alabel_r in -lplot" >&5 $as_echo_n "checking for pl_alabel_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_alabel_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_alabel_r (); int main () { return pl_alabel_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_alabel_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_alabel_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_alabel_r" >&5 $as_echo "$ac_cv_lib_plot_pl_alabel_r" >&6; } if test "x$ac_cv_lib_plot_pl_alabel_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi if test "x$enable_plotutils" = "xyes"; then { $as_echo "$as_me:$LINENO: checking whether pl_bgcolor_r is declared" >&5 $as_echo_n "checking whether pl_bgcolor_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_bgcolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_bgcolor_r (void) pl_bgcolor_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_bgcolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_bgcolor_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_bgcolor_r" >&5 $as_echo "$ac_cv_have_decl_pl_bgcolor_r" >&6; } if test "x$ac_cv_have_decl_pl_bgcolor_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_bgcolor_r in -lplot" >&5 $as_echo_n "checking for pl_bgcolor_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_bgcolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_bgcolor_r (); int main () { return pl_bgcolor_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_bgcolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_bgcolor_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_bgcolor_r" >&5 $as_echo "$ac_cv_lib_plot_pl_bgcolor_r" >&6; } if test "x$ac_cv_lib_plot_pl_bgcolor_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_bgcolorname_r is declared" >&5 $as_echo_n "checking whether pl_bgcolorname_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_bgcolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_bgcolorname_r (void) pl_bgcolorname_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_bgcolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_bgcolorname_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_bgcolorname_r" >&5 $as_echo "$ac_cv_have_decl_pl_bgcolorname_r" >&6; } if test "x$ac_cv_have_decl_pl_bgcolorname_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_bgcolorname_r in -lplot" >&5 $as_echo_n "checking for pl_bgcolorname_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_bgcolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_bgcolorname_r (); int main () { return pl_bgcolorname_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_bgcolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_bgcolorname_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_bgcolorname_r" >&5 $as_echo "$ac_cv_lib_plot_pl_bgcolorname_r" >&6; } if test "x$ac_cv_lib_plot_pl_bgcolorname_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_color_r is declared" >&5 $as_echo_n "checking whether pl_color_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_color_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_color_r (void) pl_color_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_color_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_color_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_color_r" >&5 $as_echo "$ac_cv_have_decl_pl_color_r" >&6; } if test "x$ac_cv_have_decl_pl_color_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_color_r in -lplot" >&5 $as_echo_n "checking for pl_color_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_color_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_color_r (); int main () { return pl_color_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_color_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_color_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_color_r" >&5 $as_echo "$ac_cv_lib_plot_pl_color_r" >&6; } if test "x$ac_cv_lib_plot_pl_color_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_colorname_r is declared" >&5 $as_echo_n "checking whether pl_colorname_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_colorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_colorname_r (void) pl_colorname_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_colorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_colorname_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_colorname_r" >&5 $as_echo "$ac_cv_have_decl_pl_colorname_r" >&6; } if test "x$ac_cv_have_decl_pl_colorname_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_colorname_r in -lplot" >&5 $as_echo_n "checking for pl_colorname_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_colorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_colorname_r (); int main () { return pl_colorname_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_colorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_colorname_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_colorname_r" >&5 $as_echo "$ac_cv_lib_plot_pl_colorname_r" >&6; } if test "x$ac_cv_lib_plot_pl_colorname_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_erase_r is declared" >&5 $as_echo_n "checking whether pl_erase_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_erase_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_erase_r (void) pl_erase_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_erase_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_erase_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_erase_r" >&5 $as_echo "$ac_cv_have_decl_pl_erase_r" >&6; } if test "x$ac_cv_have_decl_pl_erase_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_erase_r in -lplot" >&5 $as_echo_n "checking for pl_erase_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_erase_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_erase_r (); int main () { return pl_erase_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_erase_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_erase_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_erase_r" >&5 $as_echo "$ac_cv_lib_plot_pl_erase_r" >&6; } if test "x$ac_cv_lib_plot_pl_erase_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fbox_r is declared" >&5 $as_echo_n "checking whether pl_fbox_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fbox_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fbox_r (void) pl_fbox_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fbox_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fbox_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fbox_r" >&5 $as_echo "$ac_cv_have_decl_pl_fbox_r" >&6; } if test "x$ac_cv_have_decl_pl_fbox_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fbox_r in -lplot" >&5 $as_echo_n "checking for pl_fbox_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fbox_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fbox_r (); int main () { return pl_fbox_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fbox_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fbox_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fbox_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fbox_r" >&6; } if test "x$ac_cv_lib_plot_pl_fbox_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fcircle_r is declared" >&5 $as_echo_n "checking whether pl_fcircle_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fcircle_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fcircle_r (void) pl_fcircle_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fcircle_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fcircle_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fcircle_r" >&5 $as_echo "$ac_cv_have_decl_pl_fcircle_r" >&6; } if test "x$ac_cv_have_decl_pl_fcircle_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fcircle_r in -lplot" >&5 $as_echo_n "checking for pl_fcircle_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fcircle_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fcircle_r (); int main () { return pl_fcircle_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fcircle_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fcircle_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fcircle_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fcircle_r" >&6; } if test "x$ac_cv_lib_plot_pl_fcircle_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fillcolor_r is declared" >&5 $as_echo_n "checking whether pl_fillcolor_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fillcolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fillcolor_r (void) pl_fillcolor_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fillcolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fillcolor_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fillcolor_r" >&5 $as_echo "$ac_cv_have_decl_pl_fillcolor_r" >&6; } if test "x$ac_cv_have_decl_pl_fillcolor_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fillcolor_r in -lplot" >&5 $as_echo_n "checking for pl_fillcolor_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fillcolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fillcolor_r (); int main () { return pl_fillcolor_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fillcolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fillcolor_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fillcolor_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fillcolor_r" >&6; } if test "x$ac_cv_lib_plot_pl_fillcolor_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fillcolorname_r is declared" >&5 $as_echo_n "checking whether pl_fillcolorname_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fillcolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fillcolorname_r (void) pl_fillcolorname_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fillcolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fillcolorname_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fillcolorname_r" >&5 $as_echo "$ac_cv_have_decl_pl_fillcolorname_r" >&6; } if test "x$ac_cv_have_decl_pl_fillcolorname_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fillcolorname_r in -lplot" >&5 $as_echo_n "checking for pl_fillcolorname_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fillcolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fillcolorname_r (); int main () { return pl_fillcolorname_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fillcolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fillcolorname_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fillcolorname_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fillcolorname_r" >&6; } if test "x$ac_cv_lib_plot_pl_fillcolorname_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_filltype_r is declared" >&5 $as_echo_n "checking whether pl_filltype_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_filltype_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_filltype_r (void) pl_filltype_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_filltype_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_filltype_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_filltype_r" >&5 $as_echo "$ac_cv_have_decl_pl_filltype_r" >&6; } if test "x$ac_cv_have_decl_pl_filltype_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_filltype_r in -lplot" >&5 $as_echo_n "checking for pl_filltype_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_filltype_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_filltype_r (); int main () { return pl_filltype_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_filltype_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_filltype_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_filltype_r" >&5 $as_echo "$ac_cv_lib_plot_pl_filltype_r" >&6; } if test "x$ac_cv_lib_plot_pl_filltype_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fline_r is declared" >&5 $as_echo_n "checking whether pl_fline_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fline_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fline_r (void) pl_fline_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fline_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fline_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fline_r" >&5 $as_echo "$ac_cv_have_decl_pl_fline_r" >&6; } if test "x$ac_cv_have_decl_pl_fline_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fline_r in -lplot" >&5 $as_echo_n "checking for pl_fline_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fline_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fline_r (); int main () { return pl_fline_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fline_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fline_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fline_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fline_r" >&6; } if test "x$ac_cv_lib_plot_pl_fline_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fmove_r is declared" >&5 $as_echo_n "checking whether pl_fmove_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fmove_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fmove_r (void) pl_fmove_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fmove_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fmove_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fmove_r" >&5 $as_echo "$ac_cv_have_decl_pl_fmove_r" >&6; } if test "x$ac_cv_have_decl_pl_fmove_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fmove_r in -lplot" >&5 $as_echo_n "checking for pl_fmove_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fmove_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fmove_r (); int main () { return pl_fmove_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fmove_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fmove_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fmove_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fmove_r" >&6; } if test "x$ac_cv_lib_plot_pl_fmove_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fontname_r is declared" >&5 $as_echo_n "checking whether pl_fontname_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fontname_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fontname_r (void) pl_fontname_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fontname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fontname_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fontname_r" >&5 $as_echo "$ac_cv_have_decl_pl_fontname_r" >&6; } if test "x$ac_cv_have_decl_pl_fontname_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fontname_r in -lplot" >&5 $as_echo_n "checking for pl_fontname_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fontname_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fontname_r (); int main () { return pl_fontname_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fontname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fontname_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fontname_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fontname_r" >&6; } if test "x$ac_cv_lib_plot_pl_fontname_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fontsize_r is declared" >&5 $as_echo_n "checking whether pl_fontsize_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fontsize_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fontsize_r (void) pl_fontsize_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fontsize_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fontsize_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fontsize_r" >&5 $as_echo "$ac_cv_have_decl_pl_fontsize_r" >&6; } if test "x$ac_cv_have_decl_pl_fontsize_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fontsize_r in -lplot" >&5 $as_echo_n "checking for pl_fontsize_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fontsize_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fontsize_r (); int main () { return pl_fontsize_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fontsize_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fontsize_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fontsize_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fontsize_r" >&6; } if test "x$ac_cv_lib_plot_pl_fontsize_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_fpoint_r is declared" >&5 $as_echo_n "checking whether pl_fpoint_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_fpoint_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_fpoint_r (void) pl_fpoint_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_fpoint_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_fpoint_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_fpoint_r" >&5 $as_echo "$ac_cv_have_decl_pl_fpoint_r" >&6; } if test "x$ac_cv_have_decl_pl_fpoint_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_fpoint_r in -lplot" >&5 $as_echo_n "checking for pl_fpoint_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_fpoint_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_fpoint_r (); int main () { return pl_fpoint_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_fpoint_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_fpoint_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_fpoint_r" >&5 $as_echo "$ac_cv_lib_plot_pl_fpoint_r" >&6; } if test "x$ac_cv_lib_plot_pl_fpoint_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_linemod_r is declared" >&5 $as_echo_n "checking whether pl_linemod_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_linemod_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_linemod_r (void) pl_linemod_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_linemod_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_linemod_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_linemod_r" >&5 $as_echo "$ac_cv_have_decl_pl_linemod_r" >&6; } if test "x$ac_cv_have_decl_pl_linemod_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_linemod_r in -lplot" >&5 $as_echo_n "checking for pl_linemod_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_linemod_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_linemod_r (); int main () { return pl_linemod_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_linemod_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_linemod_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_linemod_r" >&5 $as_echo "$ac_cv_lib_plot_pl_linemod_r" >&6; } if test "x$ac_cv_lib_plot_pl_linemod_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_linewidth_r is declared" >&5 $as_echo_n "checking whether pl_linewidth_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_linewidth_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_linewidth_r (void) pl_linewidth_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_linewidth_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_linewidth_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_linewidth_r" >&5 $as_echo "$ac_cv_have_decl_pl_linewidth_r" >&6; } if test "x$ac_cv_have_decl_pl_linewidth_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_linewidth_r in -lplot" >&5 $as_echo_n "checking for pl_linewidth_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_linewidth_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_linewidth_r (); int main () { return pl_linewidth_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_linewidth_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_linewidth_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_linewidth_r" >&5 $as_echo "$ac_cv_lib_plot_pl_linewidth_r" >&6; } if test "x$ac_cv_lib_plot_pl_linewidth_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_newplparams is declared" >&5 $as_echo_n "checking whether pl_newplparams is declared... " >&6; } if test "${ac_cv_have_decl_pl_newplparams+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_newplparams (void) pl_newplparams; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_newplparams=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_newplparams=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_newplparams" >&5 $as_echo "$ac_cv_have_decl_pl_newplparams" >&6; } if test "x$ac_cv_have_decl_pl_newplparams" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_newplparams in -lplot" >&5 $as_echo_n "checking for pl_newplparams in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_newplparams+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_newplparams (); int main () { return pl_newplparams (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_newplparams=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_newplparams=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_newplparams" >&5 $as_echo "$ac_cv_lib_plot_pl_newplparams" >&6; } if test "x$ac_cv_lib_plot_pl_newplparams" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_openpl_r is declared" >&5 $as_echo_n "checking whether pl_openpl_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_openpl_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_openpl_r (void) pl_openpl_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_openpl_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_openpl_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_openpl_r" >&5 $as_echo "$ac_cv_have_decl_pl_openpl_r" >&6; } if test "x$ac_cv_have_decl_pl_openpl_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_openpl_r in -lplot" >&5 $as_echo_n "checking for pl_openpl_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_openpl_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_openpl_r (); int main () { return pl_openpl_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_openpl_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_openpl_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_openpl_r" >&5 $as_echo "$ac_cv_lib_plot_pl_openpl_r" >&6; } if test "x$ac_cv_lib_plot_pl_openpl_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_pencolor_r is declared" >&5 $as_echo_n "checking whether pl_pencolor_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_pencolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_pencolor_r (void) pl_pencolor_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_pencolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_pencolor_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_pencolor_r" >&5 $as_echo "$ac_cv_have_decl_pl_pencolor_r" >&6; } if test "x$ac_cv_have_decl_pl_pencolor_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_pencolor_r in -lplot" >&5 $as_echo_n "checking for pl_pencolor_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_pencolor_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_pencolor_r (); int main () { return pl_pencolor_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_pencolor_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_pencolor_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_pencolor_r" >&5 $as_echo "$ac_cv_lib_plot_pl_pencolor_r" >&6; } if test "x$ac_cv_lib_plot_pl_pencolor_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_pencolorname_r is declared" >&5 $as_echo_n "checking whether pl_pencolorname_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_pencolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_pencolorname_r (void) pl_pencolorname_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_pencolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_pencolorname_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_pencolorname_r" >&5 $as_echo "$ac_cv_have_decl_pl_pencolorname_r" >&6; } if test "x$ac_cv_have_decl_pl_pencolorname_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_pencolorname_r in -lplot" >&5 $as_echo_n "checking for pl_pencolorname_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_pencolorname_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_pencolorname_r (); int main () { return pl_pencolorname_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_pencolorname_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_pencolorname_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_pencolorname_r" >&5 $as_echo "$ac_cv_lib_plot_pl_pencolorname_r" >&6; } if test "x$ac_cv_lib_plot_pl_pencolorname_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_setplparam is declared" >&5 $as_echo_n "checking whether pl_setplparam is declared... " >&6; } if test "${ac_cv_have_decl_pl_setplparam+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_setplparam (void) pl_setplparam; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_setplparam=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_setplparam=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_setplparam" >&5 $as_echo "$ac_cv_have_decl_pl_setplparam" >&6; } if test "x$ac_cv_have_decl_pl_setplparam" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_setplparam in -lplot" >&5 $as_echo_n "checking for pl_setplparam in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_setplparam+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_setplparam (); int main () { return pl_setplparam (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_setplparam=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_setplparam=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_setplparam" >&5 $as_echo "$ac_cv_lib_plot_pl_setplparam" >&6; } if test "x$ac_cv_lib_plot_pl_setplparam" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_space_r is declared" >&5 $as_echo_n "checking whether pl_space_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_space_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_space_r (void) pl_space_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_space_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_space_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_space_r" >&5 $as_echo "$ac_cv_have_decl_pl_space_r" >&6; } if test "x$ac_cv_have_decl_pl_space_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_space_r in -lplot" >&5 $as_echo_n "checking for pl_space_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_space_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_space_r (); int main () { return pl_space_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_space_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_space_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_space_r" >&5 $as_echo "$ac_cv_lib_plot_pl_space_r" >&6; } if test "x$ac_cv_lib_plot_pl_space_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking whether pl_textangle_r is declared" >&5 $as_echo_n "checking whether pl_textangle_r is declared... " >&6; } if test "${ac_cv_have_decl_pl_textangle_r+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #ifndef pl_textangle_r (void) pl_textangle_r; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pl_textangle_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pl_textangle_r=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pl_textangle_r" >&5 $as_echo "$ac_cv_have_decl_pl_textangle_r" >&6; } if test "x$ac_cv_have_decl_pl_textangle_r" = x""yes; then : else enable_plotutils=no fi { $as_echo "$as_me:$LINENO: checking for pl_textangle_r in -lplot" >&5 $as_echo_n "checking for pl_textangle_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_textangle_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_textangle_r (); int main () { return pl_textangle_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_textangle_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_textangle_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_textangle_r" >&5 $as_echo "$ac_cv_lib_plot_pl_textangle_r" >&6; } if test "x$ac_cv_lib_plot_pl_textangle_r" = x""yes; then a68g_unexpected=yes else enable_plotutils=no fi fi if test "x$enable_plotutils" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for pl_alabel_r in -lplot" >&5 $as_echo_n "checking for pl_alabel_r in -lplot... " >&6; } if test "${ac_cv_lib_plot_pl_alabel_r+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lplot $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pl_alabel_r (); int main () { return pl_alabel_r (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_plot_pl_alabel_r=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_plot_pl_alabel_r=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_plot_pl_alabel_r" >&5 $as_echo "$ac_cv_lib_plot_pl_alabel_r" >&6; } if test "x$ac_cv_lib_plot_pl_alabel_r" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBPLOT 1 _ACEOF LIBS="-lplot $LIBS" fi cat >>confdefs.h <<\_ACEOF #define HAVE_GNU_PLOTUTILS 1 _ACEOF fi fi if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:$LINENO: GNU scientific library..." >&5 $as_echo "$as_me: GNU scientific library..." >&6;} for ac_header in gsl/gsl_blas.h gsl/gsl_complex.h gsl/gsl_complex_math.h gsl/gsl_errno.h gsl/gsl_fft_complex.h gsl/gsl_integration.h gsl/gsl_linalg.h gsl/gsl_math.h gsl/gsl_matrix.h gsl/gsl_permutation.h gsl/gsl_sf.h gsl/gsl_vector.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_gsl=no fi done { $as_echo "$as_me:$LINENO: checking for cblas_dgemm in -lgslcblas" >&5 $as_echo_n "checking for cblas_dgemm in -lgslcblas... " >&6; } if test "${ac_cv_lib_gslcblas_cblas_dgemm+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgslcblas $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char cblas_dgemm (); int main () { return cblas_dgemm (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gslcblas_cblas_dgemm=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gslcblas_cblas_dgemm=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gslcblas_cblas_dgemm" >&5 $as_echo "$ac_cv_lib_gslcblas_cblas_dgemm" >&6; } if test "x$ac_cv_lib_gslcblas_cblas_dgemm" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBGSLCBLAS 1 _ACEOF LIBS="-lgslcblas $LIBS" else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_ddot is declared" >&5 $as_echo_n "checking whether gsl_blas_ddot is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_ddot+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_ddot (void) gsl_blas_ddot; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_ddot=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_ddot=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_ddot" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_ddot" >&6; } if test "x$ac_cv_have_decl_gsl_blas_ddot" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_ddot in -lgsl" >&5 $as_echo_n "checking for gsl_blas_ddot in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_ddot+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_ddot (); int main () { return gsl_blas_ddot (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_ddot=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_ddot=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_ddot" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_ddot" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_ddot" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:$LINENO: checking whether gsl_blas_dgemm is declared" >&5 $as_echo_n "checking whether gsl_blas_dgemm is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_dgemm+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_dgemm (void) gsl_blas_dgemm; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_dgemm=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_dgemm=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_dgemm" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_dgemm" >&6; } if test "x$ac_cv_have_decl_gsl_blas_dgemm" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_dgemm in -lgsl" >&5 $as_echo_n "checking for gsl_blas_dgemm in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_dgemm+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_dgemm (); int main () { return gsl_blas_dgemm (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_dgemm=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_dgemm=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_dgemm" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_dgemm" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_dgemm" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_dgemv is declared" >&5 $as_echo_n "checking whether gsl_blas_dgemv is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_dgemv+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_dgemv (void) gsl_blas_dgemv; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_dgemv=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_dgemv=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_dgemv" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_dgemv" >&6; } if test "x$ac_cv_have_decl_gsl_blas_dgemv" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_dgemv in -lgsl" >&5 $as_echo_n "checking for gsl_blas_dgemv in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_dgemv+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_dgemv (); int main () { return gsl_blas_dgemv (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_dgemv=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_dgemv=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_dgemv" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_dgemv" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_dgemv" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zaxpy is declared" >&5 $as_echo_n "checking whether gsl_blas_zaxpy is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zaxpy+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zaxpy (void) gsl_blas_zaxpy; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zaxpy=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zaxpy=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zaxpy" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zaxpy" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zaxpy" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zaxpy in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zaxpy in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zaxpy+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zaxpy (); int main () { return gsl_blas_zaxpy (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zaxpy=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zaxpy=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zaxpy" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zaxpy" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zaxpy" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zdotc is declared" >&5 $as_echo_n "checking whether gsl_blas_zdotc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zdotc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zdotc (void) gsl_blas_zdotc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zdotc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zdotc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zdotc" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zdotc" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zdotc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zdotc in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zdotc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zdotc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zdotc (); int main () { return gsl_blas_zdotc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zdotc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zdotc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zdotc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zdotc" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zdotc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zdscal is declared" >&5 $as_echo_n "checking whether gsl_blas_zdscal is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zdscal+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zdscal (void) gsl_blas_zdscal; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zdscal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zdscal=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zdscal" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zdscal" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zdscal" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zdscal in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zdscal in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zdscal+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zdscal (); int main () { return gsl_blas_zdscal (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zdscal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zdscal=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zdscal" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zdscal" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zdscal" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zgemm is declared" >&5 $as_echo_n "checking whether gsl_blas_zgemm is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zgemm+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zgemm (void) gsl_blas_zgemm; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zgemm=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zgemm=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zgemm" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zgemm" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zgemm" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zgemm in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zgemm in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zgemm+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zgemm (); int main () { return gsl_blas_zgemm (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zgemm=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zgemm=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zgemm" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zgemm" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zgemm" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zgemv is declared" >&5 $as_echo_n "checking whether gsl_blas_zgemv is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zgemv+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zgemv (void) gsl_blas_zgemv; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zgemv=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zgemv=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zgemv" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zgemv" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zgemv" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zgemv in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zgemv in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zgemv+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zgemv (); int main () { return gsl_blas_zgemv (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zgemv=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zgemv=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zgemv" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zgemv" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zgemv" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_blas_zscal is declared" >&5 $as_echo_n "checking whether gsl_blas_zscal is declared... " >&6; } if test "${ac_cv_have_decl_gsl_blas_zscal+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_blas_zscal (void) gsl_blas_zscal; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_blas_zscal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_blas_zscal=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_blas_zscal" >&5 $as_echo "$ac_cv_have_decl_gsl_blas_zscal" >&6; } if test "x$ac_cv_have_decl_gsl_blas_zscal" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_blas_zscal in -lgsl" >&5 $as_echo_n "checking for gsl_blas_zscal in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_zscal+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_zscal (); int main () { return gsl_blas_zscal (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_zscal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_zscal=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_zscal" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_zscal" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_zscal" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_arccosh is declared" >&5 $as_echo_n "checking whether gsl_complex_arccosh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_arccosh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_arccosh (void) gsl_complex_arccosh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_arccosh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_arccosh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_arccosh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_arccosh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_arccosh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_arccosh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_arccosh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_arccosh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_arccosh (); int main () { return gsl_complex_arccosh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_arccosh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_arccosh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_arccosh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_arccosh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_arccosh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_arcsinh is declared" >&5 $as_echo_n "checking whether gsl_complex_arcsinh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_arcsinh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_arcsinh (void) gsl_complex_arcsinh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_arcsinh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_arcsinh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_arcsinh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_arcsinh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_arcsinh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_arcsinh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_arcsinh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_arcsinh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_arcsinh (); int main () { return gsl_complex_arcsinh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_arcsinh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_arcsinh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_arcsinh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_arcsinh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_arcsinh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_arctanh is declared" >&5 $as_echo_n "checking whether gsl_complex_arctanh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_arctanh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_arctanh (void) gsl_complex_arctanh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_arctanh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_arctanh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_arctanh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_arctanh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_arctanh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_arctanh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_arctanh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_arctanh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_arctanh (); int main () { return gsl_complex_arctanh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_arctanh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_arctanh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_arctanh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_arctanh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_arctanh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_cosh is declared" >&5 $as_echo_n "checking whether gsl_complex_cosh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_cosh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_cosh (void) gsl_complex_cosh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_cosh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_cosh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_cosh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_cosh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_cosh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_cosh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_cosh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_cosh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_cosh (); int main () { return gsl_complex_cosh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_cosh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_cosh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_cosh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_cosh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_cosh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_inverse is declared" >&5 $as_echo_n "checking whether gsl_complex_inverse is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_inverse+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_inverse (void) gsl_complex_inverse; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_inverse=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_inverse=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_inverse" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_inverse" >&6; } if test "x$ac_cv_have_decl_gsl_complex_inverse" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_inverse in -lgsl" >&5 $as_echo_n "checking for gsl_complex_inverse in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_inverse+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_inverse (); int main () { return gsl_complex_inverse (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_inverse=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_inverse=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_inverse" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_inverse" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_inverse" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_mul is declared" >&5 $as_echo_n "checking whether gsl_complex_mul is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_mul+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_mul (void) gsl_complex_mul; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_mul=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_mul=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_mul" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_mul" >&6; } if test "x$ac_cv_have_decl_gsl_complex_mul" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_mul in -lgsl" >&5 $as_echo_n "checking for gsl_complex_mul in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_mul+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_mul (); int main () { return gsl_complex_mul (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_mul=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_mul=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_mul" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_mul" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_mul" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_sinh is declared" >&5 $as_echo_n "checking whether gsl_complex_sinh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_sinh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_sinh (void) gsl_complex_sinh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_sinh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_sinh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_sinh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_sinh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_sinh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_sinh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_sinh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_sinh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_sinh (); int main () { return gsl_complex_sinh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_sinh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_sinh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_sinh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_sinh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_sinh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_complex_tanh is declared" >&5 $as_echo_n "checking whether gsl_complex_tanh is declared... " >&6; } if test "${ac_cv_have_decl_gsl_complex_tanh+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_complex_tanh (void) gsl_complex_tanh; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_complex_tanh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_complex_tanh=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_complex_tanh" >&5 $as_echo "$ac_cv_have_decl_gsl_complex_tanh" >&6; } if test "x$ac_cv_have_decl_gsl_complex_tanh" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_complex_tanh in -lgsl" >&5 $as_echo_n "checking for gsl_complex_tanh in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_complex_tanh+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_complex_tanh (); int main () { return gsl_complex_tanh (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_complex_tanh=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_complex_tanh=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_complex_tanh" >&5 $as_echo "$ac_cv_lib_gsl_gsl_complex_tanh" >&6; } if test "x$ac_cv_lib_gsl_gsl_complex_tanh" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_backward is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_backward is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_backward+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_backward (void) gsl_fft_complex_backward; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_backward=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_backward=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_backward" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_backward" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_backward" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_backward in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_backward in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_backward+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_backward (); int main () { return gsl_fft_complex_backward (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_backward=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_backward=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_backward" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_backward" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_backward" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_forward is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_forward is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_forward+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_forward (void) gsl_fft_complex_forward; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_forward=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_forward=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_forward" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_forward" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_forward" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_forward in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_forward in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_forward+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_forward (); int main () { return gsl_fft_complex_forward (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_forward=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_forward=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_forward" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_forward" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_forward" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_inverse is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_inverse is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_inverse+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_inverse (void) gsl_fft_complex_inverse; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_inverse=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_inverse=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_inverse" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_inverse" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_inverse" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_inverse in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_inverse in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_inverse+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_inverse (); int main () { return gsl_fft_complex_inverse (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_inverse=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_inverse=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_inverse" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_inverse" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_inverse" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_wavetable_alloc is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_wavetable_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_wavetable_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_wavetable_alloc (void) gsl_fft_complex_wavetable_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_wavetable_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_wavetable_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_wavetable_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_wavetable_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_wavetable_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_wavetable_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_wavetable_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_wavetable_alloc (); int main () { return gsl_fft_complex_wavetable_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_wavetable_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_wavetable_free is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_wavetable_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_wavetable_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_wavetable_free (void) gsl_fft_complex_wavetable_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_wavetable_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_wavetable_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_wavetable_free" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_wavetable_free" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_wavetable_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_wavetable_free in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_wavetable_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_wavetable_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_wavetable_free (); int main () { return gsl_fft_complex_wavetable_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_wavetable_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_wavetable_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_wavetable_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_wavetable_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_wavetable_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_workspace_alloc is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_workspace_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_workspace_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_workspace_alloc (void) gsl_fft_complex_workspace_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_workspace_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_workspace_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_workspace_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_workspace_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_workspace_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_workspace_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_workspace_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_workspace_alloc (); int main () { return gsl_fft_complex_workspace_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_workspace_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_fft_complex_workspace_free is declared" >&5 $as_echo_n "checking whether gsl_fft_complex_workspace_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_fft_complex_workspace_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_fft_complex_workspace_free (void) gsl_fft_complex_workspace_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_fft_complex_workspace_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_fft_complex_workspace_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_fft_complex_workspace_free" >&5 $as_echo "$ac_cv_have_decl_gsl_fft_complex_workspace_free" >&6; } if test "x$ac_cv_have_decl_gsl_fft_complex_workspace_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_fft_complex_workspace_free in -lgsl" >&5 $as_echo_n "checking for gsl_fft_complex_workspace_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_fft_complex_workspace_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_fft_complex_workspace_free (); int main () { return gsl_fft_complex_workspace_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_fft_complex_workspace_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_fft_complex_workspace_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_fft_complex_workspace_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_fft_complex_workspace_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_fft_complex_workspace_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_integration_qagiu is declared" >&5 $as_echo_n "checking whether gsl_integration_qagiu is declared... " >&6; } if test "${ac_cv_have_decl_gsl_integration_qagiu+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_integration_qagiu (void) gsl_integration_qagiu; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_integration_qagiu=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_integration_qagiu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_integration_qagiu" >&5 $as_echo "$ac_cv_have_decl_gsl_integration_qagiu" >&6; } if test "x$ac_cv_have_decl_gsl_integration_qagiu" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_integration_qagiu in -lgsl" >&5 $as_echo_n "checking for gsl_integration_qagiu in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_integration_qagiu+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_integration_qagiu (); int main () { return gsl_integration_qagiu (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_integration_qagiu=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_integration_qagiu=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_integration_qagiu" >&5 $as_echo "$ac_cv_lib_gsl_gsl_integration_qagiu" >&6; } if test "x$ac_cv_lib_gsl_gsl_integration_qagiu" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_integration_workspace_alloc is declared" >&5 $as_echo_n "checking whether gsl_integration_workspace_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_integration_workspace_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_integration_workspace_alloc (void) gsl_integration_workspace_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_integration_workspace_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_integration_workspace_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_integration_workspace_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_integration_workspace_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_integration_workspace_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_integration_workspace_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_integration_workspace_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_integration_workspace_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_integration_workspace_alloc (); int main () { return gsl_integration_workspace_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_integration_workspace_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_integration_workspace_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_integration_workspace_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_integration_workspace_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_integration_workspace_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_integration_workspace_free is declared" >&5 $as_echo_n "checking whether gsl_integration_workspace_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_integration_workspace_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_integration_workspace_free (void) gsl_integration_workspace_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_integration_workspace_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_integration_workspace_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_integration_workspace_free" >&5 $as_echo "$ac_cv_have_decl_gsl_integration_workspace_free" >&6; } if test "x$ac_cv_have_decl_gsl_integration_workspace_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_integration_workspace_free in -lgsl" >&5 $as_echo_n "checking for gsl_integration_workspace_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_integration_workspace_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_integration_workspace_free (); int main () { return gsl_integration_workspace_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_integration_workspace_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_integration_workspace_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_integration_workspace_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_integration_workspace_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_integration_workspace_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_LU_decomp is declared" >&5 $as_echo_n "checking whether gsl_linalg_LU_decomp is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_LU_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_LU_decomp (void) gsl_linalg_LU_decomp; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_LU_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_LU_decomp=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_LU_decomp" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_LU_decomp" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_LU_decomp" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_LU_decomp in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_LU_decomp in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_LU_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_LU_decomp (); int main () { return gsl_linalg_LU_decomp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_LU_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_LU_decomp=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_LU_decomp" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_LU_decomp" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_LU_decomp" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_LU_det is declared" >&5 $as_echo_n "checking whether gsl_linalg_LU_det is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_LU_det+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_LU_det (void) gsl_linalg_LU_det; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_LU_det=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_LU_det=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_LU_det" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_LU_det" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_LU_det" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_LU_det in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_LU_det in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_LU_det+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_LU_det (); int main () { return gsl_linalg_LU_det (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_LU_det=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_LU_det=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_LU_det" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_LU_det" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_LU_det" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_LU_invert is declared" >&5 $as_echo_n "checking whether gsl_linalg_LU_invert is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_LU_invert+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_LU_invert (void) gsl_linalg_LU_invert; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_LU_invert=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_LU_invert=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_LU_invert" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_LU_invert" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_LU_invert" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_LU_invert in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_LU_invert in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_LU_invert+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_LU_invert (); int main () { return gsl_linalg_LU_invert (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_LU_invert=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_LU_invert=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_LU_invert" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_LU_invert" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_LU_invert" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_LU_refine is declared" >&5 $as_echo_n "checking whether gsl_linalg_LU_refine is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_LU_refine+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_LU_refine (void) gsl_linalg_LU_refine; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_LU_refine=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_LU_refine=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_LU_refine" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_LU_refine" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_LU_refine" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_LU_refine in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_LU_refine in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_LU_refine+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_LU_refine (); int main () { return gsl_linalg_LU_refine (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_LU_refine=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_LU_refine=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_LU_refine" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_LU_refine" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_LU_refine" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_LU_solve is declared" >&5 $as_echo_n "checking whether gsl_linalg_LU_solve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_LU_solve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_LU_solve (void) gsl_linalg_LU_solve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_LU_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_LU_solve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_LU_solve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_LU_solve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_LU_solve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_LU_solve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_LU_solve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_LU_solve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_LU_solve (); int main () { return gsl_linalg_LU_solve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_LU_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_LU_solve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_LU_solve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_LU_solve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_LU_solve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_QR_decomp is declared" >&5 $as_echo_n "checking whether gsl_linalg_QR_decomp is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_QR_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_QR_decomp (void) gsl_linalg_QR_decomp; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_QR_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_QR_decomp=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_QR_decomp" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_QR_decomp" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_QR_decomp" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_QR_decomp in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_QR_decomp in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_QR_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_QR_decomp (); int main () { return gsl_linalg_QR_decomp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_QR_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_QR_decomp=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_QR_decomp" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_QR_decomp" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_QR_decomp" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_QR_lssolve is declared" >&5 $as_echo_n "checking whether gsl_linalg_QR_lssolve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_QR_lssolve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_QR_lssolve (void) gsl_linalg_QR_lssolve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_QR_lssolve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_QR_lssolve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_QR_lssolve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_QR_lssolve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_QR_lssolve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_QR_lssolve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_QR_lssolve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_QR_lssolve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_QR_lssolve (); int main () { return gsl_linalg_QR_lssolve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_QR_lssolve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_QR_lssolve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_QR_lssolve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_QR_lssolve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_QR_lssolve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_QR_solve is declared" >&5 $as_echo_n "checking whether gsl_linalg_QR_solve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_QR_solve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_QR_solve (void) gsl_linalg_QR_solve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_QR_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_QR_solve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_QR_solve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_QR_solve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_QR_solve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_QR_solve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_QR_solve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_QR_solve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_QR_solve (); int main () { return gsl_linalg_QR_solve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_QR_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_QR_solve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_QR_solve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_QR_solve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_QR_solve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_SV_decomp is declared" >&5 $as_echo_n "checking whether gsl_linalg_SV_decomp is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_SV_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_SV_decomp (void) gsl_linalg_SV_decomp; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_SV_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_SV_decomp=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_SV_decomp" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_SV_decomp" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_SV_decomp" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_SV_decomp in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_SV_decomp in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_SV_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_SV_decomp (); int main () { return gsl_linalg_SV_decomp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_SV_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_SV_decomp=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_SV_decomp" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_SV_decomp" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_SV_decomp" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_SV_solve is declared" >&5 $as_echo_n "checking whether gsl_linalg_SV_solve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_SV_solve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_SV_solve (void) gsl_linalg_SV_solve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_SV_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_SV_solve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_SV_solve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_SV_solve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_SV_solve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_SV_solve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_SV_solve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_SV_solve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_SV_solve (); int main () { return gsl_linalg_SV_solve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_SV_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_SV_solve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_SV_solve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_SV_solve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_SV_solve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_cholesky_decomp is declared" >&5 $as_echo_n "checking whether gsl_linalg_cholesky_decomp is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_cholesky_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_cholesky_decomp (void) gsl_linalg_cholesky_decomp; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_cholesky_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_cholesky_decomp=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_cholesky_decomp" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_cholesky_decomp" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_cholesky_decomp" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_cholesky_decomp in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_cholesky_decomp in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_cholesky_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_cholesky_decomp (); int main () { return gsl_linalg_cholesky_decomp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_cholesky_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_cholesky_decomp=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_cholesky_decomp" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_cholesky_decomp" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_cholesky_decomp" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_cholesky_solve is declared" >&5 $as_echo_n "checking whether gsl_linalg_cholesky_solve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_cholesky_solve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_cholesky_solve (void) gsl_linalg_cholesky_solve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_cholesky_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_cholesky_solve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_cholesky_solve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_cholesky_solve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_cholesky_solve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_cholesky_solve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_cholesky_solve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_cholesky_solve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_cholesky_solve (); int main () { return gsl_linalg_cholesky_solve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_cholesky_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_cholesky_solve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_cholesky_solve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_cholesky_solve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_cholesky_solve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_complex_LU_decomp is declared" >&5 $as_echo_n "checking whether gsl_linalg_complex_LU_decomp is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_complex_LU_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_complex_LU_decomp (void) gsl_linalg_complex_LU_decomp; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_complex_LU_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_complex_LU_decomp=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_complex_LU_decomp" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_complex_LU_decomp" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_complex_LU_decomp" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_complex_LU_decomp in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_complex_LU_decomp in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_complex_LU_decomp (); int main () { return gsl_linalg_complex_LU_decomp (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_complex_LU_decomp" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_complex_LU_det is declared" >&5 $as_echo_n "checking whether gsl_linalg_complex_LU_det is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_complex_LU_det+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_complex_LU_det (void) gsl_linalg_complex_LU_det; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_complex_LU_det=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_complex_LU_det=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_complex_LU_det" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_complex_LU_det" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_complex_LU_det" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_complex_LU_det in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_complex_LU_det in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_complex_LU_det+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_complex_LU_det (); int main () { return gsl_linalg_complex_LU_det (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_complex_LU_det=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_complex_LU_det=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_complex_LU_det" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_complex_LU_det" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_complex_LU_det" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_complex_LU_invert is declared" >&5 $as_echo_n "checking whether gsl_linalg_complex_LU_invert is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_complex_LU_invert+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_complex_LU_invert (void) gsl_linalg_complex_LU_invert; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_complex_LU_invert=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_complex_LU_invert=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_complex_LU_invert" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_complex_LU_invert" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_complex_LU_invert" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_complex_LU_invert in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_complex_LU_invert in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_complex_LU_invert+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_complex_LU_invert (); int main () { return gsl_linalg_complex_LU_invert (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_complex_LU_invert=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_complex_LU_invert=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_complex_LU_invert" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_complex_LU_invert" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_complex_LU_invert" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_complex_LU_refine is declared" >&5 $as_echo_n "checking whether gsl_linalg_complex_LU_refine is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_complex_LU_refine+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_complex_LU_refine (void) gsl_linalg_complex_LU_refine; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_complex_LU_refine=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_complex_LU_refine=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_complex_LU_refine" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_complex_LU_refine" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_complex_LU_refine" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_complex_LU_refine in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_complex_LU_refine in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_complex_LU_refine+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_complex_LU_refine (); int main () { return gsl_linalg_complex_LU_refine (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_complex_LU_refine=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_complex_LU_refine=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_complex_LU_refine" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_complex_LU_refine" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_complex_LU_refine" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_linalg_complex_LU_solve is declared" >&5 $as_echo_n "checking whether gsl_linalg_complex_LU_solve is declared... " >&6; } if test "${ac_cv_have_decl_gsl_linalg_complex_LU_solve+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_linalg_complex_LU_solve (void) gsl_linalg_complex_LU_solve; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_linalg_complex_LU_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_linalg_complex_LU_solve=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_linalg_complex_LU_solve" >&5 $as_echo "$ac_cv_have_decl_gsl_linalg_complex_LU_solve" >&6; } if test "x$ac_cv_have_decl_gsl_linalg_complex_LU_solve" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_linalg_complex_LU_solve in -lgsl" >&5 $as_echo_n "checking for gsl_linalg_complex_LU_solve in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_linalg_complex_LU_solve+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_linalg_complex_LU_solve (); int main () { return gsl_linalg_complex_LU_solve (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_linalg_complex_LU_solve=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_linalg_complex_LU_solve=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_linalg_complex_LU_solve" >&5 $as_echo "$ac_cv_lib_gsl_gsl_linalg_complex_LU_solve" >&6; } if test "x$ac_cv_lib_gsl_gsl_linalg_complex_LU_solve" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_add is declared" >&5 $as_echo_n "checking whether gsl_matrix_add is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_add+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_add (void) gsl_matrix_add; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_add=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_add" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_add" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_add" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_add in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_add in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_add+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_add (); int main () { return gsl_matrix_add (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_add=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_add" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_add" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_add" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_alloc is declared" >&5 $as_echo_n "checking whether gsl_matrix_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_alloc (void) gsl_matrix_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_alloc (); int main () { return gsl_matrix_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_add is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_add is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_add+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_add (void) gsl_matrix_complex_add; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_add=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_add" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_add" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_add" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_add in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_add in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_add+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_add (); int main () { return gsl_matrix_complex_add (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_add=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_add" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_add" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_add" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_alloc is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_alloc (void) gsl_matrix_complex_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_alloc (); int main () { return gsl_matrix_complex_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_free is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_free (void) gsl_matrix_complex_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_free" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_free" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_free in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_free (); int main () { return gsl_matrix_complex_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_get is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_get is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_get+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_get (void) gsl_matrix_complex_get; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_get=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_get" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_get" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_get" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_get in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_get in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_get+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_get (); int main () { return gsl_matrix_complex_get (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_get=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_get" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_get" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_get" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_isnull is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_isnull is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_isnull (void) gsl_matrix_complex_isnull; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_isnull=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_isnull" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_isnull" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_isnull" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_isnull in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_isnull in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_isnull (); int main () { return gsl_matrix_complex_isnull (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_isnull=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_isnull" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_isnull" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_isnull" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_scale is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_scale is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_scale+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_scale (void) gsl_matrix_complex_scale; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_scale=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_scale" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_scale" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_scale" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_scale in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_scale in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_scale+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_scale (); int main () { return gsl_matrix_complex_scale (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_scale=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_scale" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_scale" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_scale" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_set is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_set is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_set+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_set (void) gsl_matrix_complex_set; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_set=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_set" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_set" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_set" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_set in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_set in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_set+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_set (); int main () { return gsl_matrix_complex_set (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_set=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_set" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_set" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_set" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_set_zero is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_set_zero is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_set_zero (void) gsl_matrix_complex_set_zero; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_set_zero=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_set_zero" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_set_zero" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_set_zero" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_set_zero in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_set_zero in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_set_zero (); int main () { return gsl_matrix_complex_set_zero (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_set_zero=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_set_zero" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_set_zero" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_set_zero" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_sub is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_sub is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_sub+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_sub (void) gsl_matrix_complex_sub; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_sub=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_sub" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_sub" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_sub" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_sub in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_sub in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_sub+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_sub (); int main () { return gsl_matrix_complex_sub (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_sub=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_sub" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_sub" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_sub" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_complex_transpose is declared" >&5 $as_echo_n "checking whether gsl_matrix_complex_transpose is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_complex_transpose+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_complex_transpose (void) gsl_matrix_complex_transpose; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_complex_transpose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_complex_transpose=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_complex_transpose" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_complex_transpose" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_complex_transpose" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_complex_transpose in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_complex_transpose in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_complex_transpose+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_complex_transpose (); int main () { return gsl_matrix_complex_transpose (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_complex_transpose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_complex_transpose=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_complex_transpose" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_complex_transpose" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_complex_transpose" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_free is declared" >&5 $as_echo_n "checking whether gsl_matrix_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_free (void) gsl_matrix_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_free" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_free" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_free in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_free (); int main () { return gsl_matrix_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_get is declared" >&5 $as_echo_n "checking whether gsl_matrix_get is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_get+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_get (void) gsl_matrix_get; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_get=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_get" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_get" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_get" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_get in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_get in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_get+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_get (); int main () { return gsl_matrix_get (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_get=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_get" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_get" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_get" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_isnull is declared" >&5 $as_echo_n "checking whether gsl_matrix_isnull is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_isnull (void) gsl_matrix_isnull; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_isnull=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_isnull" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_isnull" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_isnull" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_isnull in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_isnull in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_isnull (); int main () { return gsl_matrix_isnull (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_isnull=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_isnull" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_isnull" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_isnull" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_scale is declared" >&5 $as_echo_n "checking whether gsl_matrix_scale is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_scale+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_scale (void) gsl_matrix_scale; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_scale=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_scale" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_scale" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_scale" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_scale in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_scale in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_scale+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_scale (); int main () { return gsl_matrix_scale (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_scale=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_scale" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_scale" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_scale" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_set is declared" >&5 $as_echo_n "checking whether gsl_matrix_set is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_set+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_set (void) gsl_matrix_set; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_set=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_set" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_set" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_set" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_set in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_set in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_set+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_set (); int main () { return gsl_matrix_set (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_set=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_set" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_set" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_set" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_set_zero is declared" >&5 $as_echo_n "checking whether gsl_matrix_set_zero is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_set_zero (void) gsl_matrix_set_zero; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_set_zero=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_set_zero" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_set_zero" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_set_zero" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_set_zero in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_set_zero in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_set_zero (); int main () { return gsl_matrix_set_zero (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_set_zero=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_set_zero" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_set_zero" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_set_zero" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_sub is declared" >&5 $as_echo_n "checking whether gsl_matrix_sub is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_sub+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_sub (void) gsl_matrix_sub; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_sub=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_sub" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_sub" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_sub" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_sub in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_sub in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_sub+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_sub (); int main () { return gsl_matrix_sub (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_sub=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_sub" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_sub" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_sub" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_matrix_transpose is declared" >&5 $as_echo_n "checking whether gsl_matrix_transpose is declared... " >&6; } if test "${ac_cv_have_decl_gsl_matrix_transpose+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_matrix_transpose (void) gsl_matrix_transpose; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_matrix_transpose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_matrix_transpose=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_matrix_transpose" >&5 $as_echo "$ac_cv_have_decl_gsl_matrix_transpose" >&6; } if test "x$ac_cv_have_decl_gsl_matrix_transpose" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_matrix_transpose in -lgsl" >&5 $as_echo_n "checking for gsl_matrix_transpose in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_matrix_transpose+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_matrix_transpose (); int main () { return gsl_matrix_transpose (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_matrix_transpose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_matrix_transpose=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_matrix_transpose" >&5 $as_echo "$ac_cv_lib_gsl_gsl_matrix_transpose" >&6; } if test "x$ac_cv_lib_gsl_gsl_matrix_transpose" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_permutation_alloc is declared" >&5 $as_echo_n "checking whether gsl_permutation_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_permutation_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_permutation_alloc (void) gsl_permutation_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_permutation_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_permutation_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_permutation_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_permutation_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_permutation_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_permutation_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_permutation_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_permutation_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_permutation_alloc (); int main () { return gsl_permutation_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_permutation_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_permutation_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_permutation_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_permutation_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_permutation_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_permutation_free is declared" >&5 $as_echo_n "checking whether gsl_permutation_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_permutation_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_permutation_free (void) gsl_permutation_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_permutation_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_permutation_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_permutation_free" >&5 $as_echo "$ac_cv_have_decl_gsl_permutation_free" >&6; } if test "x$ac_cv_have_decl_gsl_permutation_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_permutation_free in -lgsl" >&5 $as_echo_n "checking for gsl_permutation_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_permutation_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_permutation_free (); int main () { return gsl_permutation_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_permutation_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_permutation_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_permutation_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_permutation_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_permutation_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_permutation_get is declared" >&5 $as_echo_n "checking whether gsl_permutation_get is declared... " >&6; } if test "${ac_cv_have_decl_gsl_permutation_get+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_permutation_get (void) gsl_permutation_get; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_permutation_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_permutation_get=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_permutation_get" >&5 $as_echo "$ac_cv_have_decl_gsl_permutation_get" >&6; } if test "x$ac_cv_have_decl_gsl_permutation_get" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_permutation_get in -lgsl" >&5 $as_echo_n "checking for gsl_permutation_get in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_permutation_get+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_permutation_get (); int main () { return gsl_permutation_get (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_permutation_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_permutation_get=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_permutation_get" >&5 $as_echo "$ac_cv_lib_gsl_gsl_permutation_get" >&6; } if test "x$ac_cv_lib_gsl_gsl_permutation_get" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_set_error_handler is declared" >&5 $as_echo_n "checking whether gsl_set_error_handler is declared... " >&6; } if test "${ac_cv_have_decl_gsl_set_error_handler+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_set_error_handler (void) gsl_set_error_handler; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_set_error_handler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_set_error_handler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_set_error_handler" >&5 $as_echo "$ac_cv_have_decl_gsl_set_error_handler" >&6; } if test "x$ac_cv_have_decl_gsl_set_error_handler" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_set_error_handler in -lgsl" >&5 $as_echo_n "checking for gsl_set_error_handler in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_set_error_handler+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_set_error_handler (); int main () { return gsl_set_error_handler (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_set_error_handler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_set_error_handler=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_set_error_handler" >&5 $as_echo "$ac_cv_lib_gsl_gsl_set_error_handler" >&6; } if test "x$ac_cv_lib_gsl_gsl_set_error_handler" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_set_error_handler_off is declared" >&5 $as_echo_n "checking whether gsl_set_error_handler_off is declared... " >&6; } if test "${ac_cv_have_decl_gsl_set_error_handler_off+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_set_error_handler_off (void) gsl_set_error_handler_off; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_set_error_handler_off=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_set_error_handler_off=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_set_error_handler_off" >&5 $as_echo "$ac_cv_have_decl_gsl_set_error_handler_off" >&6; } if test "x$ac_cv_have_decl_gsl_set_error_handler_off" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_set_error_handler_off in -lgsl" >&5 $as_echo_n "checking for gsl_set_error_handler_off in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_set_error_handler_off+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_set_error_handler_off (); int main () { return gsl_set_error_handler_off (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_set_error_handler_off=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_set_error_handler_off=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_set_error_handler_off" >&5 $as_echo "$ac_cv_lib_gsl_gsl_set_error_handler_off" >&6; } if test "x$ac_cv_lib_gsl_gsl_set_error_handler_off" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_airy_Ai_deriv_e is declared" >&5 $as_echo_n "checking whether gsl_sf_airy_Ai_deriv_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_airy_Ai_deriv_e (void) gsl_sf_airy_Ai_deriv_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_airy_Ai_deriv_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_airy_Ai_deriv_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_airy_Ai_deriv_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_airy_Ai_deriv_e (); int main () { return gsl_sf_airy_Ai_deriv_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_airy_Ai_deriv_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_airy_Ai_e is declared" >&5 $as_echo_n "checking whether gsl_sf_airy_Ai_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_airy_Ai_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_airy_Ai_e (void) gsl_sf_airy_Ai_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_airy_Ai_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_airy_Ai_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_airy_Ai_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_airy_Ai_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_airy_Ai_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_airy_Ai_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_airy_Ai_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_airy_Ai_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_airy_Ai_e (); int main () { return gsl_sf_airy_Ai_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_airy_Ai_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_airy_Ai_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_airy_Ai_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_airy_Ai_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_airy_Ai_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_airy_Bi_deriv_e is declared" >&5 $as_echo_n "checking whether gsl_sf_airy_Bi_deriv_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_airy_Bi_deriv_e (void) gsl_sf_airy_Bi_deriv_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_airy_Bi_deriv_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_airy_Bi_deriv_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_airy_Bi_deriv_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_airy_Bi_deriv_e (); int main () { return gsl_sf_airy_Bi_deriv_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_airy_Bi_deriv_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_airy_Bi_e is declared" >&5 $as_echo_n "checking whether gsl_sf_airy_Bi_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_airy_Bi_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_airy_Bi_e (void) gsl_sf_airy_Bi_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_airy_Bi_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_airy_Bi_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_airy_Bi_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_airy_Bi_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_airy_Bi_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_airy_Bi_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_airy_Bi_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_airy_Bi_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_airy_Bi_e (); int main () { return gsl_sf_airy_Bi_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_airy_Bi_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_airy_Bi_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_airy_Bi_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_airy_Bi_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_airy_Bi_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_In_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_In_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_In_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_In_e (void) gsl_sf_bessel_In_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_In_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_In_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_In_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_In_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_In_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_In_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_In_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_In_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_In_e (); int main () { return gsl_sf_bessel_In_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_In_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_In_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_In_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_In_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_In_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_In_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_In_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_In_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_In_scaled_e (void) gsl_sf_bessel_In_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_In_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_In_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_In_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_In_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_In_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_In_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_In_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_In_scaled_e (); int main () { return gsl_sf_bessel_In_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_In_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Inu_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Inu_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Inu_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Inu_e (void) gsl_sf_bessel_Inu_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Inu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Inu_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Inu_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Inu_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Inu_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Inu_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Inu_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Inu_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Inu_e (); int main () { return gsl_sf_bessel_Inu_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Inu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Inu_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Inu_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Inu_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Inu_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Inu_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Inu_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Inu_scaled_e (void) gsl_sf_bessel_Inu_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Inu_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Inu_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Inu_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Inu_scaled_e (); int main () { return gsl_sf_bessel_Inu_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Inu_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Jn_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Jn_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Jn_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Jn_e (void) gsl_sf_bessel_Jn_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Jn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Jn_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Jn_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Jn_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Jn_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Jn_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Jn_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Jn_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Jn_e (); int main () { return gsl_sf_bessel_Jn_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Jn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Jn_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Jn_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Jn_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Jn_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Jnu_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Jnu_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Jnu_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Jnu_e (void) gsl_sf_bessel_Jnu_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Jnu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Jnu_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Jnu_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Jnu_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Jnu_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Jnu_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Jnu_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Jnu_e (); int main () { return gsl_sf_bessel_Jnu_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Jnu_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Kn_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Kn_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Kn_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Kn_e (void) gsl_sf_bessel_Kn_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Kn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Kn_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Kn_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Kn_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Kn_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Kn_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Kn_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Kn_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Kn_e (); int main () { return gsl_sf_bessel_Kn_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Kn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Kn_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Kn_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Kn_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Kn_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Kn_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Kn_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Kn_scaled_e (void) gsl_sf_bessel_Kn_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Kn_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Kn_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Kn_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Kn_scaled_e (); int main () { return gsl_sf_bessel_Kn_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Kn_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Knu_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Knu_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Knu_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Knu_e (void) gsl_sf_bessel_Knu_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Knu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Knu_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Knu_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Knu_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Knu_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Knu_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Knu_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Knu_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Knu_e (); int main () { return gsl_sf_bessel_Knu_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Knu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Knu_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Knu_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Knu_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Knu_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Knu_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Knu_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Knu_scaled_e (void) gsl_sf_bessel_Knu_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Knu_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Knu_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Knu_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Knu_scaled_e (); int main () { return gsl_sf_bessel_Knu_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Knu_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Yn_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Yn_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Yn_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Yn_e (void) gsl_sf_bessel_Yn_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Yn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Yn_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Yn_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Yn_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Yn_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Yn_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Yn_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Yn_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Yn_e (); int main () { return gsl_sf_bessel_Yn_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Yn_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Yn_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Yn_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Yn_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Yn_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_Ynu_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_Ynu_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_Ynu_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_Ynu_e (void) gsl_sf_bessel_Ynu_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_Ynu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_Ynu_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_Ynu_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_Ynu_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_Ynu_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_Ynu_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_Ynu_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_Ynu_e (); int main () { return gsl_sf_bessel_Ynu_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_Ynu_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_il_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_il_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_il_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_il_scaled_e (void) gsl_sf_bessel_il_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_il_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_il_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_il_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_il_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_il_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_il_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_il_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_il_scaled_e (); int main () { return gsl_sf_bessel_il_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_il_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_jl_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_jl_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_jl_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_jl_e (void) gsl_sf_bessel_jl_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_jl_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_jl_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_jl_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_jl_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_jl_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_jl_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_jl_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_jl_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_jl_e (); int main () { return gsl_sf_bessel_jl_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_jl_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_jl_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_jl_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_jl_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_jl_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_kl_scaled_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_kl_scaled_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_kl_scaled_e (void) gsl_sf_bessel_kl_scaled_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_kl_scaled_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_kl_scaled_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_kl_scaled_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_kl_scaled_e (); int main () { return gsl_sf_bessel_kl_scaled_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_kl_scaled_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_bessel_yl_e is declared" >&5 $as_echo_n "checking whether gsl_sf_bessel_yl_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_bessel_yl_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_bessel_yl_e (void) gsl_sf_bessel_yl_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_bessel_yl_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_bessel_yl_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_bessel_yl_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_bessel_yl_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_bessel_yl_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_bessel_yl_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_bessel_yl_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_bessel_yl_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_bessel_yl_e (); int main () { return gsl_sf_bessel_yl_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_bessel_yl_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_bessel_yl_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_bessel_yl_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_bessel_yl_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_bessel_yl_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_beta_e is declared" >&5 $as_echo_n "checking whether gsl_sf_beta_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_beta_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_beta_e (void) gsl_sf_beta_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_beta_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_beta_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_beta_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_beta_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_beta_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_beta_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_beta_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_beta_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_beta_e (); int main () { return gsl_sf_beta_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_beta_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_beta_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_beta_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_beta_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_beta_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_beta_inc_e is declared" >&5 $as_echo_n "checking whether gsl_sf_beta_inc_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_beta_inc_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_beta_inc_e (void) gsl_sf_beta_inc_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_beta_inc_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_beta_inc_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_beta_inc_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_beta_inc_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_beta_inc_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_beta_inc_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_beta_inc_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_beta_inc_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_beta_inc_e (); int main () { return gsl_sf_beta_inc_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_beta_inc_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_beta_inc_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_beta_inc_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_beta_inc_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_beta_inc_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_Ecomp_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_Ecomp_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_Ecomp_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_Ecomp_e (void) gsl_sf_ellint_Ecomp_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_Ecomp_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_Ecomp_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_Ecomp_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_Ecomp_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_Ecomp_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_Ecomp_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_Ecomp_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_Ecomp_e (); int main () { return gsl_sf_ellint_Ecomp_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_Ecomp_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_Kcomp_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_Kcomp_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_Kcomp_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_Kcomp_e (void) gsl_sf_ellint_Kcomp_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_Kcomp_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_Kcomp_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_Kcomp_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_Kcomp_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_Kcomp_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_Kcomp_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_Kcomp_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_Kcomp_e (); int main () { return gsl_sf_ellint_Kcomp_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_Kcomp_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_RC_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_RC_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_RC_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_RC_e (void) gsl_sf_ellint_RC_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_RC_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_RC_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_RC_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_RC_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_RC_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_RC_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_RC_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_RC_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_RC_e (); int main () { return gsl_sf_ellint_RC_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_RC_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_RC_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_RC_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_RC_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_RC_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_RD_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_RD_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_RD_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_RD_e (void) gsl_sf_ellint_RD_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_RD_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_RD_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_RD_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_RD_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_RD_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_RD_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_RD_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_RD_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_RD_e (); int main () { return gsl_sf_ellint_RD_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_RD_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_RD_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_RD_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_RD_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_RD_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_RF_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_RF_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_RF_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_RF_e (void) gsl_sf_ellint_RF_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_RF_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_RF_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_RF_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_RF_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_RF_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_RF_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_RF_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_RF_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_RF_e (); int main () { return gsl_sf_ellint_RF_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_RF_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_RF_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_RF_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_RF_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_RF_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_ellint_RJ_e is declared" >&5 $as_echo_n "checking whether gsl_sf_ellint_RJ_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_ellint_RJ_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_ellint_RJ_e (void) gsl_sf_ellint_RJ_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_ellint_RJ_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_ellint_RJ_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_ellint_RJ_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_ellint_RJ_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_ellint_RJ_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_ellint_RJ_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_ellint_RJ_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_ellint_RJ_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_ellint_RJ_e (); int main () { return gsl_sf_ellint_RJ_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_ellint_RJ_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_ellint_RJ_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_ellint_RJ_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_ellint_RJ_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_ellint_RJ_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_erf_e is declared" >&5 $as_echo_n "checking whether gsl_sf_erf_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_erf_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_erf_e (void) gsl_sf_erf_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_erf_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_erf_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_erf_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_erf_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_erf_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_erf_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_erf_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_erf_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_erf_e (); int main () { return gsl_sf_erf_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_erf_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_erf_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_erf_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_erf_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_erf_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_erfc_e is declared" >&5 $as_echo_n "checking whether gsl_sf_erfc_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_erfc_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_erfc_e (void) gsl_sf_erfc_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_erfc_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_erfc_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_erfc_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_erfc_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_erfc_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_erfc_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_erfc_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_erfc_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_erfc_e (); int main () { return gsl_sf_erfc_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_erfc_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_erfc_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_erfc_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_erfc_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_erfc_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_fact is declared" >&5 $as_echo_n "checking whether gsl_sf_fact is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_fact+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_fact (void) gsl_sf_fact; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_fact=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_fact=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_fact" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_fact" >&6; } if test "x$ac_cv_have_decl_gsl_sf_fact" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_fact in -lgsl" >&5 $as_echo_n "checking for gsl_sf_fact in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_fact+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_fact (); int main () { return gsl_sf_fact (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_fact=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_fact=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_fact" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_fact" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_fact" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_gamma_e is declared" >&5 $as_echo_n "checking whether gsl_sf_gamma_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_gamma_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_gamma_e (void) gsl_sf_gamma_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_gamma_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_gamma_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_gamma_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_gamma_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_gamma_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_gamma_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_gamma_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_gamma_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_gamma_e (); int main () { return gsl_sf_gamma_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_gamma_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_gamma_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_gamma_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_gamma_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_gamma_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_gamma_inc_P_e is declared" >&5 $as_echo_n "checking whether gsl_sf_gamma_inc_P_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_gamma_inc_P_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_gamma_inc_P_e (void) gsl_sf_gamma_inc_P_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_gamma_inc_P_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_gamma_inc_P_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_gamma_inc_P_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_gamma_inc_P_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_gamma_inc_P_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_gamma_inc_P_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_gamma_inc_P_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_gamma_inc_P_e (); int main () { return gsl_sf_gamma_inc_P_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_gamma_inc_P_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_sf_lngamma_e is declared" >&5 $as_echo_n "checking whether gsl_sf_lngamma_e is declared... " >&6; } if test "${ac_cv_have_decl_gsl_sf_lngamma_e+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_sf_lngamma_e (void) gsl_sf_lngamma_e; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_sf_lngamma_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_sf_lngamma_e=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_sf_lngamma_e" >&5 $as_echo "$ac_cv_have_decl_gsl_sf_lngamma_e" >&6; } if test "x$ac_cv_have_decl_gsl_sf_lngamma_e" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_sf_lngamma_e in -lgsl" >&5 $as_echo_n "checking for gsl_sf_lngamma_e in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_sf_lngamma_e+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_sf_lngamma_e (); int main () { return gsl_sf_lngamma_e (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_sf_lngamma_e=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_sf_lngamma_e=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_sf_lngamma_e" >&5 $as_echo "$ac_cv_lib_gsl_gsl_sf_lngamma_e" >&6; } if test "x$ac_cv_lib_gsl_gsl_sf_lngamma_e" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_strerror is declared" >&5 $as_echo_n "checking whether gsl_strerror is declared... " >&6; } if test "${ac_cv_have_decl_gsl_strerror+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_strerror (void) gsl_strerror; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_strerror=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_strerror=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_strerror" >&5 $as_echo "$ac_cv_have_decl_gsl_strerror" >&6; } if test "x$ac_cv_have_decl_gsl_strerror" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_strerror in -lgsl" >&5 $as_echo_n "checking for gsl_strerror in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_strerror+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_strerror (); int main () { return gsl_strerror (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_strerror=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_strerror=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_strerror" >&5 $as_echo "$ac_cv_lib_gsl_gsl_strerror" >&6; } if test "x$ac_cv_lib_gsl_gsl_strerror" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_add is declared" >&5 $as_echo_n "checking whether gsl_vector_add is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_add+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_add (void) gsl_vector_add; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_add=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_add" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_add" >&6; } if test "x$ac_cv_have_decl_gsl_vector_add" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_add in -lgsl" >&5 $as_echo_n "checking for gsl_vector_add in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_add+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_add (); int main () { return gsl_vector_add (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_add=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_add=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_add" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_add" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_add" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_alloc is declared" >&5 $as_echo_n "checking whether gsl_vector_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_alloc (void) gsl_vector_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_vector_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_vector_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_alloc (); int main () { return gsl_vector_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_alloc is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_alloc is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_alloc (void) gsl_vector_complex_alloc; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_alloc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_alloc" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_alloc" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_alloc" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_alloc in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_alloc in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_alloc+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_alloc (); int main () { return gsl_vector_complex_alloc (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_alloc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_alloc=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_alloc" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_alloc" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_alloc" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_free is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_free (void) gsl_vector_complex_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_free" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_free" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_free in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_free (); int main () { return gsl_vector_complex_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_get is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_get is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_get+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_get (void) gsl_vector_complex_get; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_get=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_get" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_get" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_get" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_get in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_get in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_get+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_get (); int main () { return gsl_vector_complex_get (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_get=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_get" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_get" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_get" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_isnull is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_isnull is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_isnull (void) gsl_vector_complex_isnull; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_isnull=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_isnull" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_isnull" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_isnull" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_isnull in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_isnull in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_isnull (); int main () { return gsl_vector_complex_isnull (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_isnull=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_isnull" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_isnull" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_isnull" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_set is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_set is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_set+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_set (void) gsl_vector_complex_set; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_set=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_set" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_set" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_set" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_set in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_set in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_set+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_set (); int main () { return gsl_vector_complex_set (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_set=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_set" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_set" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_set" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_complex_set_zero is declared" >&5 $as_echo_n "checking whether gsl_vector_complex_set_zero is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_complex_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_complex_set_zero (void) gsl_vector_complex_set_zero; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_complex_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_complex_set_zero=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_complex_set_zero" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_complex_set_zero" >&6; } if test "x$ac_cv_have_decl_gsl_vector_complex_set_zero" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_complex_set_zero in -lgsl" >&5 $as_echo_n "checking for gsl_vector_complex_set_zero in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_complex_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_complex_set_zero (); int main () { return gsl_vector_complex_set_zero (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_complex_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_complex_set_zero=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_complex_set_zero" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_complex_set_zero" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_complex_set_zero" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_free is declared" >&5 $as_echo_n "checking whether gsl_vector_free is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_free+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_free (void) gsl_vector_free; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_free=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_free" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_free" >&6; } if test "x$ac_cv_have_decl_gsl_vector_free" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_free in -lgsl" >&5 $as_echo_n "checking for gsl_vector_free in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_free+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_free (); int main () { return gsl_vector_free (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_free=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_free=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_free" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_free" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_free" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_get is declared" >&5 $as_echo_n "checking whether gsl_vector_get is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_get+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_get (void) gsl_vector_get; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_get=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_get" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_get" >&6; } if test "x$ac_cv_have_decl_gsl_vector_get" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_get in -lgsl" >&5 $as_echo_n "checking for gsl_vector_get in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_get+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_get (); int main () { return gsl_vector_get (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_get=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_get=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_get" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_get" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_get" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_isnull is declared" >&5 $as_echo_n "checking whether gsl_vector_isnull is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_isnull (void) gsl_vector_isnull; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_isnull=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_isnull" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_isnull" >&6; } if test "x$ac_cv_have_decl_gsl_vector_isnull" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_isnull in -lgsl" >&5 $as_echo_n "checking for gsl_vector_isnull in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_isnull+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_isnull (); int main () { return gsl_vector_isnull (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_isnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_isnull=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_isnull" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_isnull" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_isnull" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_scale is declared" >&5 $as_echo_n "checking whether gsl_vector_scale is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_scale+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_scale (void) gsl_vector_scale; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_scale=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_scale" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_scale" >&6; } if test "x$ac_cv_have_decl_gsl_vector_scale" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_scale in -lgsl" >&5 $as_echo_n "checking for gsl_vector_scale in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_scale+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_scale (); int main () { return gsl_vector_scale (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_scale=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_scale=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_scale" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_scale" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_scale" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_set is declared" >&5 $as_echo_n "checking whether gsl_vector_set is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_set+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_set (void) gsl_vector_set; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_set=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_set" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_set" >&6; } if test "x$ac_cv_have_decl_gsl_vector_set" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_set in -lgsl" >&5 $as_echo_n "checking for gsl_vector_set in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_set+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_set (); int main () { return gsl_vector_set (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_set=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_set=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_set" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_set" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_set" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_set_zero is declared" >&5 $as_echo_n "checking whether gsl_vector_set_zero is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_set_zero (void) gsl_vector_set_zero; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_set_zero=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_set_zero" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_set_zero" >&6; } if test "x$ac_cv_have_decl_gsl_vector_set_zero" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_set_zero in -lgsl" >&5 $as_echo_n "checking for gsl_vector_set_zero in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_set_zero+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_set_zero (); int main () { return gsl_vector_set_zero (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_set_zero=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_set_zero=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_set_zero" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_set_zero" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_set_zero" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking whether gsl_vector_sub is declared" >&5 $as_echo_n "checking whether gsl_vector_sub is declared... " >&6; } if test "${ac_cv_have_decl_gsl_vector_sub+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include int main () { #ifndef gsl_vector_sub (void) gsl_vector_sub; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_gsl_vector_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_gsl_vector_sub=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_gsl_vector_sub" >&5 $as_echo "$ac_cv_have_decl_gsl_vector_sub" >&6; } if test "x$ac_cv_have_decl_gsl_vector_sub" = x""yes; then : else enable_gsl=no fi { $as_echo "$as_me:$LINENO: checking for gsl_vector_sub in -lgsl" >&5 $as_echo_n "checking for gsl_vector_sub in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_vector_sub+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_vector_sub (); int main () { return gsl_vector_sub (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_vector_sub=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_vector_sub=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_vector_sub" >&5 $as_echo "$ac_cv_lib_gsl_gsl_vector_sub" >&6; } if test "x$ac_cv_lib_gsl_gsl_vector_sub" = x""yes; then a68g_unexpected=yes else enable_gsl=no fi fi if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for gsl_blas_ddot in -lgsl" >&5 $as_echo_n "checking for gsl_blas_ddot in -lgsl... " >&6; } if test "${ac_cv_lib_gsl_gsl_blas_ddot+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lgsl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char gsl_blas_ddot (); int main () { return gsl_blas_ddot (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_gsl_gsl_blas_ddot=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_gsl_gsl_blas_ddot=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_gsl_gsl_blas_ddot" >&5 $as_echo "$ac_cv_lib_gsl_gsl_blas_ddot" >&6; } if test "x$ac_cv_lib_gsl_gsl_blas_ddot" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBGSL 1 _ACEOF LIBS="-lgsl $LIBS" fi cat >>confdefs.h <<\_ACEOF #define HAVE_GNU_GSL 1 _ACEOF fi fi if test "x$enable_parallel" = "xyes"; then { $as_echo "$as_me:$LINENO: POSIX pthreads..." >&5 $as_echo "$as_me: POSIX pthreads..." >&6;} for ac_header in pthread.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_parallel=no fi done { $as_echo "$as_me:$LINENO: checking whether pthread_attr_getstacksize is declared" >&5 $as_echo_n "checking whether pthread_attr_getstacksize is declared... " >&6; } if test "${ac_cv_have_decl_pthread_attr_getstacksize+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_attr_getstacksize (void) pthread_attr_getstacksize; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_attr_getstacksize=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_attr_getstacksize=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_attr_getstacksize" >&5 $as_echo "$ac_cv_have_decl_pthread_attr_getstacksize" >&6; } if test "x$ac_cv_have_decl_pthread_attr_getstacksize" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_attr_getstacksize in -lpthread" >&5 $as_echo_n "checking for pthread_attr_getstacksize in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_attr_getstacksize+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_attr_getstacksize (); int main () { return pthread_attr_getstacksize (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_attr_getstacksize=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_attr_getstacksize=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_attr_getstacksize" >&5 $as_echo "$ac_cv_lib_pthread_pthread_attr_getstacksize" >&6; } if test "x$ac_cv_lib_pthread_pthread_attr_getstacksize" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi if test "x$enable_parallel" = "xyes"; then { $as_echo "$as_me:$LINENO: checking whether pthread_attr_init is declared" >&5 $as_echo_n "checking whether pthread_attr_init is declared... " >&6; } if test "${ac_cv_have_decl_pthread_attr_init+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_attr_init (void) pthread_attr_init; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_attr_init=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_attr_init=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_attr_init" >&5 $as_echo "$ac_cv_have_decl_pthread_attr_init" >&6; } if test "x$ac_cv_have_decl_pthread_attr_init" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_attr_init in -lpthread" >&5 $as_echo_n "checking for pthread_attr_init in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_attr_init+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_attr_init (); int main () { return pthread_attr_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_attr_init=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_attr_init=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_attr_init" >&5 $as_echo "$ac_cv_lib_pthread_pthread_attr_init" >&6; } if test "x$ac_cv_lib_pthread_pthread_attr_init" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_attr_setstacksize is declared" >&5 $as_echo_n "checking whether pthread_attr_setstacksize is declared... " >&6; } if test "${ac_cv_have_decl_pthread_attr_setstacksize+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_attr_setstacksize (void) pthread_attr_setstacksize; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_attr_setstacksize=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_attr_setstacksize=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_attr_setstacksize" >&5 $as_echo "$ac_cv_have_decl_pthread_attr_setstacksize" >&6; } if test "x$ac_cv_have_decl_pthread_attr_setstacksize" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_attr_setstacksize in -lpthread" >&5 $as_echo_n "checking for pthread_attr_setstacksize in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_attr_setstacksize+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_attr_setstacksize (); int main () { return pthread_attr_setstacksize (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_attr_setstacksize=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_attr_setstacksize=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_attr_setstacksize" >&5 $as_echo "$ac_cv_lib_pthread_pthread_attr_setstacksize" >&6; } if test "x$ac_cv_lib_pthread_pthread_attr_setstacksize" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_create is declared" >&5 $as_echo_n "checking whether pthread_create is declared... " >&6; } if test "${ac_cv_have_decl_pthread_create+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_create (void) pthread_create; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_create=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_create=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_create" >&5 $as_echo "$ac_cv_have_decl_pthread_create" >&6; } if test "x$ac_cv_have_decl_pthread_create" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_create in -lpthread" >&5 $as_echo_n "checking for pthread_create in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_create+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_create (); int main () { return pthread_create (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_create=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_create=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_create" >&5 $as_echo "$ac_cv_lib_pthread_pthread_create" >&6; } if test "x$ac_cv_lib_pthread_pthread_create" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_equal is declared" >&5 $as_echo_n "checking whether pthread_equal is declared... " >&6; } if test "${ac_cv_have_decl_pthread_equal+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_equal (void) pthread_equal; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_equal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_equal=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_equal" >&5 $as_echo "$ac_cv_have_decl_pthread_equal" >&6; } if test "x$ac_cv_have_decl_pthread_equal" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_equal in -lpthread" >&5 $as_echo_n "checking for pthread_equal in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_equal+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_equal (); int main () { return pthread_equal (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_equal=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_equal=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_equal" >&5 $as_echo "$ac_cv_lib_pthread_pthread_equal" >&6; } if test "x$ac_cv_lib_pthread_pthread_equal" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_exit is declared" >&5 $as_echo_n "checking whether pthread_exit is declared... " >&6; } if test "${ac_cv_have_decl_pthread_exit+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_exit (void) pthread_exit; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_exit=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_exit=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_exit" >&5 $as_echo "$ac_cv_have_decl_pthread_exit" >&6; } if test "x$ac_cv_have_decl_pthread_exit" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_exit in -lpthread" >&5 $as_echo_n "checking for pthread_exit in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_exit+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_exit (); int main () { return pthread_exit (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_exit=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_exit=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_exit" >&5 $as_echo "$ac_cv_lib_pthread_pthread_exit" >&6; } if test "x$ac_cv_lib_pthread_pthread_exit" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_join is declared" >&5 $as_echo_n "checking whether pthread_join is declared... " >&6; } if test "${ac_cv_have_decl_pthread_join+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_join (void) pthread_join; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_join=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_join=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_join" >&5 $as_echo "$ac_cv_have_decl_pthread_join" >&6; } if test "x$ac_cv_have_decl_pthread_join" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_join in -lpthread" >&5 $as_echo_n "checking for pthread_join in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_join+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_join (); int main () { return pthread_join (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_join=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_join=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_join" >&5 $as_echo "$ac_cv_lib_pthread_pthread_join" >&6; } if test "x$ac_cv_lib_pthread_pthread_join" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_mutex_lock is declared" >&5 $as_echo_n "checking whether pthread_mutex_lock is declared... " >&6; } if test "${ac_cv_have_decl_pthread_mutex_lock+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_mutex_lock (void) pthread_mutex_lock; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_mutex_lock=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_mutex_lock=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_mutex_lock" >&5 $as_echo "$ac_cv_have_decl_pthread_mutex_lock" >&6; } if test "x$ac_cv_have_decl_pthread_mutex_lock" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_mutex_lock in -lpthread" >&5 $as_echo_n "checking for pthread_mutex_lock in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_mutex_lock+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_mutex_lock (); int main () { return pthread_mutex_lock (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_mutex_lock=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_mutex_lock=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_lock" >&5 $as_echo "$ac_cv_lib_pthread_pthread_mutex_lock" >&6; } if test "x$ac_cv_lib_pthread_pthread_mutex_lock" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_mutex_unlock is declared" >&5 $as_echo_n "checking whether pthread_mutex_unlock is declared... " >&6; } if test "${ac_cv_have_decl_pthread_mutex_unlock+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_mutex_unlock (void) pthread_mutex_unlock; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_mutex_unlock=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_mutex_unlock=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_mutex_unlock" >&5 $as_echo "$ac_cv_have_decl_pthread_mutex_unlock" >&6; } if test "x$ac_cv_have_decl_pthread_mutex_unlock" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_mutex_unlock in -lpthread" >&5 $as_echo_n "checking for pthread_mutex_unlock in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_mutex_unlock+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_mutex_unlock (); int main () { return pthread_mutex_unlock (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_mutex_unlock=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_mutex_unlock=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_unlock" >&5 $as_echo "$ac_cv_lib_pthread_pthread_mutex_unlock" >&6; } if test "x$ac_cv_lib_pthread_pthread_mutex_unlock" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking whether pthread_self is declared" >&5 $as_echo_n "checking whether pthread_self is declared... " >&6; } if test "${ac_cv_have_decl_pthread_self+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef pthread_self (void) pthread_self; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_pthread_self=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_pthread_self=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_pthread_self" >&5 $as_echo "$ac_cv_have_decl_pthread_self" >&6; } if test "x$ac_cv_have_decl_pthread_self" = x""yes; then : else enable_parallel=no fi { $as_echo "$as_me:$LINENO: checking for pthread_self in -lpthread" >&5 $as_echo_n "checking for pthread_self in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_self+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_self (); int main () { return pthread_self (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_self=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_self=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_self" >&5 $as_echo "$ac_cv_lib_pthread_pthread_self" >&6; } if test "x$ac_cv_lib_pthread_pthread_self" = x""yes; then a68g_unexpected=yes else enable_parallel=no fi fi if test "x$enable_parallel" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for pthread_attr_getstacksize in -lpthread" >&5 $as_echo_n "checking for pthread_attr_getstacksize in -lpthread... " >&6; } if test "${ac_cv_lib_pthread_pthread_attr_getstacksize+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pthread_attr_getstacksize (); int main () { return pthread_attr_getstacksize (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pthread_pthread_attr_getstacksize=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_attr_getstacksize=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_attr_getstacksize" >&5 $as_echo "$ac_cv_lib_pthread_pthread_attr_getstacksize" >&6; } if test "x$ac_cv_lib_pthread_pthread_attr_getstacksize" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBPTHREAD 1 _ACEOF LIBS="-lpthread $LIBS" fi cat >>confdefs.h <<\_ACEOF #define HAVE_PARALLEL_CLAUSE 1 _ACEOF fi fi if test "x$enable_postgresql" = "xyes"; then { $as_echo "$as_me:$LINENO: PostgreSQL..." >&5 $as_echo "$as_me: PostgreSQL..." >&6;} for ac_header in libpq-fe.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF else enable_postgresql=no fi done { $as_echo "$as_me:$LINENO: checking whether PQbackendPID is declared" >&5 $as_echo_n "checking whether PQbackendPID is declared... " >&6; } if test "${ac_cv_have_decl_PQbackendPID+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQbackendPID (void) PQbackendPID; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQbackendPID=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQbackendPID=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQbackendPID" >&5 $as_echo "$ac_cv_have_decl_PQbackendPID" >&6; } if test "x$ac_cv_have_decl_PQbackendPID" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQbackendPID in -lpq" >&5 $as_echo_n "checking for PQbackendPID in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQbackendPID+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQbackendPID (); int main () { return PQbackendPID (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQbackendPID=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQbackendPID=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQbackendPID" >&5 $as_echo "$ac_cv_lib_pq_PQbackendPID" >&6; } if test "x$ac_cv_lib_pq_PQbackendPID" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi if test "x$enable_postgresql" = "xyes"; then { $as_echo "$as_me:$LINENO: checking whether PQclear is declared" >&5 $as_echo_n "checking whether PQclear is declared... " >&6; } if test "${ac_cv_have_decl_PQclear+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQclear (void) PQclear; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQclear=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQclear=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQclear" >&5 $as_echo "$ac_cv_have_decl_PQclear" >&6; } if test "x$ac_cv_have_decl_PQclear" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQclear in -lpq" >&5 $as_echo_n "checking for PQclear in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQclear+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQclear (); int main () { return PQclear (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQclear=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQclear=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQclear" >&5 $as_echo "$ac_cv_lib_pq_PQclear" >&6; } if test "x$ac_cv_lib_pq_PQclear" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQcmdStatus is declared" >&5 $as_echo_n "checking whether PQcmdStatus is declared... " >&6; } if test "${ac_cv_have_decl_PQcmdStatus+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQcmdStatus (void) PQcmdStatus; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQcmdStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQcmdStatus=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQcmdStatus" >&5 $as_echo "$ac_cv_have_decl_PQcmdStatus" >&6; } if test "x$ac_cv_have_decl_PQcmdStatus" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQcmdStatus in -lpq" >&5 $as_echo_n "checking for PQcmdStatus in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQcmdStatus+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQcmdStatus (); int main () { return PQcmdStatus (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQcmdStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQcmdStatus=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQcmdStatus" >&5 $as_echo "$ac_cv_lib_pq_PQcmdStatus" >&6; } if test "x$ac_cv_lib_pq_PQcmdStatus" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQcmdTuples is declared" >&5 $as_echo_n "checking whether PQcmdTuples is declared... " >&6; } if test "${ac_cv_have_decl_PQcmdTuples+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQcmdTuples (void) PQcmdTuples; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQcmdTuples=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQcmdTuples=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQcmdTuples" >&5 $as_echo "$ac_cv_have_decl_PQcmdTuples" >&6; } if test "x$ac_cv_have_decl_PQcmdTuples" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQcmdTuples in -lpq" >&5 $as_echo_n "checking for PQcmdTuples in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQcmdTuples+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQcmdTuples (); int main () { return PQcmdTuples (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQcmdTuples=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQcmdTuples=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQcmdTuples" >&5 $as_echo "$ac_cv_lib_pq_PQcmdTuples" >&6; } if test "x$ac_cv_lib_pq_PQcmdTuples" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQconnectdb is declared" >&5 $as_echo_n "checking whether PQconnectdb is declared... " >&6; } if test "${ac_cv_have_decl_PQconnectdb+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQconnectdb (void) PQconnectdb; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQconnectdb=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQconnectdb=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQconnectdb" >&5 $as_echo "$ac_cv_have_decl_PQconnectdb" >&6; } if test "x$ac_cv_have_decl_PQconnectdb" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQconnectdb in -lpq" >&5 $as_echo_n "checking for PQconnectdb in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQconnectdb+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQconnectdb (); int main () { return PQconnectdb (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQconnectdb=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQconnectdb=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQconnectdb" >&5 $as_echo "$ac_cv_lib_pq_PQconnectdb" >&6; } if test "x$ac_cv_lib_pq_PQconnectdb" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQdb is declared" >&5 $as_echo_n "checking whether PQdb is declared... " >&6; } if test "${ac_cv_have_decl_PQdb+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQdb (void) PQdb; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQdb=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQdb=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQdb" >&5 $as_echo "$ac_cv_have_decl_PQdb" >&6; } if test "x$ac_cv_have_decl_PQdb" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQdb in -lpq" >&5 $as_echo_n "checking for PQdb in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQdb+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQdb (); int main () { return PQdb (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQdb=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQdb=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQdb" >&5 $as_echo "$ac_cv_lib_pq_PQdb" >&6; } if test "x$ac_cv_lib_pq_PQdb" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQerrorMessage is declared" >&5 $as_echo_n "checking whether PQerrorMessage is declared... " >&6; } if test "${ac_cv_have_decl_PQerrorMessage+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQerrorMessage (void) PQerrorMessage; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQerrorMessage=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQerrorMessage=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQerrorMessage" >&5 $as_echo "$ac_cv_have_decl_PQerrorMessage" >&6; } if test "x$ac_cv_have_decl_PQerrorMessage" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQerrorMessage in -lpq" >&5 $as_echo_n "checking for PQerrorMessage in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQerrorMessage+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQerrorMessage (); int main () { return PQerrorMessage (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQerrorMessage=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQerrorMessage=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQerrorMessage" >&5 $as_echo "$ac_cv_lib_pq_PQerrorMessage" >&6; } if test "x$ac_cv_lib_pq_PQerrorMessage" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQexec is declared" >&5 $as_echo_n "checking whether PQexec is declared... " >&6; } if test "${ac_cv_have_decl_PQexec+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQexec (void) PQexec; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQexec=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQexec=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQexec" >&5 $as_echo "$ac_cv_have_decl_PQexec" >&6; } if test "x$ac_cv_have_decl_PQexec" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQexec in -lpq" >&5 $as_echo_n "checking for PQexec in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQexec+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQexec (); int main () { return PQexec (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQexec=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQexec=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQexec" >&5 $as_echo "$ac_cv_lib_pq_PQexec" >&6; } if test "x$ac_cv_lib_pq_PQexec" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQfformat is declared" >&5 $as_echo_n "checking whether PQfformat is declared... " >&6; } if test "${ac_cv_have_decl_PQfformat+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQfformat (void) PQfformat; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQfformat=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQfformat=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQfformat" >&5 $as_echo "$ac_cv_have_decl_PQfformat" >&6; } if test "x$ac_cv_have_decl_PQfformat" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQfformat in -lpq" >&5 $as_echo_n "checking for PQfformat in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQfformat+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQfformat (); int main () { return PQfformat (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQfformat=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQfformat=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQfformat" >&5 $as_echo "$ac_cv_lib_pq_PQfformat" >&6; } if test "x$ac_cv_lib_pq_PQfformat" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQfinish is declared" >&5 $as_echo_n "checking whether PQfinish is declared... " >&6; } if test "${ac_cv_have_decl_PQfinish+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQfinish (void) PQfinish; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQfinish=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQfinish=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQfinish" >&5 $as_echo "$ac_cv_have_decl_PQfinish" >&6; } if test "x$ac_cv_have_decl_PQfinish" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQfinish in -lpq" >&5 $as_echo_n "checking for PQfinish in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQfinish+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQfinish (); int main () { return PQfinish (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQfinish=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQfinish=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQfinish" >&5 $as_echo "$ac_cv_lib_pq_PQfinish" >&6; } if test "x$ac_cv_lib_pq_PQfinish" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQfname is declared" >&5 $as_echo_n "checking whether PQfname is declared... " >&6; } if test "${ac_cv_have_decl_PQfname+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQfname (void) PQfname; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQfname=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQfname=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQfname" >&5 $as_echo "$ac_cv_have_decl_PQfname" >&6; } if test "x$ac_cv_have_decl_PQfname" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQfname in -lpq" >&5 $as_echo_n "checking for PQfname in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQfname+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQfname (); int main () { return PQfname (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQfname=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQfname=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQfname" >&5 $as_echo "$ac_cv_lib_pq_PQfname" >&6; } if test "x$ac_cv_lib_pq_PQfname" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQfnumber is declared" >&5 $as_echo_n "checking whether PQfnumber is declared... " >&6; } if test "${ac_cv_have_decl_PQfnumber+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQfnumber (void) PQfnumber; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQfnumber=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQfnumber=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQfnumber" >&5 $as_echo "$ac_cv_have_decl_PQfnumber" >&6; } if test "x$ac_cv_have_decl_PQfnumber" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQfnumber in -lpq" >&5 $as_echo_n "checking for PQfnumber in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQfnumber+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQfnumber (); int main () { return PQfnumber (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQfnumber=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQfnumber=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQfnumber" >&5 $as_echo "$ac_cv_lib_pq_PQfnumber" >&6; } if test "x$ac_cv_lib_pq_PQfnumber" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQgetisnull is declared" >&5 $as_echo_n "checking whether PQgetisnull is declared... " >&6; } if test "${ac_cv_have_decl_PQgetisnull+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQgetisnull (void) PQgetisnull; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQgetisnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQgetisnull=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQgetisnull" >&5 $as_echo "$ac_cv_have_decl_PQgetisnull" >&6; } if test "x$ac_cv_have_decl_PQgetisnull" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQgetisnull in -lpq" >&5 $as_echo_n "checking for PQgetisnull in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQgetisnull+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQgetisnull (); int main () { return PQgetisnull (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQgetisnull=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQgetisnull=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQgetisnull" >&5 $as_echo "$ac_cv_lib_pq_PQgetisnull" >&6; } if test "x$ac_cv_lib_pq_PQgetisnull" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQgetvalue is declared" >&5 $as_echo_n "checking whether PQgetvalue is declared... " >&6; } if test "${ac_cv_have_decl_PQgetvalue+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQgetvalue (void) PQgetvalue; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQgetvalue=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQgetvalue=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQgetvalue" >&5 $as_echo "$ac_cv_have_decl_PQgetvalue" >&6; } if test "x$ac_cv_have_decl_PQgetvalue" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQgetvalue in -lpq" >&5 $as_echo_n "checking for PQgetvalue in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQgetvalue+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQgetvalue (); int main () { return PQgetvalue (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQgetvalue=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQgetvalue=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQgetvalue" >&5 $as_echo "$ac_cv_lib_pq_PQgetvalue" >&6; } if test "x$ac_cv_lib_pq_PQgetvalue" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQhost is declared" >&5 $as_echo_n "checking whether PQhost is declared... " >&6; } if test "${ac_cv_have_decl_PQhost+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQhost (void) PQhost; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQhost=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQhost=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQhost" >&5 $as_echo "$ac_cv_have_decl_PQhost" >&6; } if test "x$ac_cv_have_decl_PQhost" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQhost in -lpq" >&5 $as_echo_n "checking for PQhost in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQhost+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQhost (); int main () { return PQhost (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQhost=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQhost=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQhost" >&5 $as_echo "$ac_cv_lib_pq_PQhost" >&6; } if test "x$ac_cv_lib_pq_PQhost" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQnfields is declared" >&5 $as_echo_n "checking whether PQnfields is declared... " >&6; } if test "${ac_cv_have_decl_PQnfields+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQnfields (void) PQnfields; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQnfields=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQnfields=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQnfields" >&5 $as_echo "$ac_cv_have_decl_PQnfields" >&6; } if test "x$ac_cv_have_decl_PQnfields" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQnfields in -lpq" >&5 $as_echo_n "checking for PQnfields in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQnfields+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQnfields (); int main () { return PQnfields (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQnfields=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQnfields=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQnfields" >&5 $as_echo "$ac_cv_lib_pq_PQnfields" >&6; } if test "x$ac_cv_lib_pq_PQnfields" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQntuples is declared" >&5 $as_echo_n "checking whether PQntuples is declared... " >&6; } if test "${ac_cv_have_decl_PQntuples+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQntuples (void) PQntuples; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQntuples=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQntuples=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQntuples" >&5 $as_echo "$ac_cv_have_decl_PQntuples" >&6; } if test "x$ac_cv_have_decl_PQntuples" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQntuples in -lpq" >&5 $as_echo_n "checking for PQntuples in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQntuples+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQntuples (); int main () { return PQntuples (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQntuples=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQntuples=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQntuples" >&5 $as_echo "$ac_cv_lib_pq_PQntuples" >&6; } if test "x$ac_cv_lib_pq_PQntuples" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQoptions is declared" >&5 $as_echo_n "checking whether PQoptions is declared... " >&6; } if test "${ac_cv_have_decl_PQoptions+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQoptions (void) PQoptions; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQoptions=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQoptions=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQoptions" >&5 $as_echo "$ac_cv_have_decl_PQoptions" >&6; } if test "x$ac_cv_have_decl_PQoptions" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQoptions in -lpq" >&5 $as_echo_n "checking for PQoptions in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQoptions+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQoptions (); int main () { return PQoptions (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQoptions=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQoptions=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQoptions" >&5 $as_echo "$ac_cv_lib_pq_PQoptions" >&6; } if test "x$ac_cv_lib_pq_PQoptions" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQparameterStatus is declared" >&5 $as_echo_n "checking whether PQparameterStatus is declared... " >&6; } if test "${ac_cv_have_decl_PQparameterStatus+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQparameterStatus (void) PQparameterStatus; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQparameterStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQparameterStatus=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQparameterStatus" >&5 $as_echo "$ac_cv_have_decl_PQparameterStatus" >&6; } if test "x$ac_cv_have_decl_PQparameterStatus" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQparameterStatus in -lpq" >&5 $as_echo_n "checking for PQparameterStatus in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQparameterStatus+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQparameterStatus (); int main () { return PQparameterStatus (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQparameterStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQparameterStatus=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQparameterStatus" >&5 $as_echo "$ac_cv_lib_pq_PQparameterStatus" >&6; } if test "x$ac_cv_lib_pq_PQparameterStatus" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQpass is declared" >&5 $as_echo_n "checking whether PQpass is declared... " >&6; } if test "${ac_cv_have_decl_PQpass+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQpass (void) PQpass; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQpass=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQpass=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQpass" >&5 $as_echo "$ac_cv_have_decl_PQpass" >&6; } if test "x$ac_cv_have_decl_PQpass" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQpass in -lpq" >&5 $as_echo_n "checking for PQpass in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQpass+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQpass (); int main () { return PQpass (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQpass=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQpass=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQpass" >&5 $as_echo "$ac_cv_lib_pq_PQpass" >&6; } if test "x$ac_cv_lib_pq_PQpass" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQport is declared" >&5 $as_echo_n "checking whether PQport is declared... " >&6; } if test "${ac_cv_have_decl_PQport+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQport (void) PQport; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQport=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQport=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQport" >&5 $as_echo "$ac_cv_have_decl_PQport" >&6; } if test "x$ac_cv_have_decl_PQport" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQport in -lpq" >&5 $as_echo_n "checking for PQport in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQport+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQport (); int main () { return PQport (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQport=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQport=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQport" >&5 $as_echo "$ac_cv_lib_pq_PQport" >&6; } if test "x$ac_cv_lib_pq_PQport" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQprotocolVersion is declared" >&5 $as_echo_n "checking whether PQprotocolVersion is declared... " >&6; } if test "${ac_cv_have_decl_PQprotocolVersion+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQprotocolVersion (void) PQprotocolVersion; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQprotocolVersion=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQprotocolVersion=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQprotocolVersion" >&5 $as_echo "$ac_cv_have_decl_PQprotocolVersion" >&6; } if test "x$ac_cv_have_decl_PQprotocolVersion" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQprotocolVersion in -lpq" >&5 $as_echo_n "checking for PQprotocolVersion in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQprotocolVersion+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQprotocolVersion (); int main () { return PQprotocolVersion (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQprotocolVersion=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQprotocolVersion=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQprotocolVersion" >&5 $as_echo "$ac_cv_lib_pq_PQprotocolVersion" >&6; } if test "x$ac_cv_lib_pq_PQprotocolVersion" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQreset is declared" >&5 $as_echo_n "checking whether PQreset is declared... " >&6; } if test "${ac_cv_have_decl_PQreset+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQreset (void) PQreset; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQreset=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQreset=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQreset" >&5 $as_echo "$ac_cv_have_decl_PQreset" >&6; } if test "x$ac_cv_have_decl_PQreset" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQreset in -lpq" >&5 $as_echo_n "checking for PQreset in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQreset+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQreset (); int main () { return PQreset (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQreset=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQreset=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQreset" >&5 $as_echo "$ac_cv_lib_pq_PQreset" >&6; } if test "x$ac_cv_lib_pq_PQreset" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQresultErrorMessage is declared" >&5 $as_echo_n "checking whether PQresultErrorMessage is declared... " >&6; } if test "${ac_cv_have_decl_PQresultErrorMessage+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQresultErrorMessage (void) PQresultErrorMessage; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQresultErrorMessage=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQresultErrorMessage=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQresultErrorMessage" >&5 $as_echo "$ac_cv_have_decl_PQresultErrorMessage" >&6; } if test "x$ac_cv_have_decl_PQresultErrorMessage" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQresultErrorMessage in -lpq" >&5 $as_echo_n "checking for PQresultErrorMessage in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQresultErrorMessage+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQresultErrorMessage (); int main () { return PQresultErrorMessage (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQresultErrorMessage=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQresultErrorMessage=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQresultErrorMessage" >&5 $as_echo "$ac_cv_lib_pq_PQresultErrorMessage" >&6; } if test "x$ac_cv_lib_pq_PQresultErrorMessage" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQresultStatus is declared" >&5 $as_echo_n "checking whether PQresultStatus is declared... " >&6; } if test "${ac_cv_have_decl_PQresultStatus+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQresultStatus (void) PQresultStatus; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQresultStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQresultStatus=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQresultStatus" >&5 $as_echo "$ac_cv_have_decl_PQresultStatus" >&6; } if test "x$ac_cv_have_decl_PQresultStatus" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQresultStatus in -lpq" >&5 $as_echo_n "checking for PQresultStatus in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQresultStatus+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQresultStatus (); int main () { return PQresultStatus (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQresultStatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQresultStatus=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQresultStatus" >&5 $as_echo "$ac_cv_lib_pq_PQresultStatus" >&6; } if test "x$ac_cv_lib_pq_PQresultStatus" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQserverVersion is declared" >&5 $as_echo_n "checking whether PQserverVersion is declared... " >&6; } if test "${ac_cv_have_decl_PQserverVersion+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQserverVersion (void) PQserverVersion; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQserverVersion=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQserverVersion=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQserverVersion" >&5 $as_echo "$ac_cv_have_decl_PQserverVersion" >&6; } if test "x$ac_cv_have_decl_PQserverVersion" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQserverVersion in -lpq" >&5 $as_echo_n "checking for PQserverVersion in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQserverVersion+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQserverVersion (); int main () { return PQserverVersion (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQserverVersion=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQserverVersion=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQserverVersion" >&5 $as_echo "$ac_cv_lib_pq_PQserverVersion" >&6; } if test "x$ac_cv_lib_pq_PQserverVersion" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQsocket is declared" >&5 $as_echo_n "checking whether PQsocket is declared... " >&6; } if test "${ac_cv_have_decl_PQsocket+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQsocket (void) PQsocket; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQsocket=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQsocket=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQsocket" >&5 $as_echo "$ac_cv_have_decl_PQsocket" >&6; } if test "x$ac_cv_have_decl_PQsocket" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQsocket in -lpq" >&5 $as_echo_n "checking for PQsocket in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQsocket+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQsocket (); int main () { return PQsocket (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQsocket=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQsocket=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQsocket" >&5 $as_echo "$ac_cv_lib_pq_PQsocket" >&6; } if test "x$ac_cv_lib_pq_PQsocket" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQstatus is declared" >&5 $as_echo_n "checking whether PQstatus is declared... " >&6; } if test "${ac_cv_have_decl_PQstatus+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQstatus (void) PQstatus; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQstatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQstatus=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQstatus" >&5 $as_echo "$ac_cv_have_decl_PQstatus" >&6; } if test "x$ac_cv_have_decl_PQstatus" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQstatus in -lpq" >&5 $as_echo_n "checking for PQstatus in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQstatus+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQstatus (); int main () { return PQstatus (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQstatus=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQstatus=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQstatus" >&5 $as_echo "$ac_cv_lib_pq_PQstatus" >&6; } if test "x$ac_cv_lib_pq_PQstatus" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQtty is declared" >&5 $as_echo_n "checking whether PQtty is declared... " >&6; } if test "${ac_cv_have_decl_PQtty+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQtty (void) PQtty; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQtty=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQtty=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQtty" >&5 $as_echo "$ac_cv_have_decl_PQtty" >&6; } if test "x$ac_cv_have_decl_PQtty" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQtty in -lpq" >&5 $as_echo_n "checking for PQtty in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQtty+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQtty (); int main () { return PQtty (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQtty=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQtty=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQtty" >&5 $as_echo "$ac_cv_lib_pq_PQtty" >&6; } if test "x$ac_cv_lib_pq_PQtty" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking whether PQuser is declared" >&5 $as_echo_n "checking whether PQuser is declared... " >&6; } if test "${ac_cv_have_decl_PQuser+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef PQuser (void) PQuser; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_PQuser=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_PQuser=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_PQuser" >&5 $as_echo "$ac_cv_have_decl_PQuser" >&6; } if test "x$ac_cv_have_decl_PQuser" = x""yes; then : else enable_postgresql=no fi { $as_echo "$as_me:$LINENO: checking for PQuser in -lpq" >&5 $as_echo_n "checking for PQuser in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQuser+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQuser (); int main () { return PQuser (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQuser=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQuser=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQuser" >&5 $as_echo "$ac_cv_lib_pq_PQuser" >&6; } if test "x$ac_cv_lib_pq_PQuser" = x""yes; then a68g_unexpected=yes else enable_postgresql=no fi fi if test "x$enable_postgresql" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for PQbackendPID in -lpq" >&5 $as_echo_n "checking for PQbackendPID in -lpq... " >&6; } if test "${ac_cv_lib_pq_PQbackendPID+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpq $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char PQbackendPID (); int main () { return PQbackendPID (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_pq_PQbackendPID=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pq_PQbackendPID=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_pq_PQbackendPID" >&5 $as_echo "$ac_cv_lib_pq_PQbackendPID" >&6; } if test "x$ac_cv_lib_pq_PQbackendPID" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBPQ 1 _ACEOF LIBS="-lpq $LIBS" fi cat >>confdefs.h <<\_ACEOF #define HAVE_POSTGRESQL 1 _ACEOF fi fi if test "x$enable_compiler" = "xyes"; then { $as_echo "$as_me:$LINENO: Dynamic loader..." >&5 $as_echo "$as_me: Dynamic loader..." >&6;} for ac_header in dlfcn.h do as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 $as_echo_n "checking $ac_header usability... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_header_compiler=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 $as_echo_n "checking $ac_header presence... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then ac_header_preproc=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext { $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 $as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 $as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ------------------------------------------------------- ## ## Report this to Marcel van der Veer ## ## ------------------------------------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 $as_echo_n "checking for $ac_header... " >&6; } if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then $as_echo_n "(cached) " >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi ac_res=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi as_val=`eval 'as_val=${'$as_ac_Header'} $as_echo "$as_val"'` if test "x$as_val" = x""yes; then cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done { $as_echo "$as_me:$LINENO: checking whether dlopen is declared" >&5 $as_echo_n "checking whether dlopen is declared... " >&6; } if test "${ac_cv_have_decl_dlopen+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef dlopen (void) dlopen; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_dlopen=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_dlopen" >&5 $as_echo "$ac_cv_have_decl_dlopen" >&6; } if test "x$ac_cv_have_decl_dlopen" = x""yes; then : else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlopen+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_dl_dlopen=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlopen=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = x""yes; then a68g_unexpected=yes else enable_compiler=no fi if test "x$enable_compiler" = "xyes"; then { $as_echo "$as_me:$LINENO: checking whether dlsym is declared" >&5 $as_echo_n "checking whether dlsym is declared... " >&6; } if test "${ac_cv_have_decl_dlsym+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef dlsym (void) dlsym; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_dlsym=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_dlsym=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_dlsym" >&5 $as_echo "$ac_cv_have_decl_dlsym" >&6; } if test "x$ac_cv_have_decl_dlsym" = x""yes; then : else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking for dlsym in -ldl" >&5 $as_echo_n "checking for dlsym in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlsym+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlsym (); int main () { return dlsym (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_dl_dlsym=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlsym=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlsym" >&5 $as_echo "$ac_cv_lib_dl_dlsym" >&6; } if test "x$ac_cv_lib_dl_dlsym" = x""yes; then a68g_unexpected=yes else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking whether dlerror is declared" >&5 $as_echo_n "checking whether dlerror is declared... " >&6; } if test "${ac_cv_have_decl_dlerror+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef dlerror (void) dlerror; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_dlerror=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_dlerror=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_dlerror" >&5 $as_echo "$ac_cv_have_decl_dlerror" >&6; } if test "x$ac_cv_have_decl_dlerror" = x""yes; then : else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking for dlerror in -ldl" >&5 $as_echo_n "checking for dlerror in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlerror+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlerror (); int main () { return dlerror (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_dl_dlerror=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlerror=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlerror" >&5 $as_echo "$ac_cv_lib_dl_dlerror" >&6; } if test "x$ac_cv_lib_dl_dlerror" = x""yes; then a68g_unexpected=yes else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking whether dlclose is declared" >&5 $as_echo_n "checking whether dlclose is declared... " >&6; } if test "${ac_cv_have_decl_dlclose+set}" = set; then $as_echo_n "(cached) " >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { #ifndef dlclose (void) dlclose; #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_compile") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then ac_cv_have_decl_dlclose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_have_decl_dlclose=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:$LINENO: result: $ac_cv_have_decl_dlclose" >&5 $as_echo "$ac_cv_have_decl_dlclose" >&6; } if test "x$ac_cv_have_decl_dlclose" = x""yes; then : else enable_compiler=no fi { $as_echo "$as_me:$LINENO: checking for dlclose in -ldl" >&5 $as_echo_n "checking for dlclose in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlclose+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlclose (); int main () { return dlclose (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_dl_dlclose=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlclose=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlclose" >&5 $as_echo "$ac_cv_lib_dl_dlclose" >&6; } if test "x$ac_cv_lib_dl_dlclose" = x""yes; then a68g_unexpected=yes else enable_compiler=no fi fi if test "x$enable_compiler" = "xyes"; then { $as_echo "$as_me:$LINENO: checking for dlopen in -ldl" >&5 $as_echo_n "checking for dlopen in -ldl... " >&6; } if test "${ac_cv_lib_dl_dlopen+set}" = set; then $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char dlopen (); int main () { return dlopen (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" $as_echo "$ac_try_echo") >&5 (eval "$ac_link") 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then ac_cv_lib_dl_dlopen=yes else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlopen=no fi rm -rf conftest.dSYM rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5 $as_echo "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = x""yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBDL 1 _ACEOF LIBS="-ldl $LIBS" fi cat >>confdefs.h <<\_ACEOF #define HAVE_DL 1 _ACEOF fi fi # # Generate files. # ac_config_files="$ac_config_files Makefile" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:$LINENO: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) $as_unset $ac_var ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then test "x$cache_file" != "x/dev/null" && { $as_echo "$as_me:$LINENO: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} cat confcache >$cache_file else { $as_echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' DEFS=-DHAVE_CONFIG_H ac_libobjs= ac_ltlibobjs= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext" ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then { { $as_echo "$as_me:$LINENO: error: conditional \"AMDEP\" was never defined. Usually this means the macro was only invoked conditionally." >&5 $as_echo "$as_me: error: conditional \"AMDEP\" was never defined. Usually this means the macro was only invoked conditionally." >&2;} { (exit 1); exit 1; }; } fi if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then { { $as_echo "$as_me:$LINENO: error: conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." >&5 $as_echo "$as_me: error: conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." >&2;} { (exit 1); exit 1; }; } fi if test -z "${EXPORT_DYNAMIC_TRUE}" && test -z "${EXPORT_DYNAMIC_FALSE}"; then { { $as_echo "$as_me:$LINENO: error: conditional \"EXPORT_DYNAMIC\" was never defined. Usually this means the macro was only invoked conditionally." >&5 $as_echo "$as_me: error: conditional \"EXPORT_DYNAMIC\" was never defined. Usually this means the macro was only invoked conditionally." >&2;} { (exit 1); exit 1; }; } fi : ${CONFIG_STATUS=./config.status} ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} cat >$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in *posix*) set -o posix ;; esac fi # PATH needs CR # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo if (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. case $0 in *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 { (exit 1); exit 1; } fi # Work around bugs in pre-3.0 UWIN ksh. for as_var in ENV MAIL MAILPATH do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # Required to use basename. if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi # Name of the executable. as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # CDPATH. $as_unset CDPATH as_lineno_1=$LINENO as_lineno_2=$LINENO test "x$as_lineno_1" != "x$as_lineno_2" && test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || { # Create $as_me.lineno as a copy of $as_myself, but with $LINENO # uniformly replaced by the line number. The first 'sed' inserts a # line-number line after each line using $LINENO; the second 'sed' # does the real work. The second script uses 'N' to pair each # line-number line with the line containing $LINENO, and appends # trailing '-' during substitution so that $LINENO is not a special # case at line end. # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the # scripts with optimization help from Paolo Bonzini. Blame Lee # E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 { (exit 1); exit 1; }; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in -n*) case `echo 'x\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. *) ECHO_C='\c';; esac;; *) ECHO_N='-n';; esac if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 # Save the log message, to keep $[0] and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by algol68g $as_me 2.8, which was generated by GNU Autoconf 2.63. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" config_headers="$ac_config_headers" config_commands="$ac_config_commands" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files from templates according to the current configuration. Usage: $0 [OPTION]... [FILE]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE --header=FILE[:TEMPLATE] instantiate the configuration header FILE Configuration files: $config_files Configuration headers: $config_headers Configuration commands: $config_commands Report bugs to ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_version="\\ algol68g config.status 2.8 configured by $0, generated by GNU Autoconf 2.63, with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" Copyright (C) 2008 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' INSTALL='$INSTALL' MKDIR_P='$MKDIR_P' AWK='$AWK' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac CONFIG_FILES="$CONFIG_FILES '$ac_optarg'" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac CONFIG_HEADERS="$CONFIG_HEADERS '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header { $as_echo "$as_me: error: ambiguous option: $1 Try \`$0 --help' for more information." >&2 { (exit 1); exit 1; }; };; --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) { $as_echo "$as_me: error: unrecognized option: $1 Try \`$0 --help' for more information." >&2 { (exit 1); exit 1; }; } ;; *) ac_config_targets="$ac_config_targets $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # # INIT-COMMANDS # AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "source/a68g-config.h") CONFIG_HEADERS="$CONFIG_HEADERS source/a68g-config.h" ;; "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; *) { { $as_echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 $as_echo "$as_me: error: invalid argument: $ac_config_target" >&2;} { (exit 1); exit 1; }; };; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= trap 'exit_status=$? { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status ' 0 trap '{ (exit 1); exit 1; }' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || { $as_echo "$as_me: cannot create a temporary directory in ." >&2 { (exit 1); exit 1; } } # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=' ' ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 $as_echo "$as_me: error: could not make $CONFIG_STATUS" >&2;} { (exit 1); exit 1; }; } ac_delim_num=`echo "$ac_subst_vars" | grep -c '$'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 $as_echo "$as_me: error: could not make $CONFIG_STATUS" >&2;} { (exit 1); exit 1; }; } ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 $as_echo "$as_me: error: could not make $CONFIG_STATUS" >&2;} { (exit 1); exit 1; }; } else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\).*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\).*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \ || { { $as_echo "$as_me:$LINENO: error: could not setup config files machinery" >&5 $as_echo "$as_me: error: could not setup config files machinery" >&2;} { (exit 1); exit 1; }; } _ACEOF # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=/{ s/:*\$(srcdir):*/:/ s/:*\${srcdir}:*/:/ s/:*@srcdir@:*/:/ s/^\([^=]*=[ ]*\):*/\1/ s/:*$// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF # Transform confdefs.h into an awk script `defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. # Create a delimiter string that does not exist in confdefs.h, to ease # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do ac_t=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_t"; then break elif $ac_last_try; then { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_HEADERS" >&5 $as_echo "$as_me: error: could not make $CONFIG_HEADERS" >&2;} { (exit 1); exit 1; }; } else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done # For the awk script, D is an array of macro values keyed by name, # likewise P contains macro parameters if any. Preserve backslash # newline sequences. ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* sed -n ' s/.\{148\}/&'"$ac_delim"'/g t rset :rset s/^[ ]*#[ ]*define[ ][ ]*/ / t def d :def s/\\$// t bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3"/p s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p d :bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3\\\\\\n"\\/p t cont s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p t cont d :cont n s/.\{148\}/&'"$ac_delim"'/g t clear :clear s/\\$// t bsnlc s/["\\]/\\&/g; s/^/"/; s/$/"/p d :bsnlc s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p b cont ' >$CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 for (key in D) D_is_set[key] = 1 FS = "" } /^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { line = \$ 0 split(line, arg, " ") if (arg[1] == "#") { defundef = arg[2] mac1 = arg[3] } else { defundef = substr(arg[1], 2) mac1 = arg[2] } split(mac1, mac2, "(") #) macro = mac2[1] prefix = substr(line, 1, index(line, defundef) - 1) if (D_is_set[macro]) { # Preserve the white space surrounding the "#". print prefix "define", macro P[macro] D[macro] next } else { # Replace #undef with comments. This is necessary, for example, # in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it. if (defundef == "undef") { print "/*", prefix defundef, macro, "*/" next } } } { print } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 { { $as_echo "$as_me:$LINENO: error: could not setup config headers machinery" >&5 $as_echo "$as_me: error: could not setup config headers machinery" >&2;} { (exit 1); exit 1; }; } fi # test -n "$CONFIG_HEADERS" eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS :C $CONFIG_COMMANDS" shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) { { $as_echo "$as_me:$LINENO: error: invalid tag $ac_tag" >&5 $as_echo "$as_me: error: invalid tag $ac_tag" >&2;} { (exit 1); exit 1; }; };; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || { { $as_echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5 $as_echo "$as_me: error: cannot find input file: $ac_f" >&2;} { (exit 1); exit 1; }; };; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac ac_file_inputs="$ac_file_inputs '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:$LINENO: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$tmp/stdin" \ || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 $as_echo "$as_me: error: could not create $ac_file" >&2;} { (exit 1); exit 1; }; } ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` { as_dir="$ac_dir" case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || { { $as_echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5 $as_echo "$as_me: error: cannot create directory $as_dir" >&2;} { (exit 1); exit 1; }; }; } ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # case $INSTALL in [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; esac ac_MKDIR_P=$MKDIR_P case $MKDIR_P in [\\/$]* | ?:[\\/]* ) ;; */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;; esac _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p ' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t s&@INSTALL@&$ac_INSTALL&;t t s&@MKDIR_P@&$ac_MKDIR_P&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \ || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 $as_echo "$as_me: error: could not create $ac_file" >&2;} { (exit 1); exit 1; }; } test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined." >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined." >&2;} rm -f "$tmp/stdin" case $ac_file in -) cat "$tmp/out" && rm -f "$tmp/out";; *) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";; esac \ || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 $as_echo "$as_me: error: could not create $ac_file" >&2;} { (exit 1); exit 1; }; } ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { $as_echo "/* $configure_input */" \ && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" } >"$tmp/config.h" \ || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 $as_echo "$as_me: error: could not create $ac_file" >&2;} { (exit 1); exit 1; }; } if diff "$ac_file" "$tmp/config.h" >/dev/null 2>&1; then { $as_echo "$as_me:$LINENO: $ac_file is unchanged" >&5 $as_echo "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$tmp/config.h" "$ac_file" \ || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 $as_echo "$as_me: error: could not create $ac_file" >&2;} { (exit 1); exit 1; }; } fi else $as_echo "/* $configure_input */" \ && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" \ || { { $as_echo "$as_me:$LINENO: error: could not create -" >&5 $as_echo "$as_me: error: could not create -" >&2;} { (exit 1); exit 1; }; } fi # Compute "$ac_file"'s index in $config_headers. _am_arg="$ac_file" _am_stamp_count=1 for _am_header in $config_headers :; do case $_am_header in $_am_arg | $_am_arg:* ) break ;; * ) _am_stamp_count=`expr $_am_stamp_count + 1` ;; esac done echo "timestamp for $_am_arg" >`$as_dirname -- "$_am_arg" || $as_expr X"$_am_arg" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$_am_arg" : 'X\(//\)[^/]' \| \ X"$_am_arg" : 'X\(//\)$' \| \ X"$_am_arg" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$_am_arg" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'`/stamp-h$_am_stamp_count ;; :C) { $as_echo "$as_me:$LINENO: executing $ac_file commands" >&5 $as_echo "$as_me: executing $ac_file commands" >&6;} ;; esac case $ac_file$ac_mode in "depfiles":C) test x"$AMDEP_TRUE" != x"" || for mf in $CONFIG_FILES; do # Strip MF so we end up with the name of the file. mf=`echo "$mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile or not. # We used to match only the files named `Makefile.in', but # some people rename them; so instead we look at the file content. # Grep'ing the first line is not enough: some people post-process # each Makefile.in and add a new line on top of each file to say so. # Grep'ing the whole file is not good either: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then dirpart=`$as_dirname -- "$mf" || $as_expr X"$mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$mf" : 'X\(//\)[^/]' \| \ X"$mf" : 'X\(//\)$' \| \ X"$mf" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$mf" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` else continue fi # Extract the definition of DEPDIR, am__include, and am__quote # from the Makefile without running `make'. DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` test -z "$DEPDIR" && continue am__include=`sed -n 's/^am__include = //p' < "$mf"` test -z "am__include" && continue am__quote=`sed -n 's/^am__quote = //p' < "$mf"` # When using ansi2knr, U may be empty or an underscore; expand it U=`sed -n 's/^U = //p' < "$mf"` # Find all dependency output files, they are included files with # $(DEPDIR) in their names. We invoke sed twice because it is the # simplest approach to changing $(DEPDIR) to its actual value in the # expansion. for file in `sed -n " s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g' -e 's/\$U/'"$U"'/g'`; do # Make sure the directory exists. test -f "$dirpart/$file" && continue fdir=`$as_dirname -- "$file" || $as_expr X"$file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$file" : 'X\(//\)[^/]' \| \ X"$file" : 'X\(//\)$' \| \ X"$file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` { as_dir=$dirpart/$fdir case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || { { $as_echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5 $as_echo "$as_me: error: cannot create directory $as_dir" >&2;} { (exit 1); exit 1; }; }; } # echo "creating $dirpart/$file" echo '# dummy' > "$dirpart/$file" done done ;; esac done # for ac_tag { (exit 0); exit 0; } _ACEOF chmod +x $CONFIG_STATUS ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || { { $as_echo "$as_me:$LINENO: error: write failure creating $CONFIG_STATUS" >&5 $as_echo "$as_me: error: write failure creating $CONFIG_STATUS" >&2;} { (exit 1); exit 1; }; } # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || { (exit 1); exit 1; } fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:$LINENO: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi { $as_echo "$as_me:$LINENO: " >&5 $as_echo "$as_me: " >&6;} { $as_echo "$as_me:$LINENO: algol68g-2.8 by Marcel van der Veer " >&5 $as_echo "$as_me: algol68g-2.8 by Marcel van der Veer " >&6;} if test "x$a68g_exists" = "xyes"; then { $as_echo "$as_me:$LINENO: algol68g already exists on this system" >&5 $as_echo "$as_me: algol68g already exists on this system" >&6;} fi if test "x$enable_parallel" = "xyes"; then { $as_echo "$as_me:$LINENO: building with parallel clause" >&5 $as_echo "$as_me: building with parallel clause" >&6;} fi if test "x$enable_plotutils" = "xyes"; then { $as_echo "$as_me:$LINENO: building with GNU plotutils" >&5 $as_echo "$as_me: building with GNU plotutils" >&6;} fi if test "x$enable_gsl" = "xyes"; then { $as_echo "$as_me:$LINENO: building with GNU scientific library" >&5 $as_echo "$as_me: building with GNU scientific library" >&6;} fi if test "x$enable_postgresql" = "xyes"; then { $as_echo "$as_me:$LINENO: building with PostgreSQL" >&5 $as_echo "$as_me: building with PostgreSQL" >&6;} fi if test "x$enable_compiler" = "xyes"; then { $as_echo "$as_me:$LINENO: building compiler-interpreter" >&5 $as_echo "$as_me: building compiler-interpreter" >&6;} else { $as_echo "$as_me:$LINENO: building interpreter-only" >&5 $as_echo "$as_me: building interpreter-only" >&6;} fi { $as_echo "$as_me:$LINENO: now type 'make' optionally followed by 'make check' or 'make install'" >&5 $as_echo "$as_me: now type 'make' optionally followed by 'make check' or 'make install'" >&6;} algol68g-2.8/configure.ac0000644000175000001440000005432712224300564012222 00000000000000AC_INIT([algol68g], [2.8], [Marcel van der Veer ]) # # Algol 68 Genie "configure.ac" from "a68g-tools". # AC_PREREQ([2.60]) # Check whether compiler supports $1 as a command-line option. # If it does, add the string to CFLAGS. AC_DEFUN([A68G_AC_PROG_CC_CFLAGS], [AC_MSG_CHECKING([whether $CC accepts $1]) a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS $1" _AC_COMPILE_IFELSE([AC_LANG_PROGRAM()], AC_MSG_RESULT(yes), [CFLAGS="$a68g_ac_save_CFLAGS" AC_MSG_RESULT(no)]) ]) # Check whether $1 is in GNU plotutils. AC_DEFUN([A68G_AC_PLOTUTILS], [AC_CHECK_DECL([$1], [], [enable_plotutils=no], [ #include #include ]) AC_CHECK_LIB([plot], [$1], [a68g_unexpected=yes], [enable_plotutils=no]) ]) # Check whether $1 is in GNU GSL. AC_DEFUN([A68G_AC_GSL], [AC_CHECK_DECL([$1], [], [enable_gsl=no], [ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include ]) AC_CHECK_LIB([gsl], [$1], [a68g_unexpected=yes], [enable_gsl=no]) ]) # Check whether $1 is in PostgreSQL. AC_DEFUN([A68G_AC_POSTGRESQL], [AC_CHECK_DECL([$1], [], [enable_postgresql=no], [ #include ]) AC_CHECK_LIB([pq], [$1], [a68g_unexpected=yes], [enable_postgresql=no]) ]) # Check whether $1 is in pthread. AC_DEFUN([A68G_AC_PTHREAD], [AC_CHECK_DECL([$1], [], [enable_parallel=no], [ #include ]) AC_CHECK_LIB([pthread], [$1], [a68g_unexpected=yes], [enable_parallel=no]) ]) # Check whether $1 is in dl. AC_DEFUN([A68G_AC_DL], [AC_CHECK_DECL([$1], [], [enable_compiler=no], [ #include ]) AC_CHECK_LIB([dl], [$1], [a68g_unexpected=yes], [enable_compiler=no]) ]) # # Platform ids. # AC_MSG_NOTICE([host system...]) AC_CANONICAL_BUILD AC_CANONICAL_HOST AC_CANONICAL_TARGET AC_MSG_CHECKING([platform]) case "$host" in # # Linux. # *86-*-gnu | *86_64-*-gnu | *86-*-linux* | *86_64-*-linux* | arm*-*-linux*) AC_DEFINE(HAVE_LINUX, 1, [Define this if LINUX was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_RESULT([linux]) ;; # # Cygwin. # *86-*-cygwin* | *86_64-*-cygwin*) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_RESULT([cygwin]) ;; # # Mac OS X. # *86-*-*darwin* | *86_64-*-*darwin*) AC_DEFINE(HAVE_MAC_OS_X, 1, [Define this if DARWIN was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_RESULT([mac os x]) ;; # # FreeBSD. # *86-*-freebsd* | *86_64-*-freebsd*) AC_DEFINE(HAVE_FREEBSD, 1, [Define this if FreeBSD was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_RESULT([freebsd]) ;; # # NetBSD. # *86-*-netbsd* | *86_64-*-netbsd*) AC_DEFINE(HAVE_NETBSD, 1, [Define this if NetBSD was detected]) AC_DEFINE(HAVE_IEEE_754, 1, [Define this if IEEE_754 compliant]) AC_MSG_RESULT([netbsd]) ;; # # OpenBSD. # *86-*-openbsd* | *86_64-*-openbsd*) AC_DEFINE(HAVE_OPENBSD, 1, [Define this if OpenBSD was detected]) AC_MSG_WARN([configuring interpreter-only on OpenBSD]) AC_MSG_RESULT([openbsd]) enable_compiler=no ;; # # Others, untested. # *) AC_DEFINE(HAVE_UNTESTED, 1, [Define this if untested OS was detected]) AC_MSG_WARN([configuring interpreter-only on untested platform]) AC_MSG_RESULT([interpreter-only]) enable_compiler=no ;; esac # # Extra options. # AC_ARG_ENABLE(arch, [AS_HELP_STRING([--enable-arch=cpu], [if using gcc, enable emitting architecture-tuned assembly code (default is "no")])], , enable_arch=no) AC_ARG_ENABLE(compiler, [AS_HELP_STRING([--enable-compiler], [enable unit compiler (default is "yes")])], , enable_compiler=yes) AC_ARG_ENABLE(curses, [AS_HELP_STRING([--enable-curses], [if installed, enable curses library (default is "yes")])], , enable_curses=yes) AC_ARG_ENABLE(readline, [AS_HELP_STRING([--enable-readline], [if installed, enable readline library (default is "yes")])], , enable_readline=yes) AC_ARG_ENABLE(gsl, [AS_HELP_STRING([--enable-gsl], [if installed, enable GNU Scientific Library (default is "yes")])], , enable_gsl=yes) AC_ARG_ENABLE(parallel, [AS_HELP_STRING([--enable-parallel], [enable Algol 68 parallel-clause (default is "yes")])], , enable_parallel=yes) AC_ARG_ENABLE(pic, [AS_HELP_STRING([--enable-pic=option], [if using gcc, enable option to generate PIC (default is "-fPIC")])], , enable_pic="-fPIC") AC_ARG_ENABLE(prescott, [AS_HELP_STRING([--enable-prescott], [if using gcc, enable optimisation for P4 Prescott (default is "no")])], , enable_prescott=no) AC_ARG_ENABLE(plotutils, [AS_HELP_STRING([--enable-plotutils], [if installed, enable GNU plotting utilities (default is "yes")])], , enable_plotutils=yes) AC_ARG_ENABLE(postgresql, [AS_HELP_STRING([--enable-postgresql], [if installed, enable PostgreSQL (default is "yes")])], , enable_postgresql=yes) # # Initialisation. # AC_MSG_NOTICE([initialising...]) AM_INIT_AUTOMAKE([subdir-objects]) AC_PREFIX_DEFAULT(/usr/local) AC_CONFIG_SRCDIR([source/a68g.h]) AC_CONFIG_HEADERS([source/a68g-config.h]) AC_PROG_INSTALL AC_CHECK_PROG(a68g_exists, a68g, "yes") # # C compiler. # AC_MSG_NOTICE([C compiler...]) AC_LANG(C) AC_PROG_CC([clang gcc cc]) if test "x$GCC" != "xyes"; then a68g_ac_compiler=no AC_MSG_WARN([gcc is the preferred C compiler; configuring interpreter-only]) else AC_DEFINE(HAVE_GCC, 1, [Define this if GCC was detected]) if test "x$enable_prescott" != "xno"; then CFLAGS="-O3 -fomit-frame-pointer -march=prescott -funroll-loops" enable_pic="no" fi A68G_AC_PROG_CC_CFLAGS([-pedantic]) A68G_AC_PROG_CC_CFLAGS([-W]) A68G_AC_PROG_CC_CFLAGS([-Wall]) A68G_AC_PROG_CC_CFLAGS([-Wextra]) A68G_AC_PROG_CC_CFLAGS([-Wshadow]) # A68G_AC_PROG_CC_CFLAGS([-Wconversion]) Too much warnings! A68G_AC_PROG_CC_CFLAGS([-Wstrict-prototypes]) A68G_AC_PROG_CC_CFLAGS([-Wchar-subscripts]) # # Test on gcc capabilities. # # # Check -Wl,--export-dynamic, needed for creating shared objects. # # Check whether we can link to a particular function, not just whether we can link. # In fact, we must actually check that the resulting program runs. # a68g_ac_arg="-Wl,--export-dynamic" AC_MSG_CHECKING([if $CC accepts $a68g_ac_arg]) a68g_ac_save_LDFLAGS=$LDFLAGS LDFLAGS="$a68g_ac_save_LDFLAGS $a68g_ac_arg" AC_RUN_IFELSE([AC_LANG_PROGRAM([extern void exit (); void (*fptr) () = exit;],[])], [AC_MSG_RESULT(yes) AC_DEFINE(HAVE_EXPORT_DYNAMIC, 1, [Define this if EXPORT_DYNAMIC is recognised]) ], [AC_MSG_RESULT(no) AC_MSG_WARN([--export-dynamic is not accepted; configuring interpreter-only]) a68g_ac_compiler=no LDFLAGS=$a68g_ac_save_LDFLAGS ], [AC_MSG_RESULT(assuming no) AC_MSG_WARN([--export-dynamic is not accepted; configuring interpreter-only]) a68g_ac_compiler=no LDFLAGS=$a68g_ac_save_LDFLAGS ] ) fi AM_CONDITIONAL([EXPORT_DYNAMIC], [test "x$a68g_ac_compiler" = "xyes"]) # # Optionally, tune for a specific processor. # if test "x$enable_arch" != "xno"; then AC_MSG_CHECKING([whether $CC accepts -march=$enable_arch]) a68g_ac_save_CFLAGS=$CFLAGS a68g_ac_march="-march=$enable_arch" CFLAGS="$a68g_ac_save_CFLAGS $a68g_ac_march" _AC_COMPILE_IFELSE([AC_LANG_PROGRAM()], [AC_MSG_RESULT(yes) AC_DEFINE_UNQUOTED(HAVE_TUNING, "$a68g_ac_march", [Define this if user wants to tune for a specific CPU]) ], [AC_MSG_RESULT(no) AC_MSG_WARN([your CPU name is not accepted; resetting to default]) CFLAGS="$a68g_ac_save_CFLAGS" ] ) fi # # Some platforms want another or no PIC option. # if test "x$enable_compiler" = "xyes"; then if test "x$enable_pic" != "xno"; then AC_MSG_CHECKING([whether $CC accepts $enable_pic]) a68g_ac_save_CFLAGS=$CFLAGS CFLAGS="$a68g_ac_save_CFLAGS $enable_pic" _AC_COMPILE_IFELSE([AC_LANG_PROGRAM()], [AC_MSG_RESULT(yes) AC_DEFINE_UNQUOTED(HAVE_PIC, "$enable_pic", [Define this as PIC option]) ], [AC_MSG_RESULT(no) AC_MSG_WARN([your PIC option is not accepted; configuring interpreter-only]) ] ) CFLAGS="$a68g_ac_save_CFLAGS" fi fi AM_PROG_CC_C_O AC_PROG_CPP AC_MSG_NOTICE([types...]) AC_C_CHAR_UNSIGNED AC_TYPE_MODE_T AC_TYPE_SIZE_T AC_TYPE_SSIZE_T AC_TYPE_UINT16_T AC_MSG_CHECKING([__off_t or off_t]) AC_COMPILE_IFELSE( [[ #include #include __off_t dummy; ]], [AC_MSG_RESULT([__off_t])], [AC_MSG_RESULT([off_t]) AC_DEFINE(__off_t, off_t, [Define this if we have no __off_t])] ) AC_MSG_CHECKING([__pid_t or pid_t]) AC_COMPILE_IFELSE( [[ #include #include __pid_t dummy; ]], [AC_MSG_RESULT([__pid_t])], [AC_MSG_RESULT([pid_t]) AC_DEFINE(__pid_t, pid_t, [Define this if we have no __pid_t])] ) AC_MSG_CHECKING([__mode_t or mode_t]) AC_COMPILE_IFELSE( [[ #include #include __mode_t dummy; ]], [AC_MSG_RESULT([__mode_t])], [AC_MSG_RESULT([mode_t]) AC_DEFINE(__mode_t, mode_t, [Define this if we have no __mode_t])] ) # # Extra include directories. # AC_MSG_NOTICE([extra include directories...]) if test -d /usr/local/pgsql/include; then AC_DEFINE(HAVE_USR_LOCAL_PGSQL_INCLUDE, 1, [Define this if /usr/local/pgsql/include was detected]) CFLAGS="$CFLAGS -I/usr/local/pgsql/include" CPPFLAGS="$CPPFLAGS -I/usr/local/pgsql/include" CXXFLAGS="$CXXFLAGS -I/usr/local/pgsql/include" LDFLAGS="$LDFLAGS -L/usr/local/pgsql/lib" fi if test -d /usr/pkg/pgsql/include; then AC_DEFINE(HAVE_USR_PKG_PGSQL_INCLUDE, 1, [Define this if /usr/pkg/pgsql/include was detected]) CFLAGS="$CFLAGS -I/usr/pkg/pgsql/include" CPPFLAGS="$CPPFLAGS -I/usr/pkg/pgsql/include" CXXFLAGS="$CXXFLAGS -I/usr/pkg/pgsql/include" LDFLAGS="$LDFLAGS -L/usr/pkg/pgsql/lib" fi if test -d /opt/local/pgsql/include; then AC_DEFINE(HAVE_OPT_LOCAL_PGSQL_INCLUDE, 1, [Define this if /opt/local/pgsql/include was detected]) CFLAGS="$CFLAGS -I/opt/local/pgsql/include" CPPFLAGS="$CPPFLAGS -I/opt/local/pgsql/include" CXXFLAGS="$CXXFLAGS -I/opt/local/pgsql/include" LDFLAGS="$LDFLAGS -L/opt/local/pgsql/lib" fi # # Checks for header files. # AC_MSG_NOTICE([standard header files...]) # # test is GSL proof. # AC_CHECK_HEADERS([math.h]) AC_CHECK_LIB([m], [cos]) AC_HEADER_STDC AC_HEADER_ASSERT AC_HEADER_DIRENT AC_HEADER_SYS_WAIT AC_HEADER_TIOCGWINSZ AC_CHECK_HEADERS([assert.h ctype.h errno.h fcntl.h float.h limits.h netdb.h netinet/in.h regex.h setjmp.h signal.h stdarg.h stddef.h stdio.h sys/ioctl.h sys/resource.h sys/socket.h sys/time.h termios.h time.h]) # # Functions we expect # AC_MSG_NOTICE([standard functions...]) AC_CHECK_FUNCS(exit) AC_CHECK_FUNCS(fprintf) AC_CHECK_FUNCS(free) AC_CHECK_FUNCS(longjmp) AC_CHECK_FUNCS(malloc) AC_CHECK_FUNCS(memcpy) AC_CHECK_FUNCS(memmove) AC_CHECK_FUNCS(memset) AC_CHECK_FUNCS(printf) AC_CHECK_FUNCS(setjmp) AC_CHECK_FUNCS(signal) AC_CHECK_FUNCS(snprintf) AC_CHECK_FUNCS(strcmp) AC_CHECK_FUNCS(strncmp) AC_CHECK_FUNCS(strncpy) AC_MSG_NOTICE([optional headers and libraries...]) if test "x$enable_curses" = "xyes"; then AC_CHECK_HEADERS([curses.h], [], [enable_curses=no], []) if test "x$enable_curses" = "xno"; then AC_CHECK_HEADERS([ncurses/curses.h], [enable_curses=yes], [], []) fi if test "x$enable_curses" = "xyes"; then AC_CHECK_LIB([ncurses], [initscr], [], [enable_curses=no]) if test "x$enable_curses" = "xyes"; then if test "x$enable_readline" = "xyes"; then AC_CHECK_HEADERS([readline/readline.h], [], [enable_readline=no], []) AC_CHECK_HEADERS([readline/history.h], [], [enable_readline=no], []) if test "x$enable_readline" = "xyes"; then AC_CHECK_LIB([readline], [readline], [], [enable_readline=no], [-lcurses]) if test "x$enable_readline" = "xyes"; then AC_DEFINE(HAVE_READLINE, 1, [Define this if readline was detected]) fi fi fi fi if test "x$enable_curses" = "xno"; then AC_CHECK_LIB([curses], [initscr], [enable_curses=yes], []) fi if test "x$enable_curses" = "xyes"; then AC_DEFINE(HAVE_CURSES, 1, [Define this if curses was detected]) fi fi fi if test "x$enable_plotutils" = "xyes"; then AC_MSG_NOTICE([GNU plotutils...]) AC_CHECK_HEADERS([plot.h], [], [enable_plotutils=no], []) A68G_AC_PLOTUTILS(pl_alabel_r) if test "x$enable_plotutils" = "xyes"; then A68G_AC_PLOTUTILS(pl_bgcolor_r) A68G_AC_PLOTUTILS(pl_bgcolorname_r) A68G_AC_PLOTUTILS(pl_color_r) A68G_AC_PLOTUTILS(pl_colorname_r) A68G_AC_PLOTUTILS(pl_erase_r) A68G_AC_PLOTUTILS(pl_fbox_r) A68G_AC_PLOTUTILS(pl_fcircle_r) A68G_AC_PLOTUTILS(pl_fillcolor_r) A68G_AC_PLOTUTILS(pl_fillcolorname_r) A68G_AC_PLOTUTILS(pl_filltype_r) A68G_AC_PLOTUTILS(pl_fline_r) A68G_AC_PLOTUTILS(pl_fmove_r) A68G_AC_PLOTUTILS(pl_fontname_r) A68G_AC_PLOTUTILS(pl_fontsize_r) A68G_AC_PLOTUTILS(pl_fpoint_r) A68G_AC_PLOTUTILS(pl_linemod_r) A68G_AC_PLOTUTILS(pl_linewidth_r) A68G_AC_PLOTUTILS(pl_newplparams) A68G_AC_PLOTUTILS(pl_openpl_r) A68G_AC_PLOTUTILS(pl_pencolor_r) A68G_AC_PLOTUTILS(pl_pencolorname_r) A68G_AC_PLOTUTILS(pl_setplparam) A68G_AC_PLOTUTILS(pl_space_r) A68G_AC_PLOTUTILS(pl_textangle_r) fi if test "x$enable_plotutils" = "xyes"; then AC_CHECK_LIB([plot], [pl_alabel_r]) AC_DEFINE(HAVE_GNU_PLOTUTILS, 1, [Define this if a good GNU plotutils installation was detected]) fi fi if test "x$enable_gsl" = "xyes"; then AC_MSG_NOTICE([GNU scientific library...]) AC_CHECK_HEADERS([gsl/gsl_blas.h gsl/gsl_complex.h gsl/gsl_complex_math.h gsl/gsl_errno.h gsl/gsl_fft_complex.h gsl/gsl_integration.h gsl/gsl_linalg.h gsl/gsl_math.h gsl/gsl_matrix.h gsl/gsl_permutation.h gsl/gsl_sf.h gsl/gsl_vector.h], [], [enable_gsl=no], []) AC_CHECK_LIB([gslcblas], [cblas_dgemm], [], [enable_gsl=no]) A68G_AC_GSL(gsl_blas_ddot) if test "x$enable_gsl" = "xyes"; then A68G_AC_GSL(gsl_blas_dgemm) A68G_AC_GSL(gsl_blas_dgemv) A68G_AC_GSL(gsl_blas_zaxpy) A68G_AC_GSL(gsl_blas_zdotc) A68G_AC_GSL(gsl_blas_zdscal) A68G_AC_GSL(gsl_blas_zgemm) A68G_AC_GSL(gsl_blas_zgemv) A68G_AC_GSL(gsl_blas_zscal) A68G_AC_GSL(gsl_complex_arccosh) A68G_AC_GSL(gsl_complex_arcsinh) A68G_AC_GSL(gsl_complex_arctanh) A68G_AC_GSL(gsl_complex_cosh) A68G_AC_GSL(gsl_complex_inverse) A68G_AC_GSL(gsl_complex_mul) A68G_AC_GSL(gsl_complex_sinh) A68G_AC_GSL(gsl_complex_tanh) A68G_AC_GSL(gsl_fft_complex_backward) A68G_AC_GSL(gsl_fft_complex_forward) A68G_AC_GSL(gsl_fft_complex_inverse) A68G_AC_GSL(gsl_fft_complex_wavetable_alloc) A68G_AC_GSL(gsl_fft_complex_wavetable_free) A68G_AC_GSL(gsl_fft_complex_workspace_alloc) A68G_AC_GSL(gsl_fft_complex_workspace_free) A68G_AC_GSL(gsl_integration_qagiu) A68G_AC_GSL(gsl_integration_workspace_alloc) A68G_AC_GSL(gsl_integration_workspace_free) A68G_AC_GSL(gsl_linalg_LU_decomp) A68G_AC_GSL(gsl_linalg_LU_det) A68G_AC_GSL(gsl_linalg_LU_invert) A68G_AC_GSL(gsl_linalg_LU_refine) A68G_AC_GSL(gsl_linalg_LU_solve) A68G_AC_GSL(gsl_linalg_QR_decomp) A68G_AC_GSL(gsl_linalg_QR_lssolve) A68G_AC_GSL(gsl_linalg_QR_solve) A68G_AC_GSL(gsl_linalg_SV_decomp) A68G_AC_GSL(gsl_linalg_SV_solve) A68G_AC_GSL(gsl_linalg_cholesky_decomp) A68G_AC_GSL(gsl_linalg_cholesky_solve) A68G_AC_GSL(gsl_linalg_complex_LU_decomp) A68G_AC_GSL(gsl_linalg_complex_LU_det) A68G_AC_GSL(gsl_linalg_complex_LU_invert) A68G_AC_GSL(gsl_linalg_complex_LU_refine) A68G_AC_GSL(gsl_linalg_complex_LU_solve) A68G_AC_GSL(gsl_matrix_add) A68G_AC_GSL(gsl_matrix_alloc) A68G_AC_GSL(gsl_matrix_complex_add) A68G_AC_GSL(gsl_matrix_complex_alloc) A68G_AC_GSL(gsl_matrix_complex_free) A68G_AC_GSL(gsl_matrix_complex_get) A68G_AC_GSL(gsl_matrix_complex_isnull) A68G_AC_GSL(gsl_matrix_complex_scale) A68G_AC_GSL(gsl_matrix_complex_set) A68G_AC_GSL(gsl_matrix_complex_set_zero) A68G_AC_GSL(gsl_matrix_complex_sub) A68G_AC_GSL(gsl_matrix_complex_transpose) A68G_AC_GSL(gsl_matrix_free) A68G_AC_GSL(gsl_matrix_get) A68G_AC_GSL(gsl_matrix_isnull) A68G_AC_GSL(gsl_matrix_scale) A68G_AC_GSL(gsl_matrix_set) A68G_AC_GSL(gsl_matrix_set_zero) A68G_AC_GSL(gsl_matrix_sub) A68G_AC_GSL(gsl_matrix_transpose) A68G_AC_GSL(gsl_permutation_alloc) A68G_AC_GSL(gsl_permutation_free) A68G_AC_GSL(gsl_permutation_get) A68G_AC_GSL(gsl_set_error_handler) A68G_AC_GSL(gsl_set_error_handler_off) A68G_AC_GSL(gsl_sf_airy_Ai_deriv_e) A68G_AC_GSL(gsl_sf_airy_Ai_e) A68G_AC_GSL(gsl_sf_airy_Bi_deriv_e) A68G_AC_GSL(gsl_sf_airy_Bi_e) A68G_AC_GSL(gsl_sf_bessel_In_e) A68G_AC_GSL(gsl_sf_bessel_In_scaled_e) A68G_AC_GSL(gsl_sf_bessel_Inu_e) A68G_AC_GSL(gsl_sf_bessel_Inu_scaled_e) A68G_AC_GSL(gsl_sf_bessel_Jn_e) A68G_AC_GSL(gsl_sf_bessel_Jnu_e) A68G_AC_GSL(gsl_sf_bessel_Kn_e) A68G_AC_GSL(gsl_sf_bessel_Kn_scaled_e) A68G_AC_GSL(gsl_sf_bessel_Knu_e) A68G_AC_GSL(gsl_sf_bessel_Knu_scaled_e) A68G_AC_GSL(gsl_sf_bessel_Yn_e) A68G_AC_GSL(gsl_sf_bessel_Ynu_e) A68G_AC_GSL(gsl_sf_bessel_il_scaled_e) A68G_AC_GSL(gsl_sf_bessel_jl_e) A68G_AC_GSL(gsl_sf_bessel_kl_scaled_e) A68G_AC_GSL(gsl_sf_bessel_yl_e) A68G_AC_GSL(gsl_sf_beta_e) A68G_AC_GSL(gsl_sf_beta_inc_e) A68G_AC_GSL(gsl_sf_ellint_Ecomp_e) A68G_AC_GSL(gsl_sf_ellint_Kcomp_e) A68G_AC_GSL(gsl_sf_ellint_RC_e) A68G_AC_GSL(gsl_sf_ellint_RD_e) A68G_AC_GSL(gsl_sf_ellint_RF_e) A68G_AC_GSL(gsl_sf_ellint_RJ_e) A68G_AC_GSL(gsl_sf_erf_e) A68G_AC_GSL(gsl_sf_erfc_e) A68G_AC_GSL(gsl_sf_fact) A68G_AC_GSL(gsl_sf_gamma_e) A68G_AC_GSL(gsl_sf_gamma_inc_P_e) A68G_AC_GSL(gsl_sf_lngamma_e) A68G_AC_GSL(gsl_strerror) A68G_AC_GSL(gsl_vector_add) A68G_AC_GSL(gsl_vector_alloc) A68G_AC_GSL(gsl_vector_complex_alloc) A68G_AC_GSL(gsl_vector_complex_free) A68G_AC_GSL(gsl_vector_complex_get) A68G_AC_GSL(gsl_vector_complex_isnull) A68G_AC_GSL(gsl_vector_complex_set) A68G_AC_GSL(gsl_vector_complex_set_zero) A68G_AC_GSL(gsl_vector_free) A68G_AC_GSL(gsl_vector_get) A68G_AC_GSL(gsl_vector_isnull) A68G_AC_GSL(gsl_vector_scale) A68G_AC_GSL(gsl_vector_set) A68G_AC_GSL(gsl_vector_set_zero) A68G_AC_GSL(gsl_vector_sub) fi if test "x$enable_gsl" = "xyes"; then AC_CHECK_LIB([gsl], [gsl_blas_ddot]) AC_DEFINE(HAVE_GNU_GSL, 1, [Define this if a good GNU GSL installation was detected]) fi fi if test "x$enable_parallel" = "xyes"; then AC_MSG_NOTICE([POSIX pthreads...]) AC_CHECK_HEADERS([pthread.h], [], [enable_parallel=no], []) A68G_AC_PTHREAD(pthread_attr_getstacksize) if test "x$enable_parallel" = "xyes"; then A68G_AC_PTHREAD(pthread_attr_init) A68G_AC_PTHREAD(pthread_attr_setstacksize) A68G_AC_PTHREAD(pthread_create) A68G_AC_PTHREAD(pthread_equal) A68G_AC_PTHREAD(pthread_exit) A68G_AC_PTHREAD(pthread_join) A68G_AC_PTHREAD(pthread_mutex_lock) A68G_AC_PTHREAD(pthread_mutex_unlock) A68G_AC_PTHREAD(pthread_self) fi if test "x$enable_parallel" = "xyes"; then AC_CHECK_LIB([pthread], pthread_attr_getstacksize) AC_DEFINE(HAVE_PARALLEL_CLAUSE, 1, [Define this if a good pthread installation was detected]) fi fi if test "x$enable_postgresql" = "xyes"; then AC_MSG_NOTICE([PostgreSQL...]) AC_CHECK_HEADERS([libpq-fe.h], [], [enable_postgresql=no], []) A68G_AC_POSTGRESQL(PQbackendPID) if test "x$enable_postgresql" = "xyes"; then A68G_AC_POSTGRESQL(PQclear) A68G_AC_POSTGRESQL(PQcmdStatus) A68G_AC_POSTGRESQL(PQcmdTuples) A68G_AC_POSTGRESQL(PQconnectdb) A68G_AC_POSTGRESQL(PQdb) A68G_AC_POSTGRESQL(PQerrorMessage) A68G_AC_POSTGRESQL(PQexec) A68G_AC_POSTGRESQL(PQfformat) A68G_AC_POSTGRESQL(PQfinish) A68G_AC_POSTGRESQL(PQfname) A68G_AC_POSTGRESQL(PQfnumber) A68G_AC_POSTGRESQL(PQgetisnull) A68G_AC_POSTGRESQL(PQgetvalue) A68G_AC_POSTGRESQL(PQhost) A68G_AC_POSTGRESQL(PQnfields) A68G_AC_POSTGRESQL(PQntuples) A68G_AC_POSTGRESQL(PQoptions) A68G_AC_POSTGRESQL(PQparameterStatus) A68G_AC_POSTGRESQL(PQpass) A68G_AC_POSTGRESQL(PQport) A68G_AC_POSTGRESQL(PQprotocolVersion) A68G_AC_POSTGRESQL(PQreset) A68G_AC_POSTGRESQL(PQresultErrorMessage) A68G_AC_POSTGRESQL(PQresultStatus) A68G_AC_POSTGRESQL(PQserverVersion) A68G_AC_POSTGRESQL(PQsocket) A68G_AC_POSTGRESQL(PQstatus) A68G_AC_POSTGRESQL(PQtty) A68G_AC_POSTGRESQL(PQuser) fi if test "x$enable_postgresql" = "xyes"; then AC_CHECK_LIB([pq], [PQbackendPID]) AC_DEFINE(HAVE_POSTGRESQL, 1, [Define this if a good PostgreSQL installation was detected]) fi fi if test "x$enable_compiler" = "xyes"; then AC_MSG_NOTICE([Dynamic loader...]) AC_CHECK_HEADERS([dlfcn.h]) A68G_AC_DL(dlopen) if test "x$enable_compiler" = "xyes"; then A68G_AC_DL(dlsym) A68G_AC_DL(dlerror) A68G_AC_DL(dlclose) fi if test "x$enable_compiler" = "xyes"; then AC_CHECK_LIB([dl], [dlopen]) AC_DEFINE(HAVE_DL, 1, [Define this if a good DL installation was detected]) fi fi # # Generate files. # AC_CONFIG_FILES([Makefile]) AC_OUTPUT AC_MSG_NOTICE([]) AC_MSG_NOTICE([AC_PACKAGE_NAME-AC_PACKAGE_VERSION by Marcel van der Veer ]) if test "x$a68g_exists" = "xyes"; then AC_MSG_NOTICE([AC_PACKAGE_NAME already exists on this system]) fi if test "x$enable_parallel" = "xyes"; then AC_MSG_NOTICE([building with parallel clause]) fi if test "x$enable_plotutils" = "xyes"; then AC_MSG_NOTICE([building with GNU plotutils]) fi if test "x$enable_gsl" = "xyes"; then AC_MSG_NOTICE([building with GNU scientific library]) fi if test "x$enable_postgresql" = "xyes"; then AC_MSG_NOTICE([building with PostgreSQL]) fi if test "x$enable_compiler" = "xyes"; then AC_MSG_NOTICE([building compiler-interpreter]) else AC_MSG_NOTICE([building interpreter-only]) fi AC_MSG_NOTICE([now type 'make' optionally followed by 'make check' or 'make install']) algol68g-2.8/compile0000755000175000001440000000717311551405127011312 00000000000000#! /bin/sh # Wrapper for compilers which do not understand `-c -o'. scriptversion=2005-05-14.22 # Copyright (C) 1999, 2000, 2003, 2004, 2005 Free Software Foundation, Inc. # Written by Tom Tromey . # # 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 2, 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, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # This file is maintained in Automake, please report # bugs to or send patches to # . case $1 in '') echo "$0: No command. Try \`$0 --help' for more information." 1>&2 exit 1; ;; -h | --h*) cat <<\EOF Usage: compile [--help] [--version] PROGRAM [ARGS] Wrapper for compilers which do not understand `-c -o'. Remove `-o dest.o' from ARGS, run PROGRAM with the remaining arguments, and rename the output as expected. If you are trying to build a whole package this is not the right script to run: please start by reading the file `INSTALL'. Report bugs to . EOF exit $? ;; -v | --v*) echo "compile $scriptversion" exit $? ;; esac ofile= cfile= eat= for arg do if test -n "$eat"; then eat= else case $1 in -o) # configure might choose to run compile as `compile cc -o foo foo.c'. # So we strip `-o arg' only if arg is an object. eat=1 case $2 in *.o | *.obj) ofile=$2 ;; *) set x "$@" -o "$2" shift ;; esac ;; *.c) cfile=$1 set x "$@" "$1" shift ;; *) set x "$@" "$1" shift ;; esac fi shift done if test -z "$ofile" || test -z "$cfile"; then # If no `-o' option was seen then we might have been invoked from a # pattern rule where we don't need one. That is ok -- this is a # normal compilation that the losing compiler can handle. If no # `.c' file was seen then we are probably linking. That is also # ok. exec "$@" fi # Name of file we expect compiler to create. cofile=`echo "$cfile" | sed -e 's|^.*/||' -e 's/\.c$/.o/'` # Create the lock directory. # Note: use `[/.-]' here to ensure that we don't use the same name # that we are using for the .o file. Also, base the name on the expected # object file name, since that is what matters with a parallel build. lockdir=`echo "$cofile" | sed -e 's|[/.-]|_|g'`.d while true; do if mkdir "$lockdir" >/dev/null 2>&1; then break fi sleep 1 done # FIXME: race condition here if user kills between mkdir and trap. trap "rmdir '$lockdir'; exit 1" 1 2 15 # Run the compile. "$@" ret=$? if test -f "$cofile"; then mv "$cofile" "$ofile" elif test -f "${cofile}bj"; then mv "${cofile}bj" "$ofile" fi rmdir "$lockdir" exit $ret # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-end: "$" # End: algol68g-2.8/source/0000777000175000001440000000000012224301437011305 500000000000000algol68g-2.8/source/postgresql.c0000644000175000001440000006051512157722130013601 00000000000000/** @file postgresql.c @author J. Marcel van der Veer. @brief Interface to libpq. @section Copyright This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2013 J. Marcel van der Veer . @section License 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 . @section Description PostgreSQL libpq interface based on initial work by Jaap Boender. Wraps "connection" and "result" objects in a FILE variable to support multiple connections. Error codes: 0 Success -1 No connection -2 No result -3 Other error **/ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #if defined HAVE_POSTGRESQL #include "a68g.h" #define LIBPQ_STRING "PostgreSQL libq" #define ERROR_NOT_CONNECTED "not connected to a database" #define ERROR_NO_QUERY_RESULT "no query result available" #define NO_PGCONN ((PGconn *) NULL) #define NO_PGRESULT ((PGresult *) NULL) /** @brief PROC pg connect db (REF FILE, STRING, REF STRING) INT @param p Node in syntax tree. **/ void genie_pq_connectdb (NODE_T * p) { A68_REF ref_string, ref_file, ref_z, conninfo; A68_FILE *file; POP_REF (p, &ref_string); CHECK_REF (p, ref_string, MODE (REF_STRING)); POP_REF (p, &conninfo); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); if (IS_IN_HEAP (&ref_file) && !IS_IN_HEAP (&ref_string)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, MODE (REF_STRING)); exit_genie (p, A68_RUNTIME_ERROR); } else if (IS_IN_FRAME (&ref_file) && IS_IN_FRAME (&ref_string)) { if (REF_SCOPE (&ref_string) > REF_SCOPE (&ref_file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, MODE (REF_STRING)); exit_genie (p, A68_RUNTIME_ERROR); } } /* Initialise the file */ file = FILE_DEREF (&ref_file); if (OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ALREADY_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } STATUS (file) = INIT_MASK; CHANNEL (file) = associate_channel; OPENED (file) = A68_TRUE; OPEN_EXCLUSIVE (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; TMP_FILE (file) = A68_FALSE; if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) { UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); } IDENTIFICATION (file) = nil_ref; TERMINATOR (file) = nil_ref; FORMAT (file) = nil_format; FD (file) = -1; if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) { UNBLOCK_GC_HANDLE (&(STRING (file))); } STRING (file) = ref_string; BLOCK_GC_HANDLE (&(STRING (file))); STRPOS (file) = 0; STREAM (&DEVICE (file)) = NULL; set_default_event_procedures (file); /* Establish a connection */ ref_z = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, conninfo)); CONNECTION (file) = PQconnectdb (a_to_c_string (p, DEREF (char, &ref_z), conninfo)); RESULT (file) = NO_PGRESULT; if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -3, INT); } (void) PQsetErrorVerbosity (CONNECTION (file), PQERRORS_DEFAULT); if (PQstatus (CONNECTION (file)) != CONNECTION_OK) { PUSH_PRIMAL (p, -1, INT); } else { PUSH_PRIMAL (p, 0, INT); } } /** @brief PROC pq finish (REF FILE) VOID @param p Node in syntax tree. **/ void genie_pq_finish (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) != NO_PGRESULT) { PQclear (RESULT (file)); } PQfinish (CONNECTION (file)); CONNECTION (file) = NO_PGCONN; RESULT (file) = NO_PGRESULT; PUSH_PRIMAL (p, 0, INT); } /** @brief PROC pq reset (REF FILE) VOID @param p Node in syntax tree. **/ void genie_pq_reset (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) != NO_PGRESULT) { PQclear (RESULT (file)); } PQreset (CONNECTION (file)); PUSH_PRIMAL (p, 0, INT); } /** @brief PROC pq exec = (REF FILE, STRING) INT @param p Node in syntax tree. **/ void genie_pq_exec (NODE_T * p) { A68_REF ref_z, query; A68_REF ref_file; A68_FILE *file; POP_REF (p, &query); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) != NO_PGRESULT) { PQclear (RESULT (file)); } ref_z = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, query)); RESULT (file) = PQexec (CONNECTION (file), a_to_c_string (p, DEREF (char, &ref_z), query)); if ((PQresultStatus (RESULT (file)) != PGRES_TUPLES_OK) && (PQresultStatus (RESULT (file)) != PGRES_COMMAND_OK)) { PUSH_PRIMAL (p, -3, INT); } else { PUSH_PRIMAL (p, 0, INT); } } /** @brief PROC pq parameterstatus (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_parameterstatus (NODE_T * p) { A68_REF ref_z, parameter; A68_REF ref_file; A68_FILE *file; POP_REF (p, ¶meter); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } ref_z = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, parameter)); if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, (char *) PQparameterStatus (CONNECTION (file), a_to_c_string (p, DEREF (char, &ref_z), parameter)), DEFAULT_WIDTH); PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq cmdstatus (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_cmdstatus (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQcmdStatus (RESULT (file)), DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq cmdtuples (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_cmdtuples (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQcmdTuples (RESULT (file)), DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq ntuples (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_ntuples (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } PUSH_PRIMAL (p, (PQresultStatus (RESULT (file))) == PGRES_TUPLES_OK ? PQntuples (RESULT (file)) : -3, INT); } /** @brief PROC pq nfields (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_nfields (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } PUSH_PRIMAL (p, (PQresultStatus (RESULT (file))) == PGRES_TUPLES_OK ? PQnfields (RESULT (file)) : -3, INT); } /** @brief PROC pq fname (REF FILE, INT) INT @param p Node in syntax tree. **/ void genie_pq_fname (NODE_T * p) { A68_INT a68g_index; int upb; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &a68g_index, A68_INT); CHECK_INIT (p, INITIALISED (&a68g_index), MODE (INT)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQnfields (RESULT (file)) : 0); if (VALUE (&a68g_index) < 1 || VALUE (&a68g_index) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQfname (RESULT (file), VALUE (&a68g_index) - 1), DEFAULT_WIDTH); STRPOS (file) = 0; } PUSH_PRIMAL (p, 0, INT); } /** @brief PROC pq fnumber = (REF FILE, STRING) INT @param p Node in syntax tree. **/ void genie_pq_fnumber (NODE_T * p) { A68_REF ref_z, name; A68_REF ref_file; A68_FILE *file; int k; POP_REF (p, &name); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } ref_z = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, name)); k = PQfnumber (RESULT (file), a_to_c_string (p, DEREF (char, &ref_z), name)); if (k == -1) { PUSH_PRIMAL (p, -3, INT); } else { PUSH_PRIMAL (p, k + 1, INT); } } /** @brief PROC pq fformat (REF FILE, INT) INT @param p Node in syntax tree. **/ void genie_pq_fformat (NODE_T * p) { A68_INT a68g_index; int upb; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &a68g_index, A68_INT); CHECK_INIT (p, INITIALISED (&a68g_index), MODE (INT)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQnfields (RESULT (file)) : 0); if (VALUE (&a68g_index) < 1 || VALUE (&a68g_index) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMAL (p, PQfformat (RESULT (file), VALUE (&a68g_index) - 1), INT); } /** @brief PROC pq getvalue (REF FILE, INT, INT) INT @param p Node in syntax tree. **/ void genie_pq_getvalue (NODE_T * p) { A68_INT row, column; char *str; int upb; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &column, A68_INT); CHECK_INIT (p, INITIALISED (&column), MODE (INT)); POP_OBJECT (p, &row, A68_INT); CHECK_INIT (p, INITIALISED (&row), MODE (INT)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQnfields (RESULT (file)) : 0); if (VALUE (&column) < 1 || VALUE (&column) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQntuples (RESULT (file)) : 0); if (VALUE (&row) < 1 || VALUE (&row) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } str = PQgetvalue (RESULT (file), VALUE (&row) - 1, VALUE (&column) - 1); if (str == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_NO_QUERY_RESULT); exit_genie (p, A68_RUNTIME_ERROR); } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, str, DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq getisnull (REF FILE, INT, INT) INT @param p Node in syntax tree. **/ void genie_pq_getisnull (NODE_T * p) { A68_INT row, column; int upb; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &column, A68_INT); CHECK_INIT (p, INITIALISED (&column), MODE (INT)); POP_OBJECT (p, &row, A68_INT); CHECK_INIT (p, INITIALISED (&row), MODE (INT)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQnfields (RESULT (file)) : 0); if (VALUE (&column) < 1 || VALUE (&column) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } upb = (PQresultStatus (RESULT (file)) == PGRES_TUPLES_OK ? PQntuples (RESULT (file)) : 0); if (VALUE (&row) < 1 || VALUE (&row) > upb) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMAL (p, PQgetisnull (RESULT (file), VALUE (&row) - 1, VALUE (&column) - 1), INT); } /** @brief Edit error message sting from libpq. @param p Node in syntax tree. **/ static char *pq_edit (char *str) { if (str == NULL) { return (""); } else { static char edt[BUFFER_SIZE]; char *q; int newlines = 0, len = (int) strlen (str); BOOL_T suppress_blank = A68_FALSE; q = edt; while (len > 0 && str[len - 1] == NEWLINE_CHAR) { str[len - 1] = NULL_CHAR; len = (int) strlen (str); } while (str[0] != NULL_CHAR) { if (str[0] == CR_CHAR) { str++; } else if (str[0] == NEWLINE_CHAR) { if (newlines++ == 0) { *(q++) = POINT_CHAR; *(q++) = BLANK_CHAR; *(q++) = '('; } else { *(q++) = BLANK_CHAR; } suppress_blank = A68_TRUE; str++; } else if (IS_SPACE (str[0])) { if (suppress_blank) { str++; } else { if (str[1] != NEWLINE_CHAR) { *(q++) = BLANK_CHAR; } str++; suppress_blank = A68_TRUE; } } else { *(q++) = *(str++); suppress_blank = A68_FALSE; } } if (newlines > 0) { *(q++) = ')'; } q[0] = NULL_CHAR; return (edt); } } /** @brief PROC pq errormessage (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_errormessage (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { char str[BUFFER_SIZE]; int upb; if (PQerrorMessage (CONNECTION (file)) != NULL) { bufcpy (str, pq_edit (PQerrorMessage (CONNECTION (file))), BUFFER_SIZE); upb = (int) strlen (str); if (upb > 0 && str[upb - 1] == NEWLINE_CHAR) { str[upb - 1] = NULL_CHAR; } } else { bufcpy (str, "no error message available", BUFFER_SIZE); } * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, str, DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq resulterrormessage (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_resulterrormessage (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (RESULT (file) == NO_PGRESULT) { PUSH_PRIMAL (p, -2, INT); return; } if (!IS_NIL (STRING (file))) { char str[BUFFER_SIZE]; int upb; if (PQresultErrorMessage (RESULT (file)) != NULL) { bufcpy (str, pq_edit (PQresultErrorMessage (RESULT (file))), BUFFER_SIZE); upb = (int) strlen (str); if (upb > 0 && str[upb - 1] == NEWLINE_CHAR) { str[upb - 1] = NULL_CHAR; } } else { bufcpy (str, "no error message available", BUFFER_SIZE); } * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, str, DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq db (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_db (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQdb (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq user (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_user (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQuser (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq pass (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_pass (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQpass (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq host (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_host (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQhost (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq port (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_port (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQport (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq tty (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_tty (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQtty (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq options (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_options (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { * DEREF (A68_REF, &STRING (file)) = c_to_a_string (p, PQoptions (CONNECTION (file)), DEFAULT_WIDTH); STRPOS (file) = 0; PUSH_PRIMAL (p, 0, INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq protocol version (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_protocolversion (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { PUSH_PRIMAL (p, PQprotocolVersion (CONNECTION (file)), INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq server version (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_serverversion (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { PUSH_PRIMAL (p, PQserverVersion (CONNECTION (file)), INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq socket (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_socket (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { PUSH_PRIMAL (p, PQsocket (CONNECTION (file)), INT); } else { PUSH_PRIMAL (p, -3, INT); } } /** @brief PROC pq backend pid (REF FILE) INT @param p Node in syntax tree. **/ void genie_pq_backendpid (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (CONNECTION (file) == NO_PGCONN) { PUSH_PRIMAL (p, -1, INT); return; } if (!IS_NIL (STRING (file))) { PUSH_PRIMAL (p, PQbackendPID (CONNECTION (file)), INT); } else { PUSH_PRIMAL (p, -3, INT); } } #endif /* HAVE_POSTGRESQL */ algol68g-2.8/source/a68g-config.h.in0000644000175000001440000002307712224300717014020 00000000000000/* source/a68g-config.h.in. Generated from configure.ac by autoheader. */ /* Define to 1 if `TIOCGWINSZ' requires . */ #undef GWINSZ_IN_SYS_IOCTL /* Define to 1 if you have the header file. */ #undef HAVE_ASSERT_H /* Define to 1 if you have the header file. */ #undef HAVE_CTYPE_H /* Define this if curses was detected */ #undef HAVE_CURSES /* Define to 1 if you have the header file. */ #undef HAVE_CURSES_H /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_DIRENT_H /* Define this if a good DL installation was detected */ #undef HAVE_DL /* Define to 1 if you have the header file. */ #undef HAVE_DLFCN_H /* Define to 1 if you have the header file. */ #undef HAVE_ERRNO_H /* Define to 1 if you have the `exit' function. */ #undef HAVE_EXIT /* Define this if EXPORT_DYNAMIC is recognised */ #undef HAVE_EXPORT_DYNAMIC /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H /* Define to 1 if you have the header file. */ #undef HAVE_FLOAT_H /* Define to 1 if you have the `fprintf' function. */ #undef HAVE_FPRINTF /* Define to 1 if you have the `free' function. */ #undef HAVE_FREE /* Define this if FreeBSD was detected */ #undef HAVE_FREEBSD /* Define this if GCC was detected */ #undef HAVE_GCC /* Define this if a good GNU GSL installation was detected */ #undef HAVE_GNU_GSL /* Define this if a good GNU plotutils installation was detected */ #undef HAVE_GNU_PLOTUTILS /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_BLAS_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_COMPLEX_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_COMPLEX_MATH_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_ERRNO_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_FFT_COMPLEX_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_INTEGRATION_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_LINALG_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_MATH_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_MATRIX_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_PERMUTATION_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_SF_H /* Define to 1 if you have the header file. */ #undef HAVE_GSL_GSL_VECTOR_H /* Define this if IEEE_754 compliant */ #undef HAVE_IEEE_754 /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H /* Define to 1 if you have the `dl' library (-ldl). */ #undef HAVE_LIBDL /* Define to 1 if you have the `gsl' library (-lgsl). */ #undef HAVE_LIBGSL /* Define to 1 if you have the `gslcblas' library (-lgslcblas). */ #undef HAVE_LIBGSLCBLAS /* Define to 1 if you have the `m' library (-lm). */ #undef HAVE_LIBM /* Define to 1 if you have the `ncurses' library (-lncurses). */ #undef HAVE_LIBNCURSES /* Define to 1 if you have the `plot' library (-lplot). */ #undef HAVE_LIBPLOT /* Define to 1 if you have the `pq' library (-lpq). */ #undef HAVE_LIBPQ /* Define to 1 if you have the header file. */ #undef HAVE_LIBPQ_FE_H /* Define to 1 if you have the `pthread' library (-lpthread). */ #undef HAVE_LIBPTHREAD /* Define to 1 if you have the `readline' library (-lreadline). */ #undef HAVE_LIBREADLINE /* Define to 1 if you have the header file. */ #undef HAVE_LIMITS_H /* Define this if LINUX was detected */ #undef HAVE_LINUX /* Define to 1 if you have the `longjmp' function. */ #undef HAVE_LONGJMP /* Define this if DARWIN was detected */ #undef HAVE_MAC_OS_X /* Define to 1 if you have the `malloc' function. */ #undef HAVE_MALLOC /* Define to 1 if you have the header file. */ #undef HAVE_MATH_H /* Define to 1 if you have the `memcpy' function. */ #undef HAVE_MEMCPY /* Define to 1 if you have the `memmove' function. */ #undef HAVE_MEMMOVE /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H /* Define to 1 if you have the `memset' function. */ #undef HAVE_MEMSET /* Define to 1 if you have the header file. */ #undef HAVE_NCURSES_CURSES_H /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_NDIR_H /* Define this if NetBSD was detected */ #undef HAVE_NETBSD /* Define to 1 if you have the header file. */ #undef HAVE_NETDB_H /* Define to 1 if you have the header file. */ #undef HAVE_NETINET_IN_H /* Define this if OpenBSD was detected */ #undef HAVE_OPENBSD /* Define this if /opt/local/pgsql/include was detected */ #undef HAVE_OPT_LOCAL_PGSQL_INCLUDE /* Define this if a good pthread installation was detected */ #undef HAVE_PARALLEL_CLAUSE /* Define this as PIC option */ #undef HAVE_PIC /* Define to 1 if you have the header file. */ #undef HAVE_PLOT_H /* Define this if a good PostgreSQL installation was detected */ #undef HAVE_POSTGRESQL /* Define to 1 if you have the `printf' function. */ #undef HAVE_PRINTF /* Define to 1 if you have the header file. */ #undef HAVE_PTHREAD_H /* Define this if readline was detected */ #undef HAVE_READLINE /* Define to 1 if you have the header file. */ #undef HAVE_READLINE_HISTORY_H /* Define to 1 if you have the header file. */ #undef HAVE_READLINE_READLINE_H /* Define to 1 if you have the header file. */ #undef HAVE_REGEX_H /* Define to 1 if you have the `setjmp' function. */ #undef HAVE_SETJMP /* Define to 1 if you have the header file. */ #undef HAVE_SETJMP_H /* Define to 1 if you have the `signal' function. */ #undef HAVE_SIGNAL /* Define to 1 if you have the header file. */ #undef HAVE_SIGNAL_H /* Define to 1 if you have the `snprintf' function. */ #undef HAVE_SNPRINTF /* Define to 1 if you have the header file. */ #undef HAVE_STDARG_H /* Define to 1 if you have the header file. */ #undef HAVE_STDDEF_H /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the header file. */ #undef HAVE_STDIO_H /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the `strcmp' function. */ #undef HAVE_STRCMP /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H /* Define to 1 if you have the `strncmp' function. */ #undef HAVE_STRNCMP /* Define to 1 if you have the `strncpy' function. */ #undef HAVE_STRNCPY /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_SYS_DIR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_IOCTL_H /* Define to 1 if you have the header file, and it defines `DIR'. */ #undef HAVE_SYS_NDIR_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_RESOURCE_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_SOCKET_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_STAT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TYPES_H /* Define to 1 if you have that is POSIX.1 compatible. */ #undef HAVE_SYS_WAIT_H /* Define to 1 if you have the header file. */ #undef HAVE_TERMIOS_H /* Define to 1 if you have the header file. */ #undef HAVE_TIME_H /* Define this if user wants to tune for a specific CPU */ #undef HAVE_TUNING /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H /* Define this if untested OS was detected */ #undef HAVE_UNTESTED /* Define this if /usr/local/pgsql/include was detected */ #undef HAVE_USR_LOCAL_PGSQL_INCLUDE /* Define this if /usr/pkg/pgsql/include was detected */ #undef HAVE_USR_PKG_PGSQL_INCLUDE /* Define to 1 if assertions should be disabled. */ #undef NDEBUG /* Define to 1 if your C compiler doesn't accept -c and -o together. */ #undef NO_MINUS_C_MINUS_O /* Name of package */ #undef PACKAGE /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS /* Version number of package */ #undef VERSION /* Define to 1 if type `char' is unsigned and you are not using gcc. */ #ifndef __CHAR_UNSIGNED__ # undef __CHAR_UNSIGNED__ #endif /* Define this if we have no __mode_t */ #undef __mode_t /* Define this if we have no __off_t */ #undef __off_t /* Define this if we have no __pid_t */ #undef __pid_t /* Define to `int' if does not define. */ #undef mode_t /* Define to `unsigned int' if does not define. */ #undef size_t /* Define to `int' if does not define. */ #undef ssize_t /* Define to the type of an unsigned integer type of width exactly 16 bits if such a type exists and the standard includes do not define it. */ #undef uint16_t algol68g-2.8/source/plotutils.c0000644000175000001440000015554312113475733013451 00000000000000/** @file plotutils.c @author J. Marcel van der Veer. @brief Interface to libplot. @section Copyright This file is part of Algol68G - an Algol 68 compiler-interpreter. Copyright (C) 2001-2013 J. Marcel van der Veer . @section License 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 . @section Description This file contains the Algol68G interface to libplot. Note that Algol68G is not a binding for libplot. When GNU plotutils are not installed then the routines in this file will give a runtime error when called. You can also choose to not define them in "prelude.c". **/ #include "a68g.h" #if defined HAVE_GNU_PLOTUTILS #define MAXIMUM(x, y) ((x) > (y) ? (x) : (y)) /* This part contains names for 24-bit colours recognised by libplot. The table below is based on the "rgb.txt" file distributed with X11R6. */ struct COLOUR_INFO { char *name; int red, green, blue; }; typedef struct COLOUR_INFO colour_info; #define COLOUR_MAX 65535 #define COLOUR_NAMES 668 const colour_info A68_COLOURS[COLOUR_NAMES + 1] = { {"aliceblue", 0xf0, 0xf8, 0xff}, {"aluminium", 0xaa, 0xac, 0xb7}, {"aluminum", 0xaa, 0xac, 0xb7}, {"antiquewhite", 0xfa, 0xeb, 0xd7}, {"antiquewhite1", 0xff, 0xef, 0xdb}, {"antiquewhite2", 0xee, 0xdf, 0xcc}, {"antiquewhite3", 0xcd, 0xc0, 0xb0}, {"antiquewhite4", 0x8b, 0x83, 0x78}, {"aquamarine", 0x7f, 0xff, 0xd4}, {"aquamarine1", 0x7f, 0xff, 0xd4}, {"aquamarine2", 0x76, 0xee, 0xc6}, {"aquamarine3", 0x66, 0xcd, 0xaa}, {"aquamarine4", 0x45, 0x8b, 0x74}, {"azure", 0xf0, 0xff, 0xff}, {"azure1", 0xf0, 0xff, 0xff}, {"azure2", 0xe0, 0xee, 0xee}, {"azure3", 0xc1, 0xcd, 0xcd}, {"azure4", 0x83, 0x8b, 0x8b}, {"beige", 0xf5, 0xf5, 0xdc}, {"bisque", 0xff, 0xe4, 0xc4}, {"bisque1", 0xff, 0xe4, 0xc4}, {"bisque2", 0xee, 0xd5, 0xb7}, {"bisque3", 0xcd, 0xb7, 0x9e}, {"bisque4", 0x8b, 0x7d, 0x6b}, {"black", 0x00, 0x00, 0x00}, {"blanchedalmond", 0xff, 0xeb, 0xcd}, {"blue", 0x00, 0x00, 0xff}, {"blue1", 0x00, 0x00, 0xff}, {"blue2", 0x00, 0x00, 0xee}, {"blue3", 0x00, 0x00, 0xcd}, {"blue4", 0x00, 0x00, 0x8b}, {"blueviolet", 0x8a, 0x2b, 0xe2}, {"bondi1", 0x02, 0x48, 0x8f}, {"brown", 0xa5, 0x2a, 0x2a}, {"brown1", 0xff, 0x40, 0x40}, {"brown2", 0xee, 0x3b, 0x3b}, {"brown3", 0xcd, 0x33, 0x33}, {"brown4", 0x8b, 0x23, 0x23}, {"burlywood", 0xde, 0xb8, 0x87}, {"burlywood1", 0xff, 0xd3, 0x9b}, {"burlywood2", 0xee, 0xc5, 0x91}, {"burlywood3", 0xcd, 0xaa, 0x7d}, {"burlywood4", 0x8b, 0x73, 0x55}, {"cadetblue", 0x5f, 0x9e, 0xa0}, {"cadetblue1", 0x98, 0xf5, 0xff}, {"cadetblue2", 0x8e, 0xe5, 0xee}, {"cadetblue3", 0x7a, 0xc5, 0xcd}, {"cadetblue4", 0x53, 0x86, 0x8b}, {"chartreuse", 0x7f, 0xff, 0x00}, {"chartreuse1", 0x7f, 0xff, 0x00}, {"chartreuse2", 0x76, 0xee, 0x00}, {"chartreuse3", 0x66, 0xcd, 0x00}, {"chartreuse4", 0x45, 0x8b, 0x00}, {"chocolate", 0xd2, 0x69, 0x1e}, {"chocolate1", 0xff, 0x7f, 0x24}, {"chocolate2", 0xee, 0x76, 0x21}, {"chocolate3", 0xcd, 0x66, 0x1d}, {"chocolate4", 0x8b, 0x45, 0x13}, {"coral", 0xff, 0x7f, 0x50}, {"coral1", 0xff, 0x72, 0x56}, {"coral2", 0xee, 0x6a, 0x50}, {"coral3", 0xcd, 0x5b, 0x45}, {"coral4", 0x8b, 0x3e, 0x2f}, {"cornflowerblue", 0x64, 0x95, 0xed}, {"cornsilk", 0xff, 0xf8, 0xdc}, {"cornsilk1", 0xff, 0xf8, 0xdc}, {"cornsilk2", 0xee, 0xe8, 0xcd}, {"cornsilk3", 0xcd, 0xc8, 0xb1}, {"cornsilk4", 0x8b, 0x88, 0x78}, {"cyan", 0x00, 0xff, 0xff}, {"cyan1", 0x00, 0xff, 0xff}, {"cyan2", 0x00, 0xee, 0xee}, {"cyan3", 0x00, 0xcd, 0xcd}, {"cyan4", 0x00, 0x8b, 0x8b}, {"darkblue", 0x00, 0x00, 0x8b}, {"darkcyan", 0x00, 0x8b, 0x8b}, {"darkgoldenrod", 0xb8, 0x86, 0x0b}, {"darkgoldenrod1", 0xff, 0xb9, 0x0f}, {"darkgoldenrod2", 0xee, 0xad, 0x0e}, {"darkgoldenrod3", 0xcd, 0x95, 0x0c}, {"darkgoldenrod4", 0x8b, 0x65, 0x08}, {"darkgray", 0xa9, 0xa9, 0xa9}, {"darkgreen", 0x00, 0x64, 0x00}, {"darkgrey", 0xa9, 0xa9, 0xa9}, {"darkkhaki", 0xbd, 0xb7, 0x6b}, {"darkmagenta", 0x8b, 0x00, 0x8b}, {"darkolivegreen", 0x55, 0x6b, 0x2f}, {"darkolivegreen1", 0xca, 0xff, 0x70}, {"darkolivegreen2", 0xbc, 0xee, 0x68}, {"darkolivegreen3", 0xa2, 0xcd, 0x5a}, {"darkolivegreen4", 0x6e, 0x8b, 0x3d}, {"darkorange", 0xff, 0x8c, 0x00}, {"darkorange1", 0xff, 0x7f, 0x00}, {"darkorange2", 0xee, 0x76, 0x00}, {"darkorange3", 0xcd, 0x66, 0x00}, {"darkorange4", 0x8b, 0x45, 0x00}, {"darkorchid", 0x99, 0x32, 0xcc}, {"darkorchid1", 0xbf, 0x3e, 0xff}, {"darkorchid2", 0xb2, 0x3a, 0xee}, {"darkorchid3", 0x9a, 0x32, 0xcd}, {"darkorchid4", 0x68, 0x22, 0x8b}, {"darkred", 0x8b, 0x00, 0x00}, {"darksalmon", 0xe9, 0x96, 0x7a}, {"darkseagreen", 0x8f, 0xbc, 0x8f}, {"darkseagreen1", 0xc1, 0xff, 0xc1}, {"darkseagreen2", 0xb4, 0xee, 0xb4}, {"darkseagreen3", 0x9b, 0xcd, 0x9b}, {"darkseagreen4", 0x69, 0x8b, 0x69}, {"darkslateblue", 0x48, 0x3d, 0x8b}, {"darkslategray", 0x2f, 0x4f, 0x4f}, {"darkslategray1", 0x97, 0xff, 0xff}, {"darkslategray2", 0x8d, 0xee, 0xee}, {"darkslategray3", 0x79, 0xcd, 0xcd}, {"darkslategray4", 0x52, 0x8b, 0x8b}, {"darkslategrey", 0x2f, 0x4f, 0x4f}, {"darkslategrey1", 0x97, 0xff, 0xff}, {"darkslategrey2", 0x8d, 0xee, 0xee}, {"darkslategrey3", 0x79, 0xcd, 0xcd}, {"darkslategrey4", 0x52, 0x8b, 0x8b}, {"darkturquoise", 0x00, 0xce, 0xd1}, {"darkviolet", 0x94, 0x00, 0xd3}, {"deeppink", 0xff, 0x14, 0x93}, {"deeppink1", 0xff, 0x14, 0x93}, {"deeppink2", 0xee, 0x12, 0x89}, {"deeppink3", 0xcd, 0x10, 0x76}, {"deeppink4", 0x8b, 0x0a, 0x50}, {"deepskyblue", 0x00, 0xbf, 0xff}, {"deepskyblue1", 0x00, 0xbf, 0xff}, {"deepskyblue2", 0x00, 0xb2, 0xee}, {"deepskyblue3", 0x00, 0x9a, 0xcd}, {"deepskyblue4", 0x00, 0x68, 0x8b}, {"dimgray", 0x69, 0x69, 0x69}, {"dimgrey", 0x69, 0x69, 0x69}, {"dodgerblue", 0x1e, 0x90, 0xff}, {"dodgerblue1", 0x1e, 0x90, 0xff}, {"dodgerblue2", 0x1c, 0x86, 0xee}, {"dodgerblue3", 0x18, 0x74, 0xcd}, {"dodgerblue4", 0x10, 0x4e, 0x8b}, {"firebrick", 0xb2, 0x22, 0x22}, {"firebrick1", 0xff, 0x30, 0x30}, {"firebrick2", 0xee, 0x2c, 0x2c}, {"firebrick3", 0xcd, 0x26, 0x26}, {"firebrick4", 0x8b, 0x1a, 0x1a}, {"floralwhite", 0xff, 0xfa, 0xf0}, {"forestgreen", 0x22, 0x8b, 0x22}, {"gainsboro", 0xdc, 0xdc, 0xdc}, {"ghostwhite", 0xf8, 0xf8, 0xff}, {"gold", 0xff, 0xd7, 0x00}, {"gold1", 0xff, 0xd7, 0x00}, {"gold2", 0xee, 0xc9, 0x00}, {"gold3", 0xcd, 0xad, 0x00}, {"gold4", 0x8b, 0x75, 0x00}, {"goldenrod", 0xda, 0xa5, 0x20}, {"goldenrod1", 0xff, 0xc1, 0x25}, {"goldenrod2", 0xee, 0xb4, 0x22}, {"goldenrod3", 0xcd, 0x9b, 0x1d}, {"goldenrod4", 0x8b, 0x69, 0x14}, {"gray", 0xbe, 0xbe, 0xbe}, {"gray0", 0x00, 0x00, 0x00}, {"gray1", 0x03, 0x03, 0x03}, {"gray2", 0x05, 0x05, 0x05}, {"gray3", 0x08, 0x08, 0x08}, {"gray4", 0x0a, 0x0a, 0x0a}, {"gray5", 0x0d, 0x0d, 0x0d}, {"gray6", 0x0f, 0x0f, 0x0f}, {"gray7", 0x12, 0x12, 0x12}, {"gray8", 0x14, 0x14, 0x14}, {"gray9", 0x17, 0x17, 0x17}, {"gray10", 0x1a, 0x1a, 0x1a}, {"gray11", 0x1c, 0x1c, 0x1c}, {"gray12", 0x1f, 0x1f, 0x1f}, {"gray13", 0x21, 0x21, 0x21}, {"gray14", 0x24, 0x24, 0x24}, {"gray15", 0x26, 0x26, 0x26}, {"gray16", 0x29, 0x29, 0x29}, {"gray17", 0x2b, 0x2b, 0x2b}, {"gray18", 0x2e, 0x2e, 0x2e}, {"gray19", 0x30, 0x30, 0x30}, {"gray20", 0x33, 0x33, 0x33}, {"gray21", 0x36, 0x36, 0x36}, {"gray22", 0x38, 0x38, 0x38}, {"gray23", 0x3b, 0x3b, 0x3b}, {"gray24", 0x3d, 0x3d, 0x3d}, {"gray25", 0x40, 0x40, 0x40}, {"gray26", 0x42, 0x42, 0x42}, {"gray27", 0x45, 0x45, 0x45}, {"gray28", 0x47, 0x47, 0x47}, {"gray29", 0x4a, 0x4a, 0x4a}, {"gray30", 0x4d, 0x4d, 0x4d}, {"gray31", 0x4f, 0x4f, 0x4f}, {"gray32", 0x52, 0x52, 0x52}, {"gray33", 0x54, 0x54, 0x54}, {"gray34", 0x57, 0x57, 0x57}, {"gray35", 0x59, 0x59, 0x59}, {"gray36", 0x5c, 0x5c, 0x5c}, {"gray37", 0x5e, 0x5e, 0x5e}, {"gray38", 0x61, 0x61, 0x61}, {"gray39", 0x63, 0x63, 0x63}, {"gray40", 0x66, 0x66, 0x66}, {"gray41", 0x69, 0x69, 0x69}, {"gray42", 0x6b, 0x6b, 0x6b}, {"gray43", 0x6e, 0x6e, 0x6e}, {"gray44", 0x70, 0x70, 0x70}, {"gray45", 0x73, 0x73, 0x73}, {"gray46", 0x75, 0x75, 0x75}, {"gray47", 0x78, 0x78, 0x78}, {"gray48", 0x7a, 0x7a, 0x7a}, {"gray49", 0x7d, 0x7d, 0x7d}, {"gray50", 0x7f, 0x7f, 0x7f}, {"gray51", 0x82, 0x82, 0x82}, {"gray52", 0x85, 0x85, 0x85}, {"gray53", 0x87, 0x87, 0x87}, {"gray54", 0x8a, 0x8a, 0x8a}, {"gray55", 0x8c, 0x8c, 0x8c}, {"gray56", 0x8f, 0x8f, 0x8f}, {"gray57", 0x91, 0x91, 0x91}, {"gray58", 0x94, 0x94, 0x94}, {"gray59", 0x96, 0x96, 0x96}, {"gray60", 0x99, 0x99, 0x99}, {"gray61", 0x9c, 0x9c, 0x9c}, {"gray62", 0x9e, 0x9e, 0x9e}, {"gray63", 0xa1, 0xa1, 0xa1}, {"gray64", 0xa3, 0xa3, 0xa3}, {"gray65", 0xa6, 0xa6, 0xa6}, {"gray66", 0xa8, 0xa8, 0xa8}, {"gray67", 0xab, 0xab, 0xab}, {"gray68", 0xad, 0xad, 0xad}, {"gray69", 0xb0, 0xb0, 0xb0}, {"gray70", 0xb3, 0xb3, 0xb3}, {"gray71", 0xb5, 0xb5, 0xb5}, {"gray72", 0xb8, 0xb8, 0xb8}, {"gray73", 0xba, 0xba, 0xba}, {"gray74", 0xbd, 0xbd, 0xbd}, {"gray75", 0xbf, 0xbf, 0xbf}, {"gray76", 0xc2, 0xc2, 0xc2}, {"gray77", 0xc4, 0xc4, 0xc4}, {"gray78", 0xc7, 0xc7, 0xc7}, {"gray79", 0xc9, 0xc9, 0xc9}, {"gray80", 0xcc, 0xcc, 0xcc}, {"gray81", 0xcf, 0xcf, 0xcf}, {"gray82", 0xd1, 0xd1, 0xd1}, {"gray83", 0xd4, 0xd4, 0xd4}, {"gray84", 0xd6, 0xd6, 0xd6}, {"gray85", 0xd9, 0xd9, 0xd9}, {"gray86", 0xdb, 0xdb, 0xdb}, {"gray87", 0xde, 0xde, 0xde}, {"gray88", 0xe0, 0xe0, 0xe0}, {"gray89", 0xe3, 0xe3, 0xe3}, {"gray90", 0xe5, 0xe5, 0xe5}, {"gray91", 0xe8, 0xe8, 0xe8}, {"gray92", 0xeb, 0xeb, 0xeb}, {"gray93", 0xed, 0xed, 0xed}, {"gray94", 0xf0, 0xf0, 0xf0}, {"gray95", 0xf2, 0xf2, 0xf2}, {"gray96", 0xf5, 0xf5, 0xf5}, {"gray97", 0xf7, 0xf7, 0xf7}, {"gray98", 0xfa, 0xfa, 0xfa}, {"gray99", 0xfc, 0xfc, 0xfc}, {"gray100", 0xff, 0xff, 0xff}, {"green", 0x00, 0xff, 0x00}, {"green1", 0x00, 0xff, 0x00}, {"green2", 0x00, 0xee, 0x00}, {"green3", 0x00, 0xcd, 0x00}, {"green4", 0x00, 0x8b, 0x00}, {"greenyellow", 0xad, 0xff, 0x2f}, {"grey", 0xbe, 0xbe, 0xbe}, {"grey0", 0x00, 0x00, 0x00}, {"grey1", 0x03, 0x03, 0x03}, {"grey2", 0x05, 0x05, 0x05}, {"grey3", 0x08, 0x08, 0x08}, {"grey4", 0x0a, 0x0a, 0x0a}, {"grey5", 0x0d, 0x0d, 0x0d}, {"grey6", 0x0f, 0x0f, 0x0f}, {"grey7", 0x12, 0x12, 0x12}, {"grey8", 0x14, 0x14, 0x14}, {"grey9", 0x17, 0x17, 0x17}, {"grey10", 0x1a, 0x1a, 0x1a}, {"grey11", 0x1c, 0x1c, 0x1c}, {"grey12", 0x1f, 0x1f, 0x1f}, {"grey13", 0x21, 0x21, 0x21}, {"grey14", 0x24, 0x24, 0x24}, {"grey15", 0x26, 0x26, 0x26}, {"grey16", 0x29, 0x29, 0x29}, {"grey17", 0x2b, 0x2b, 0x2b}, {"grey18", 0x2e, 0x2e, 0x2e}, {"grey19", 0x30, 0x30, 0x30}, {"grey20", 0x33, 0x33, 0x33}, {"grey21", 0x36, 0x36, 0x36}, {"grey22", 0x38, 0x38, 0x38}, {"grey23", 0x3b, 0x3b, 0x3b}, {"grey24", 0x3d, 0x3d, 0x3d}, {"grey25", 0x40, 0x40, 0x40}, {"grey26", 0x42, 0x42, 0x42}, {"grey27", 0x45, 0x45, 0x45}, {"grey28", 0x47, 0x47, 0x47}, {"grey29", 0x4a, 0x4a, 0x4a}, {"grey30", 0x4d, 0x4d, 0x4d}, {"grey31", 0x4f, 0x4f, 0x4f}, {"grey32", 0x52, 0x52, 0x52}, {"grey33", 0x54, 0x54, 0x54}, {"grey34", 0x57, 0x57, 0x57}, {"grey35", 0x59, 0x59, 0x59}, {"grey36", 0x5c, 0x5c, 0x5c}, {"grey37", 0x5e, 0x5e, 0x5e}, {"grey38", 0x61, 0x61, 0x61}, {"grey39", 0x63, 0x63, 0x63}, {"grey40", 0x66, 0x66, 0x66}, {"grey41", 0x69, 0x69, 0x69}, {"grey42", 0x6b, 0x6b, 0x6b}, {"grey43", 0x6e, 0x6e, 0x6e}, {"grey44", 0x70, 0x70, 0x70}, {"grey45", 0x73, 0x73, 0x73}, {"grey46", 0x75, 0x75, 0x75}, {"grey47", 0x78, 0x78, 0x78}, {"grey48", 0x7a, 0x7a, 0x7a}, {"grey49", 0x7d, 0x7d, 0x7d}, {"grey50", 0x7f, 0x7f, 0x7f}, {"grey51", 0x82, 0x82, 0x82}, {"grey52", 0x85, 0x85, 0x85}, {"grey53", 0x87, 0x87, 0x87}, {"grey54", 0x8a, 0x8a, 0x8a}, {"grey55", 0x8c, 0x8c, 0x8c}, {"grey56", 0x8f, 0x8f, 0x8f}, {"grey57", 0x91, 0x91, 0x91}, {"grey58", 0x94, 0x94, 0x94}, {"grey59", 0x96, 0x96, 0x96}, {"grey60", 0x99, 0x99, 0x99}, {"grey61", 0x9c, 0x9c, 0x9c}, {"grey62", 0x9e, 0x9e, 0x9e}, {"grey63", 0xa1, 0xa1, 0xa1}, {"grey64", 0xa3, 0xa3, 0xa3}, {"grey65", 0xa6, 0xa6, 0xa6}, {"grey66", 0xa8, 0xa8, 0xa8}, {"grey67", 0xab, 0xab, 0xab}, {"grey68", 0xad, 0xad, 0xad}, {"grey69", 0xb0, 0xb0, 0xb0}, {"grey70", 0xb3, 0xb3, 0xb3}, {"grey71", 0xb5, 0xb5, 0xb5}, {"grey72", 0xb8, 0xb8, 0xb8}, {"grey73", 0xba, 0xba, 0xba}, {"grey74", 0xbd, 0xbd, 0xbd}, {"grey75", 0xbf, 0xbf, 0xbf}, {"grey76", 0xc2, 0xc2, 0xc2}, {"grey77", 0xc4, 0xc4, 0xc4}, {"grey78", 0xc7, 0xc7, 0xc7}, {"grey79", 0xc9, 0xc9, 0xc9}, {"grey80", 0xcc, 0xcc, 0xcc}, {"grey81", 0xcf, 0xcf, 0xcf}, {"grey82", 0xd1, 0xd1, 0xd1}, {"grey83", 0xd4, 0xd4, 0xd4}, {"grey84", 0xd6, 0xd6, 0xd6}, {"grey85", 0xd9, 0xd9, 0xd9}, {"grey86", 0xdb, 0xdb, 0xdb}, {"grey87", 0xde, 0xde, 0xde}, {"grey88", 0xe0, 0xe0, 0xe0}, {"grey89", 0xe3, 0xe3, 0xe3}, {"grey90", 0xe5, 0xe5, 0xe5}, {"grey91", 0xe8, 0xe8, 0xe8}, {"grey92", 0xeb, 0xeb, 0xeb}, {"grey93", 0xed, 0xed, 0xed}, {"grey94", 0xf0, 0xf0, 0xf0}, {"grey95", 0xf2, 0xf2, 0xf2}, {"grey96", 0xf5, 0xf5, 0xf5}, {"grey97", 0xf7, 0xf7, 0xf7}, {"grey98", 0xfa, 0xfa, 0xfa}, {"grey99", 0xfc, 0xfc, 0xfc}, {"grey100", 0xff, 0xff, 0xff}, {"honeydew", 0xf0, 0xff, 0xf0}, {"honeydew1", 0xf0, 0xff, 0xf0}, {"honeydew2", 0xe0, 0xee, 0xe0}, {"honeydew3", 0xc1, 0xcd, 0xc1}, {"honeydew4", 0x83, 0x8b, 0x83}, {"hotpink", 0xff, 0x69, 0xb4}, {"hotpink1", 0xff, 0x6e, 0xb4}, {"hotpink2", 0xee, 0x6a, 0xa7}, {"hotpink3", 0xcd, 0x60, 0x90}, {"hotpink4", 0x8b, 0x3a, 0x62}, {"indianred", 0xcd, 0x5c, 0x5c}, {"indianred1", 0xff, 0x6a, 0x6a}, {"indianred2", 0xee, 0x63, 0x63}, {"indianred3", 0xcd, 0x55, 0x55}, {"indianred4", 0x8b, 0x3a, 0x3a}, {"ivory", 0xff, 0xff, 0xf0}, {"ivory1", 0xff, 0xff, 0xf0}, {"ivory2", 0xee, 0xee, 0xe0}, {"ivory3", 0xcd, 0xcd, 0xc1}, {"ivory4", 0x8b, 0x8b, 0x83}, {"khaki", 0xf0, 0xe6, 0x8c}, {"khaki1", 0xff, 0xf6, 0x8f}, {"khaki2", 0xee, 0xe6, 0x85}, {"khaki3", 0xcd, 0xc6, 0x73}, {"khaki4", 0x8b, 0x86, 0x4e}, {"lavender", 0xe6, 0xe6, 0xfa}, {"lavenderblush", 0xff, 0xf0, 0xf5}, {"lavenderblush1", 0xff, 0xf0, 0xf5}, {"lavenderblush2", 0xee, 0xe0, 0xe5}, {"lavenderblush3", 0xcd, 0xc1, 0xc5}, {"lavenderblush4", 0x8b, 0x83, 0x86}, {"lawngreen", 0x7c, 0xfc, 0x00}, {"lemonchiffon", 0xff, 0xfa, 0xcd}, {"lemonchiffon1", 0xff, 0xfa, 0xcd}, {"lemonchiffon2", 0xee, 0xe9, 0xbf}, {"lemonchiffon3", 0xcd, 0xc9, 0xa5}, {"lemonchiffon4", 0x8b, 0x89, 0x70}, {"lightblue", 0xad, 0xd8, 0xe6}, {"lightblue1", 0xbf, 0xef, 0xff}, {"lightblue2", 0xb2, 0xdf, 0xee}, {"lightblue3", 0x9a, 0xc0, 0xcd}, {"lightblue4", 0x68, 0x83, 0x8b}, {"lightcoral", 0xf0, 0x80, 0x80}, {"lightcyan", 0xe0, 0xff, 0xff}, {"lightcyan1", 0xe0, 0xff, 0xff}, {"lightcyan2", 0xd1, 0xee, 0xee}, {"lightcyan3", 0xb4, 0xcd, 0xcd}, {"lightcyan4", 0x7a, 0x8b, 0x8b}, {"lightgoldenrod", 0xee, 0xdd, 0x82}, {"lightgoldenrod1", 0xff, 0xec, 0x8b}, {"lightgoldenrod2", 0xee, 0xdc, 0x82}, {"lightgoldenrod3", 0xcd, 0xbe, 0x70}, {"lightgoldenrod4", 0x8b, 0x81, 0x4c}, {"lightgoldenrodyellow", 0xfa, 0xfa, 0xd2}, {"lightgray", 0xd3, 0xd3, 0xd3}, {"lightgreen", 0x90, 0xee, 0x90}, {"lightgrey", 0xd3, 0xd3, 0xd3}, {"lightpink", 0xff, 0xb6, 0xc1}, {"lightpink1", 0xff, 0xae, 0xb9}, {"lightpink2", 0xee, 0xa2, 0xad}, {"lightpink3", 0xcd, 0x8c, 0x95}, {"lightpink4", 0x8b, 0x5f, 0x65}, {"lightsalmon", 0xff, 0xa0, 0x7a}, {"lightsalmon1", 0xff, 0xa0, 0x7a}, {"lightsalmon2", 0xee, 0x95, 0x72}, {"lightsalmon3", 0xcd, 0x81, 0x62}, {"lightsalmon4", 0x8b, 0x57, 0x42}, {"lightseagreen", 0x20, 0xb2, 0xaa}, {"lightskyblue", 0x87, 0xce, 0xfa}, {"lightskyblue1", 0xb0, 0xe2, 0xff}, {"lightskyblue2", 0xa4, 0xd3, 0xee}, {"lightskyblue3", 0x8d, 0xb6, 0xcd}, {"lightskyblue4", 0x60, 0x7b, 0x8b}, {"lightslateblue", 0x84, 0x70, 0xff}, {"lightslategray", 0x77, 0x88, 0x99}, {"lightslategrey", 0x77, 0x88, 0x99}, {"lightsteelblue", 0xb0, 0xc4, 0xde}, {"lightsteelblue1", 0xca, 0xe1, 0xff}, {"lightsteelblue2", 0xbc, 0xd2, 0xee}, {"lightsteelblue3", 0xa2, 0xb5, 0xcd}, {"lightsteelblue4", 0x6e, 0x7b, 0x8b}, {"lightyellow", 0xff, 0xff, 0xe0}, {"lightyellow1", 0xff, 0xff, 0xe0}, {"lightyellow2", 0xee, 0xee, 0xd1}, {"lightyellow3", 0xcd, 0xcd, 0xb4}, {"lightyellow4", 0x8b, 0x8b, 0x7a}, {"limegreen", 0x32, 0xcd, 0x32}, {"linen", 0xfa, 0xf0, 0xe6}, {"magenta", 0xff, 0x00, 0xff}, {"magenta1", 0xff, 0x00, 0xff}, {"magenta2", 0xee, 0x00, 0xee}, {"magenta3", 0xcd, 0x00, 0xcd}, {"magenta4", 0x8b, 0x00, 0x8b}, {"maroon", 0xb0, 0x30, 0x60}, {"maroon1", 0xff, 0x34, 0xb3}, {"maroon2", 0xee, 0x30, 0xa7}, {"maroon3", 0xcd, 0x29, 0x90}, {"maroon4", 0x8b, 0x1c, 0x62}, {"mediumaquamarine", 0x66, 0xcd, 0xaa}, {"mediumblue", 0x00, 0x00, 0xcd}, {"mediumorchid", 0xba, 0x55, 0xd3}, {"mediumorchid1", 0xe0, 0x66, 0xff}, {"mediumorchid2", 0xd1, 0x5f, 0xee}, {"mediumorchid3", 0xb4, 0x52, 0xcd}, {"mediumorchid4", 0x7a, 0x37, 0x8b}, {"mediumpurple", 0x93, 0x70, 0xdb}, {"mediumpurple1", 0xab, 0x82, 0xff}, {"mediumpurple2", 0x9f, 0x79, 0xee}, {"mediumpurple3", 0x89, 0x68, 0xcd}, {"mediumpurple4", 0x5d, 0x47, 0x8b}, {"mediumseagreen", 0x3c, 0xb3, 0x71}, {"mediumslateblue", 0x7b, 0x68, 0xee}, {"mediumspringgreen", 0x00, 0xfa, 0x9a}, {"mediumturquoise", 0x48, 0xd1, 0xcc}, {"mediumvioletred", 0xc7, 0x15, 0x85}, {"midnightblue", 0x19, 0x19, 0x70}, {"mintcream", 0xf5, 0xff, 0xfa}, {"mistyrose", 0xff, 0xe4, 0xe1}, {"mistyrose1", 0xff, 0xe4, 0xe1}, {"mistyrose2", 0xee, 0xd5, 0xd2}, {"mistyrose3", 0xcd, 0xb7, 0xb5}, {"mistyrose4", 0x8b, 0x7d, 0x7b}, {"moccasin", 0xff, 0xe4, 0xb5}, {"navajowhite", 0xff, 0xde, 0xad}, {"navajowhite1", 0xff, 0xde, 0xad}, {"navajowhite2", 0xee, 0xcf, 0xa1}, {"navajowhite3", 0xcd, 0xb3, 0x8b}, {"navajowhite4", 0x8b, 0x79, 0x5e}, {"navy", 0x00, 0x00, 0x80}, {"navyblue", 0x00, 0x00, 0x80}, {"oldlace", 0xfd, 0xf5, 0xe6}, {"olivedrab", 0x6b, 0x8e, 0x23}, {"olivedrab1", 0xc0, 0xff, 0x3e}, {"olivedrab2", 0xb3, 0xee, 0x3a}, {"olivedrab3", 0x9a, 0xcd, 0x32}, {"olivedrab4", 0x69, 0x8b, 0x22}, {"orange", 0xff, 0xa5, 0x00}, {"orange1", 0xff, 0xa5, 0x00}, {"orange2", 0xee, 0x9a, 0x00}, {"orange3", 0xcd, 0x85, 0x00}, {"orange4", 0x8b, 0x5a, 0x00}, {"orangered", 0xff, 0x45, 0x00}, {"orangered1", 0xff, 0x45, 0x00}, {"orangered2", 0xee, 0x40, 0x00}, {"orangered3", 0xcd, 0x37, 0x00}, {"orangered4", 0x8b, 0x25, 0x00}, {"orchid", 0xda, 0x70, 0xd6}, {"orchid1", 0xff, 0x83, 0xfa}, {"orchid2", 0xee, 0x7a, 0xe9}, {"orchid3", 0xcd, 0x69, 0xc9}, {"orchid4", 0x8b, 0x47, 0x89}, {"palegoldenrod", 0xee, 0xe8, 0xaa}, {"palegreen", 0x98, 0xfb, 0x98}, {"palegreen1", 0x9a, 0xff, 0x9a}, {"palegreen2", 0x90, 0xee, 0x90}, {"palegreen3", 0x7c, 0xcd, 0x7c}, {"palegreen4", 0x54, 0x8b, 0x54}, {"paleturquoise", 0xaf, 0xee, 0xee}, {"paleturquoise1", 0xbb, 0xff, 0xff}, {"paleturquoise2", 0xae, 0xee, 0xee}, {"paleturquoise3", 0x96, 0xcd, 0xcd}, {"paleturquoise4", 0x66, 0x8b, 0x8b}, {"palevioletred", 0xdb, 0x70, 0x93}, {"palevioletred1", 0xff, 0x82, 0xab}, {"palevioletred2", 0xee, 0x79, 0x9f}, {"palevioletred3", 0xcd, 0x68, 0x89}, {"palevioletred4", 0x8b, 0x47, 0x5d}, {"papayawhip", 0xff, 0xef, 0xd5}, {"peachpuff", 0xff, 0xda, 0xb9}, {"peachpuff1", 0xff, 0xda, 0xb9}, {"peachpuff2", 0xee, 0xcb, 0xad}, {"peachpuff3", 0xcd, 0xaf, 0x95}, {"peachpuff4", 0x8b, 0x77, 0x65}, {"peru", 0xcd, 0x85, 0x3f}, {"pink", 0xff, 0xc0, 0xcb}, {"pink1", 0xff, 0xb5, 0xc5}, {"pink2", 0xee, 0xa9, 0xb8}, {"pink3", 0xcd, 0x91, 0x9e}, {"pink4", 0x8b, 0x63, 0x6c}, {"plum", 0xdd, 0xa0, 0xdd}, {"plum1", 0xff, 0xbb, 0xff}, {"plum2", 0xee, 0xae, 0xee}, {"plum3", 0xcd, 0x96, 0xcd}, {"plum4", 0x8b, 0x66, 0x8b}, {"powderblue", 0xb0, 0xe0, 0xe6}, {"purple", 0xa0, 0x20, 0xf0}, {"purple1", 0x9b, 0x30, 0xff}, {"purple2", 0x91, 0x2c, 0xee}, {"purple3", 0x7d, 0x26, 0xcd}, {"purple4", 0x55, 0x1a, 0x8b}, {"red", 0xff, 0x00, 0x00}, {"red1", 0xff, 0x00, 0x00}, {"red2", 0xee, 0x00, 0x00}, {"red3", 0xcd, 0x00, 0x00}, {"red4", 0x8b, 0x00, 0x00}, {"rosybrown", 0xbc, 0x8f, 0x8f}, {"rosybrown1", 0xff, 0xc1, 0xc1}, {"rosybrown2", 0xee, 0xb4, 0xb4}, {"rosybrown3", 0xcd, 0x9b, 0x9b}, {"rosybrown4", 0x8b, 0x69, 0x69}, {"royalblue", 0x41, 0x69, 0xe1}, {"royalblue1", 0x48, 0x76, 0xff}, {"royalblue2", 0x43, 0x6e, 0xee}, {"royalblue3", 0x3a, 0x5f, 0xcd}, {"royalblue4", 0x27, 0x40, 0x8b}, {"saddlebrown", 0x8b, 0x45, 0x13}, {"salmon", 0xfa, 0x80, 0x72}, {"salmon1", 0xff, 0x8c, 0x69}, {"salmon2", 0xee, 0x82, 0x62}, {"salmon3", 0xcd, 0x70, 0x54}, {"salmon4", 0x8b, 0x4c, 0x39}, {"sandybrown", 0xf4, 0xa4, 0x60}, {"seagreen", 0x2e, 0x8b, 0x57}, {"seagreen1", 0x54, 0xff, 0x9f}, {"seagreen2", 0x4e, 0xee, 0x94}, {"seagreen3", 0x43, 0xcd, 0x80}, {"seagreen4", 0x2e, 0x8b, 0x57}, {"seashell", 0xff, 0xf5, 0xee}, {"seashell1", 0xff, 0xf5, 0xee}, {"seashell2", 0xee, 0xe5, 0xde}, {"seashell3", 0xcd, 0xc5, 0xbf}, {"seashell4", 0x8b, 0x86, 0x82}, {"sienna", 0xa0, 0x52, 0x2d}, {"sienna1", 0xff, 0x82, 0x47}, {"sienna2", 0xee, 0x79, 0x42}, {"sienna3", 0xcd, 0x68, 0x39}, {"sienna4", 0x8b, 0x47, 0x26}, {"skyblue", 0x87, 0xce, 0xeb}, {"skyblue1", 0x87, 0xce, 0xff}, {"skyblue2", 0x7e, 0xc0, 0xee}, {"skyblue3", 0x6c, 0xa6, 0xcd}, {"skyblue4", 0x4a, 0x70, 0x8b}, {"slateblue", 0x6a, 0x5a, 0xcd}, {"slateblue1", 0x83, 0x6f, 0xff}, {"slateblue2", 0x7a, 0x67, 0xee}, {"slateblue3", 0x69, 0x59, 0xcd}, {"slateblue4", 0x47, 0x3c, 0x8b}, {"slategray", 0x70, 0x80, 0x90}, {"slategray1", 0xc6, 0xe2, 0xff}, {"slategray2", 0xb9, 0xd3, 0xee}, {"slategray3", 0x9f, 0xb6, 0xcd}, {"slategray4", 0x6c, 0x7b, 0x8b}, {"slategrey", 0x70, 0x80, 0x90}, {"slategrey1", 0xc6, 0xe2, 0xff}, {"slategrey2", 0xb9, 0xd3, 0xee}, {"slategrey3", 0x9f, 0xb6, 0xcd}, {"slategrey4", 0x6c, 0x7b, 0x8b}, {"snow", 0xff, 0xfa, 0xfa}, {"snow1", 0xff, 0xfa, 0xfa}, {"snow2", 0xee, 0xe9, 0xe9}, {"snow3", 0xcd, 0xc9, 0xc9}, {"snow4", 0x8b, 0x89, 0x89}, {"springgreen", 0x00, 0xff, 0x7f}, {"springgreen1", 0x00, 0xff, 0x7f}, {"springgreen2", 0x00, 0xee, 0x76}, {"springgreen3", 0x00, 0xcd, 0x66}, {"springgreen4", 0x00, 0x8b, 0x45}, {"steelblue", 0x46, 0x82, 0xb4}, {"steelblue1", 0x63, 0xb8, 0xff}, {"steelblue2", 0x5c, 0xac, 0xee}, {"steelblue3", 0x4f, 0x94, 0xcd}, {"steelblue4", 0x36, 0x64, 0x8b}, {"tan", 0xd2, 0xb4, 0x8c}, {"tan1", 0xff, 0xa5, 0x4f}, {"tan2", 0xee, 0x9a, 0x49}, {"tan3", 0xcd, 0x85, 0x3f}, {"tan4", 0x8b, 0x5a, 0x2b}, {"thistle", 0xd8, 0xbf, 0xd8}, {"thistle1", 0xff, 0xe1, 0xff}, {"thistle2", 0xee, 0xd2, 0xee}, {"thistle3", 0xcd, 0xb5, 0xcd}, {"thistle4", 0x8b, 0x7b, 0x8b}, {"tomato", 0xff, 0x63, 0x47}, {"tomato1", 0xff, 0x63, 0x47}, {"tomato2", 0xee, 0x5c, 0x42}, {"tomato3", 0xcd, 0x4f, 0x39}, {"tomato4", 0x8b, 0x36, 0x26}, {"turquoise", 0x40, 0xe0, 0xd0}, {"turquoise1", 0x00, 0xf5, 0xff}, {"turquoise2", 0x00, 0xe5, 0xee}, {"turquoise3", 0x00, 0xc5, 0xcd}, {"turquoise4", 0x00, 0x86, 0x8b}, {"violet", 0xee, 0x82, 0xee}, {"violetred", 0xd0, 0x20, 0x90}, {"violetred1", 0xff, 0x3e, 0x96}, {"violetred2", 0xee, 0x3a, 0x8c}, {"violetred3", 0xcd, 0x32, 0x78}, {"violetred4", 0x8b, 0x22, 0x52}, {"wheat", 0xf5, 0xde, 0xb3}, {"wheat1", 0xff, 0xe7, 0xba}, {"wheat2", 0xee, 0xd8, 0xae}, {"wheat3", 0xcd, 0xba, 0x96}, {"wheat4", 0x8b, 0x7e, 0x66}, {"white", 0xff, 0xff, 0xff}, {"whitesmoke", 0xf5, 0xf5, 0xf5}, {"yellow", 0xff, 0xff, 0x00}, {"yellow1", 0xff, 0xff, 0x00}, {"yellow2", 0xee, 0xee, 0x00}, {"yellow3", 0xcd, 0xcd, 0x00}, {"yellow4", 0x8b, 0x8b, 0x00}, {"yellowgreen", 0x9a, 0xcd, 0x32}, {NO_TEXT, 0, 0, 0} }; /** @brief Searches colour in the list. @param p Node in syntax tree. @param name Colour name. @param iindex Set to iindex in table. @return Whether colour name is found. **/ static BOOL_T string_to_colour (NODE_T * p, char *name, int *iindex) { A68_REF z_ref = heap_generator (p, MODE (C_STRING), (int) (1 + strlen (name))); char *z = DEREF (char, &z_ref); int i, j; BOOL_T k; /* First remove formatting from name: spaces and capitals are irrelevant */ j = 0; for (i = 0; name[i] != NULL_CHAR; i++) { if (name[i] != BLANK_CHAR) { z[j++] = (char) TO_LOWER (name[i]); } z[j] = 0; } /* Now search with the famous British Library Method */ k = A68_FALSE; for (i = 0; i < COLOUR_NAMES && !k; i++) { if (!strcmp (NAME (&A68_COLOURS[i]), z)) { k = A68_TRUE; *iindex = i; } } return (k); } /** @brief Scans string for an integer. @param z Text buffer. @param k Set to int value. @return Whether conversion is successful. **/ static BOOL_T scan_int (char **z, int *k) { char *y = *z; while (y[0] != NULL_CHAR && !IS_DIGIT (y[0])) { y++; } if (y[0] != NULL_CHAR) { (*k) = strtol (y, z, 10); return ((BOOL_T) (errno == 0)); } else { return (A68_FALSE); } } /** @brief PROC (REF FILE, STRING, STRING) make device @param p Node in syntax tree. **/ void genie_make_device (NODE_T * p) { int size; A68_REF ref_device, ref_page, ref_file; A68_FILE *file; /* Pop arguments */ POP_REF (p, &ref_page); POP_REF (p, &ref_device); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); if (DEVICE_MADE (&DEVICE (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_ALREADY_SET); exit_genie (p, A68_RUNTIME_ERROR); } /* Fill in page_size */ size = a68_string_size (p, ref_page); if (INITIALISED (&(A68_PAGE_SIZE (&DEVICE (file)))) && !IS_NIL (A68_PAGE_SIZE (&DEVICE (file)))) { UNBLOCK_GC_HANDLE (&A68_PAGE_SIZE (&DEVICE (file))); } A68_PAGE_SIZE (&DEVICE (file)) = heap_generator (p, MODE (STRING), 1 + size); BLOCK_GC_HANDLE (&A68_PAGE_SIZE (&DEVICE (file))); ASSERT (a_to_c_string (p, DEREF (char, &A68_PAGE_SIZE (&DEVICE (file))), ref_page) != NO_TEXT); /* Fill in device */ size = a68_string_size (p, ref_device); if (INITIALISED (&(DEVICE (&DEVICE (file)))) && !IS_NIL (DEVICE (&DEVICE (file)))) { UNBLOCK_GC_HANDLE (&DEVICE (&DEVICE (file))); } DEVICE (&DEVICE (file)) = heap_generator (p, MODE (STRING), 1 + size); BLOCK_GC_HANDLE (&DEVICE (&DEVICE (file))); ASSERT (a_to_c_string (p, DEREF (char, &DEVICE (&DEVICE (file))), ref_device) != NO_TEXT); DEVICE_MADE (&DEVICE (file)) = A68_TRUE; PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); } /** @brief Closes the plotter. @param p Node in syntax tree. @param f Pointer to file. @return TRUE or exits **/ BOOL_T close_device (NODE_T * p, A68_FILE * f) { CHECK_INIT (p, INITIALISED (f), MODE (FILE)); if (!OPENED (f)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (!(DEVICE_OPENED (&DEVICE (f)))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DEVICE_MADE (&DEVICE (f))) { if (!IS_NIL (DEVICE (&DEVICE (f)))) { UNBLOCK_GC_HANDLE (&(DEVICE (&DEVICE (f)))); } if (!IS_NIL (A68_PAGE_SIZE (&DEVICE (f)))) { UNBLOCK_GC_HANDLE (&(A68_PAGE_SIZE (&DEVICE (f)))); } } if (pl_closepl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CLOSING_DEVICE); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_deletepl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CLOSING_DEVICE); exit_genie (p, A68_RUNTIME_ERROR); } if (STREAM (&DEVICE (f)) != NO_STREAM && fclose (STREAM (&DEVICE (f))) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CLOSING_FILE); exit_genie (p, A68_RUNTIME_ERROR); } DEVICE_OPENED (&DEVICE (f)) = A68_FALSE; return (A68_TRUE); } /** @brief Sets up the plotter prior to using it. @param p Node in syntax tree. @param f Pointer to file. @return Plotter of file. **/ static plPlotter *set_up_device (NODE_T * p, A68_FILE * f) { A68_REF ref_filename; char *filename, *device_type; /* First set up the general device, then plotter-specific things */ CHECK_INIT (p, INITIALISED (f), MODE (FILE)); ref_filename = IDENTIFICATION (f); /* This one in front as to quickly select the plotter */ if (DEVICE_OPENED (&DEVICE (f))) { if (DEVICE_HANDLE (&DEVICE (f)) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } return (PLOTTER (&DEVICE (f))); } /* Device not set up yet */ if (!OPENED (f)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (f)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (f)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!DRAW (&CHANNEL (f))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "drawing"); exit_genie (p, A68_RUNTIME_ERROR); } if (!DEVICE_MADE (&DEVICE (f))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_NOT_SET); exit_genie (p, A68_RUNTIME_ERROR); } device_type = DEREF (char, &DEVICE (&DEVICE (f))); if (!strcmp (device_type, "X")) { #if defined X_DISPLAY_MISSING diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "X plotter missing", ""); exit_genie (p, A68_RUNTIME_ERROR); #else /*-----------------------------------------+ | Supported plotter type - X Window System | +-----------------------------------------*/ char *z = DEREF (char, &A68_PAGE_SIZE (&DEVICE (f))), size[BUFFER_SIZE]; /* Establish page size */ if (!scan_int (&z, &(WINDOW_X_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (!scan_int (&z, &(WINDOW_Y_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (z[0] != NULL_CHAR) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } /* Make the X window */ FD (f) = -1; PLOTTER_PARAMS (&DEVICE (f)) = pl_newplparams (); if (PLOTTER_PARAMS (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_ALLOCATE); exit_genie (p, A68_RUNTIME_ERROR); } ASSERT (snprintf (size, SNPRINTF_SIZE, "%dx%d", WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))) >= 0); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BITMAPSIZE", size); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BG_COLOR", (void *) "black"); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "VANISH_ON_DELETE", (void *) "no"); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "X_AUTO_FLUSH", (void *) "yes"); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "USE_DOUBLE_BUFFERING", (void *) "no"); PLOTTER (&DEVICE (f)) = pl_newpl_r ("X", NULL, NULL, stderr, PLOTTER_PARAMS (&DEVICE (f))); if (PLOTTER (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } (void) pl_space_r (PLOTTER (&DEVICE (f)), 0, 0, WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))); (void) pl_bgcolorname_r (PLOTTER (&DEVICE (f)), "black"); (void) pl_colorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_pencolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_fillcolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_filltype_r (PLOTTER (&DEVICE (f)), 0); DRAW_MOOD (f) = A68_TRUE; DEVICE_OPENED (&DEVICE (f)) = A68_TRUE; X_COORD (&DEVICE (f)) = 0; Y_COORD (&DEVICE (f)) = 0; return (PLOTTER (&DEVICE (f))); #endif } else if (!strcmp (device_type, "pnm")) { /*-----------------------------------------+ | Supported plotter type - Portable aNyMap | +-----------------------------------------*/ char *z = DEREF (char, &A68_PAGE_SIZE (&DEVICE (f))), size[BUFFER_SIZE]; /* Establish page size */ if (!scan_int (&z, &(WINDOW_X_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (!scan_int (&z, &(WINDOW_Y_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (z[0] != NULL_CHAR) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } /* Open the output file for drawing */ CHECK_REF (p, ref_filename, MODE (ROWS)); filename = DEREF (char, &ref_filename); RESET_ERRNO; if ((STREAM (&DEVICE (f)) = fopen (filename, "wb")) == NO_STREAM) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CANNOT_OPEN_NAME, filename); exit_genie (p, A68_RUNTIME_ERROR); } else { READ_MOOD (f) = A68_FALSE; WRITE_MOOD (f) = A68_FALSE; CHAR_MOOD (f) = A68_FALSE; DRAW_MOOD (f) = A68_TRUE; } /* Set up plotter */ ASSERT (snprintf (size, SNPRINTF_SIZE, "%dx%d", WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))) >= 0); PLOTTER_PARAMS (&DEVICE (f)) = pl_newplparams (); if (PLOTTER_PARAMS (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_ALLOCATE); exit_genie (p, A68_RUNTIME_ERROR); } (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BITMAPSIZE", size); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BG_COLOR", (void *) "black"); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "PNM_PORTABLE", (void *) "no"); PLOTTER (&DEVICE (f)) = pl_newpl_r ("pnm", NULL, STREAM (&DEVICE (f)), stderr, PLOTTER_PARAMS (&DEVICE (f))); if (PLOTTER (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } (void) pl_space_r (PLOTTER (&DEVICE (f)), 0, 0, WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))); (void) pl_bgcolorname_r (PLOTTER (&DEVICE (f)), "black"); (void) pl_colorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_pencolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_fillcolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_filltype_r (PLOTTER (&DEVICE (f)), 0); DRAW_MOOD (f) = A68_TRUE; DEVICE_OPENED (&DEVICE (f)) = A68_TRUE; X_COORD (&DEVICE (f)) = 0; Y_COORD (&DEVICE (f)) = 0; return (PLOTTER (&DEVICE (f))); } else if (!strcmp (device_type, "gif")) { /*------------------------------------+ | Supported plotter type - pseudo GIF | +------------------------------------*/ char *z = DEREF (char, &A68_PAGE_SIZE (&DEVICE (f))), size[BUFFER_SIZE]; /* Establish page size */ if (!scan_int (&z, &(WINDOW_X_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (!scan_int (&z, &(WINDOW_Y_SIZE (&DEVICE (f))))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } if (z[0] != NULL_CHAR) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PAGE_SIZE); exit_genie (p, A68_RUNTIME_ERROR); } /* Open the output file for drawing */ CHECK_REF (p, ref_filename, MODE (ROWS)); filename = DEREF (char, &ref_filename); RESET_ERRNO; if ((STREAM (&DEVICE (f)) = fopen (filename, "wb")) == NO_STREAM) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CANNOT_OPEN_NAME, filename); exit_genie (p, A68_RUNTIME_ERROR); } else { READ_MOOD (f) = A68_FALSE; WRITE_MOOD (f) = A68_FALSE; CHAR_MOOD (f) = A68_FALSE; DRAW_MOOD (f) = A68_TRUE; } /* Set up plotter */ PLOTTER_PARAMS (&DEVICE (f)) = pl_newplparams (); if (PLOTTER_PARAMS (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_ALLOCATE); exit_genie (p, A68_RUNTIME_ERROR); } ASSERT (snprintf (size, SNPRINTF_SIZE, "%dx%d", WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))) >= 0); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BITMAPSIZE", size); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "BG_COLOR", (void *) "black"); (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "GIF_ANIMATION", (void *) "no"); PLOTTER (&DEVICE (f)) = pl_newpl_r ("gif", NULL, STREAM (&DEVICE (f)), stderr, PLOTTER_PARAMS (&DEVICE (f))); if (PLOTTER (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } (void) pl_space_r (PLOTTER (&DEVICE (f)), 0, 0, WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))); (void) pl_bgcolorname_r (PLOTTER (&DEVICE (f)), "black"); (void) pl_colorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_pencolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_fillcolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_filltype_r (PLOTTER (&DEVICE (f)), 0); DRAW_MOOD (f) = A68_TRUE; DEVICE_OPENED (&DEVICE (f)) = A68_TRUE; X_COORD (&DEVICE (f)) = 0; Y_COORD (&DEVICE (f)) = 0; return (PLOTTER (&DEVICE (f))); } else if (!strcmp (device_type, "ps")) { #if defined POSTSCRIPT_MISSING diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "postscript plotter missing", ""); exit_genie (p, A68_RUNTIME_ERROR); #else /*------------------------------------+ | Supported plotter type - Postscript | +------------------------------------*/ /* Open the output file for drawing */ CHECK_REF (p, ref_filename, MODE (ROWS)); filename = DEREF (char, &ref_filename); RESET_ERRNO; if ((STREAM (&DEVICE (f)) = fopen (filename, "w")) == NO_STREAM) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CANNOT_OPEN_NAME, filename); exit_genie (p, A68_RUNTIME_ERROR); } else { READ_MOOD (f) = A68_FALSE; WRITE_MOOD (f) = A68_FALSE; CHAR_MOOD (f) = A68_FALSE; DRAW_MOOD (f) = A68_TRUE; } /* Set up ps plotter */ PLOTTER_PARAMS (&DEVICE (f)) = pl_newplparams (); if (PLOTTER_PARAMS (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_ALLOCATE); exit_genie (p, A68_RUNTIME_ERROR); } (void) pl_setplparam (PLOTTER_PARAMS (&DEVICE (f)), "PAGESIZE", DEREF (char, &A68_PAGE_SIZE (&DEVICE (f)))); PLOTTER (&DEVICE (f)) = pl_newpl_r ("ps", NULL, STREAM (&DEVICE (f)), stderr, PLOTTER_PARAMS (&DEVICE (f))); if (PLOTTER (&DEVICE (f)) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (pl_openpl_r (PLOTTER (&DEVICE (f))) < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DEVICE_CANNOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } WINDOW_X_SIZE (&DEVICE (f)) = 1000; WINDOW_Y_SIZE (&DEVICE (f)) = 1000; (void) pl_space_r (PLOTTER (&DEVICE (f)), 0, 0, WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f))); (void) pl_bgcolorname_r (PLOTTER (&DEVICE (f)), "black"); (void) pl_colorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_pencolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_fillcolorname_r (PLOTTER (&DEVICE (f)), "white"); (void) pl_filltype_r (PLOTTER (&DEVICE (f)), 0); DRAW_MOOD (f) = A68_TRUE; DEVICE_OPENED (&DEVICE (f)) = A68_TRUE; X_COORD (&DEVICE (f)) = 0; Y_COORD (&DEVICE (f)) = 0; return (PLOTTER (&DEVICE (f))); #endif } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "unindentified plotter", device_type); exit_genie (p, A68_RUNTIME_ERROR); } return (NULL); } /** @brief PROC (REF FILE) VOID draw erase @param p Node in syntax tree. **/ void genie_draw_clear (NODE_T * p) { A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_flushpl_r (plotter); (void) pl_erase_r (plotter); } /** @brief PROC (REF FILE) VOID draw show @param p Node in syntax tree. **/ void genie_draw_show (NODE_T * p) { A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_flushpl_r (plotter); } /** @brief PROC (REF FILE) REAL draw aspect @param p Node in syntax tree. **/ void genie_draw_aspect (NODE_T * p) { A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); PUSH_PRIMITIVE (p, (double) WINDOW_Y_SIZE (&DEVICE (f)) / (double) WINDOW_X_SIZE (&DEVICE (f)), A68_REAL); } /** @brief PROC (REF FILE, INT) VOID draw fillstyle @param p Node in syntax tree. **/ void genie_draw_fillstyle (NODE_T * p) { A68_INT z; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &z, A68_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_filltype_r (plotter, (int) VALUE (&z)); } /** @brief PROC (INT) STRING draw get colour name @param p Node in syntax tree. **/ void genie_draw_get_colour_name (NODE_T * p) { A68_INT z; int j; char *str; POP_OBJECT (p, &z, A68_INT); j = (VALUE (&z) - 1) % COLOUR_NAMES; str = NAME (&A68_COLOURS[j]); PUSH_REF (p, c_to_a_string (p, str, DEFAULT_WIDTH)); } /** @brief PROC (REF FILE, REAL, REAL, REAL) VOID draw colour @param p Node in syntax tree. **/ void genie_draw_colour (NODE_T * p) { A68_REAL x, y, z; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &z, A68_REAL); POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); RED (&DEVICE (f)) = VALUE (&x); GREEN (&DEVICE (f)) = VALUE (&y); BLUE (&DEVICE (f)) = VALUE (&z); (void) pl_color_r (plotter, (int) (VALUE (&x) * COLOUR_MAX), (int) (VALUE (&y) * COLOUR_MAX), (int) (VALUE (&z) * COLOUR_MAX)); (void) pl_pencolor_r (plotter, (int) (VALUE (&x) * COLOUR_MAX), (int) (VALUE (&y) * COLOUR_MAX), (int) (VALUE (&z) * COLOUR_MAX)); (void) pl_fillcolor_r (plotter, (int) (VALUE (&x) * COLOUR_MAX), (int) (VALUE (&y) * COLOUR_MAX), (int) (VALUE (&z) * COLOUR_MAX)); } /** @brief PROC (REF FILE, REAL, REAL, REAL) VOID draw background colour @param p Node in syntax tree. **/ void genie_draw_background_colour (NODE_T * p) { A68_REAL x, y, z; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &z, A68_REAL); POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_bgcolor_r (plotter, (int) (VALUE (&x) * COLOUR_MAX), (int) (VALUE (&y) * COLOUR_MAX), (int) (VALUE (&z) * COLOUR_MAX)); } /** @brief PROC (REF FILE, STRING) VOID draw colour name @param p Node in syntax tree. **/ void genie_draw_colour_name (NODE_T * p) { A68_REF ref_c, ref_file; A68_FILE *f; A68_REF name_ref; char *name; int iindex; double x, y, z; plPlotter *plotter; POP_REF (p, &ref_c); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); name_ref = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, ref_c)); name = DEREF (char, &name_ref); ASSERT (a_to_c_string (p, name, ref_c) != NO_TEXT); if (!string_to_colour (p, name, &iindex)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "unidentified colour name", name); exit_genie (p, A68_RUNTIME_ERROR); } x = (double) (RED (&A68_COLOURS[iindex])) / (double) (0xff); y = (double) (GREEN (&A68_COLOURS[iindex])) / (double) (0xff); z = (double) (BLUE (&A68_COLOURS[iindex])) / (double) (0xff); plotter = set_up_device (p, f); RED (&DEVICE (f)) = x; GREEN (&DEVICE (f)) = y; BLUE (&DEVICE (f)) = z; (void) pl_color_r (plotter, (int) (x * COLOUR_MAX), (int) (y * COLOUR_MAX), (int) (z * COLOUR_MAX)); (void) pl_pencolor_r (plotter, (int) (x * COLOUR_MAX), (int) (y * COLOUR_MAX), (int) (z * COLOUR_MAX)); (void) pl_fillcolor_r (plotter, (int) (x * COLOUR_MAX), (int) (y * COLOUR_MAX), (int) (z * COLOUR_MAX)); } /** @brief PROC (REF FILE, STRING) VOID draw background colour name @param p Node in syntax tree. **/ void genie_draw_background_colour_name (NODE_T * p) { A68_REF ref_c, ref_file; A68_FILE *f; A68_REF name_ref; char *name; int iindex; double x, y, z; plPlotter *plotter; POP_REF (p, &ref_c); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); name_ref = heap_generator (p, MODE (C_STRING), 1 + a68_string_size (p, ref_c)); name = DEREF (char, &name_ref); ASSERT (a_to_c_string (p, name, ref_c) != NO_TEXT); if (!string_to_colour (p, name, &iindex)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_PARAMETER, "unidentified colour name", name); exit_genie (p, A68_RUNTIME_ERROR); } x = (double) (RED (&A68_COLOURS[iindex])) / (double) (0xff); y = (double) (GREEN (&A68_COLOURS[iindex])) / (double) (0xff); z = (double) (BLUE (&A68_COLOURS[iindex])) / (double) (0xff); plotter = set_up_device (p, f); RED (&DEVICE (f)) = x; GREEN (&DEVICE (f)) = y; BLUE (&DEVICE (f)) = z; (void) pl_bgcolor_r (plotter, (int) (x * COLOUR_MAX), (int) (y * COLOUR_MAX), (int) (z * COLOUR_MAX)); } /** @brief PROC (REF FILE, STRING) VOID draw linestyle @param p Node in syntax tree. **/ void genie_draw_linestyle (NODE_T * p) { A68_REF txt, ref_file; A68_FILE *f; int size; A68_REF z_ref; char *z; plPlotter *plotter; POP_REF (p, &txt); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); size = a68_string_size (p, txt); z_ref = heap_generator (p, MODE (C_STRING), 1 + size); z = DEREF (char, &z_ref); ASSERT (a_to_c_string (p, z, txt) != NO_TEXT); (void) pl_linemod_r (plotter, z); } /** @brief PROC (REF FILE, INT) VOID draw linewidth @param p Node in syntax tree. **/ void genie_draw_linewidth (NODE_T * p) { A68_REAL width; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &width, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_linewidth_r (plotter, (int) (VALUE (&width) * (double) WINDOW_Y_SIZE (&DEVICE (f)))); } /** @brief PROC (REF FILE, REAL, REAL) VOID draw move @param p Node in syntax tree. **/ void genie_draw_move (NODE_T * p) { A68_REAL x, y; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fmove_r (plotter, VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f))); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /** @brief PROC (REF FILE, REAL, REAL) VOID draw line @param p Node in syntax tree. **/ void genie_draw_line (NODE_T * p) { A68_REAL x, y; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fline_r (plotter, X_COORD (&DEVICE (f)) * WINDOW_X_SIZE (&DEVICE (f)), Y_COORD (&DEVICE (f)) * WINDOW_Y_SIZE (&DEVICE (f)), VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f))); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /** @brief PROC (REF FILE, REAL, REAL) VOID draw point @param p Node in syntax tree. **/ void genie_draw_point (NODE_T * p) { A68_REAL x, y; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fpoint_r (plotter, VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f))); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /** @brief PROC (REF FILE, REAL, REAL) VOID draw rect @param p Node in syntax tree. **/ void genie_draw_rect (NODE_T * p) { A68_REAL x, y; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fbox_r (plotter, X_COORD (&DEVICE (f)) * WINDOW_X_SIZE (&DEVICE (f)), Y_COORD (&DEVICE (f)) * WINDOW_Y_SIZE (&DEVICE (f)), VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f))); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /** @brief PROC (REF FILE, REAL, REAL, REAL) VOID draw circle @param p Node in syntax tree. **/ void genie_draw_circle (NODE_T * p) { A68_REAL x, y, r; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &r, A68_REAL); POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fcircle_r (plotter, VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f)), VALUE (&r) * MAXIMUM (WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f)))); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /** @brief PROC (REF FILE, REAL, REAL, REAL) VOID draw atom @param p Node in syntax tree. **/ void genie_draw_atom (NODE_T * p) { A68_REAL x, y, r; double frac; int j, k; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &r, A68_REAL); POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); k = (int) (VALUE (&r) * MAXIMUM (WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f)))); (void) pl_filltype_r (plotter, 1); for (j = k - 1; j >= 0; j--) { frac = (double) j / (double) (k - 1); frac = 0.6 + 0.3 * sqrt (1.0 - frac * frac); (void) pl_color_r (plotter, (int) (frac * RED (&DEVICE (f)) * COLOUR_MAX), (int) (frac * GREEN (&DEVICE (f)) * COLOUR_MAX), (int) (frac * BLUE (&DEVICE (f)) * COLOUR_MAX)); (void) pl_fcircle_r (plotter, VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f)), (double) j); } (void) pl_filltype_r (plotter, 0); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /** @brief PROC (REF FILE, REAL, REAL, REAL) VOID draw atom @param p Node in syntax tree. **/ void genie_draw_star (NODE_T * p) { A68_REAL x, y, r; double z, frac; int j, k; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &r, A68_REAL); POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); k = (int) (VALUE (&r) * MAXIMUM (WINDOW_X_SIZE (&DEVICE (f)), WINDOW_Y_SIZE (&DEVICE (f)))); for (j = k; j >= 0; j--) { z = (double) j / (double) k; if (z < 0.2) { z = z / 0.2; frac = 0.5 * (1 + (cos (A68_PI / 2 * z))); } else { z = (z - 0.2) / 0.8; frac = (1 - z) * 0.3; } (void) pl_color_r (plotter, (int) (frac * RED (&DEVICE (f)) * COLOUR_MAX), (int) (frac * GREEN (&DEVICE (f)) * COLOUR_MAX), (int) (frac * BLUE (&DEVICE (f)) * COLOUR_MAX)); (void) pl_fcircle_r (plotter, VALUE (&x) * WINDOW_X_SIZE (&DEVICE (f)), VALUE (&y) * WINDOW_Y_SIZE (&DEVICE (f)), (double) j); } (void) pl_color_r (plotter, (int) (RED (&DEVICE (f)) * COLOUR_MAX), (int) (GREEN (&DEVICE (f)) * COLOUR_MAX), (int) (BLUE (&DEVICE (f)) * COLOUR_MAX)); X_COORD (&DEVICE (f)) = VALUE (&x); Y_COORD (&DEVICE (f)) = VALUE (&y); } /** @brief PROC (REF FILE, CHAR, CHAR, STRING) VOID draw text @param p Node in syntax tree. **/ void genie_draw_text (NODE_T * p) { A68_CHAR just_v, just_h; A68_REF txt, ref_file; A68_FILE *f; int size; A68_REF z_ref; char *z; plPlotter *plotter; POP_REF (p, &txt); POP_OBJECT (p, &just_v, A68_CHAR); POP_OBJECT (p, &just_h, A68_CHAR); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); size = a68_string_size (p, txt); z_ref = heap_generator (p, MODE (C_STRING), 1 + size); z = DEREF (char, &z_ref); ASSERT (a_to_c_string (p, z, txt) != NO_TEXT); size = pl_alabel_r (plotter, VALUE (&just_h), VALUE (&just_v), z); } /** @brief PROC (REF FILE, STRING) VOID draw fontname @param p Node in syntax tree. **/ void genie_draw_fontname (NODE_T * p) { A68_REF txt, ref_file; A68_FILE *f; int size; A68_REF z_ref; char *z; plPlotter *plotter; POP_REF (p, &txt); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); size = a68_string_size (p, txt); z_ref = heap_generator (p, MODE (C_STRING), 1 + size); z = DEREF (char, &z_ref); ASSERT (a_to_c_string (p, z, txt) != NO_TEXT); (void) pl_fontname_r (plotter, z); } /** @brief PROC (REF FILE, INT) VOID draw fontsize @param p Node in syntax tree. **/ void genie_draw_fontsize (NODE_T * p) { A68_INT size; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &size, A68_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_fontsize_r (plotter, (int) VALUE (&size)); } /** @brief PROC (REF FILE, INT) VOID draw textangle @param p Node in syntax tree. **/ void genie_draw_textangle (NODE_T * p) { A68_INT angle; A68_REF ref_file; A68_FILE *f; plPlotter *plotter; POP_OBJECT (p, &angle, A68_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); f = FILE_DEREF (&ref_file); plotter = set_up_device (p, f); (void) pl_textangle_r (plotter, (int) VALUE (&angle)); } #endif algol68g-2.8/source/monitor.c0000644000175000001440000022666012113475706013100 00000000000000/** @file monitor.c @author J. Marcel van der Veer. @brief Gdb-style monitor for the interpreter. @section Copyright This file is part of Algol68G - an Algol 68 compiler-interpreter. Copyright (C) 2001-2013 J. Marcel van der Veer . @section License 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 . @section Description This is a basic monitor for Algol68G. It activates when the interpreter receives SIGINT (CTRL-C, for instance) or when PROC VOID break, debug or evaluate is called, or when a runtime error occurs and --debug is selected. The monitor allows single stepping (unit-wise through serial/enquiry clauses) and has basic means for inspecting call-frame stack and heap. **/ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" #define CANNOT_SHOW " unprintable value or uninitialised value" #define MAX_ROW_ELEMS 24 #define NOT_A_NUM (-1) #define NO_VALUE " uninitialised value" #define STACK_SIZE 32 #define TOP_MODE (_m_stack[_m_sp - 1]) #define LOGOUT_STRING "exit" ADDR_T finish_frame_pointer = 0; BOOL_T in_monitor = A68_FALSE; char *watchpoint_expression = NO_TEXT; int break_proc_level = 0; static BOOL_T check_initialisation (NODE_T *, BYTE_T *, MOID_T *, BOOL_T *); static char symbol[BUFFER_SIZE], error_text[BUFFER_SIZE], expr[BUFFER_SIZE]; static char prompt[BUFFER_SIZE]; static BOOL_T prompt_set = A68_FALSE; static int current_frame = 0; static int max_row_elems = MAX_ROW_ELEMS; static int mon_errors = 0; static int _m_sp; static int pos, attr; static int tabs = 0; static MOID_T *_m_stack[STACK_SIZE]; static void parse (FILE_T, NODE_T *, int); #define SKIP_ONE_SYMBOL(sym) {\ while (!IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\ (sym)++;\ }\ while (IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\ (sym)++;\ }} #define SKIP_SPACE(sym) {\ while (IS_SPACE ((sym)[0]) && (sym)[0] != NULL_CHAR) {\ (sym)++;\ }} #define CHECK_MON_REF(p, z, m)\ if (! INITIALISED (&z)) {\ ASSERT (snprintf(edit_line, SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\ monitor_error (NO_VALUE, edit_line);\ QUIT_ON_ERROR;\ } else if (IS_NIL (z)) {\ ASSERT (snprintf(edit_line, SNPRINTF_SIZE, "%s", moid_to_string ((m), MOID_WIDTH, NO_NODE)) >= 0);\ monitor_error ("accessing NIL name", edit_line);\ QUIT_ON_ERROR;\ } #define QUIT_ON_ERROR\ if (mon_errors > 0) {\ return;\ } #define PARSE_CHECK(f, p, d)\ parse ((f), (p), (d));\ QUIT_ON_ERROR; #define SCAN_CHECK(f, p)\ scan_sym((f), (p));\ QUIT_ON_ERROR; /** @brief Confirm that we really want to quit. @return See brief description. */ static BOOL_T confirm_exit (void) { char *cmd; int k; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Terminate %s (yes|no): ", a68g_cmd_name) >= 0); WRITELN (STDOUT_FILENO, output_line); cmd = read_string_from_tty (NULL); if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) { return (confirm_exit ()); } for (k = 0; cmd[k] != NULL_CHAR; k++) { cmd[k] = (char) TO_LOWER (cmd[k]); } if (strcmp (cmd, "y") == 0) { return (A68_TRUE); } if (strcmp (cmd, "yes") == 0) { return (A68_TRUE); } if (strcmp (cmd, "n") == 0) { return (A68_FALSE); } if (strcmp (cmd, "no") == 0) { return (A68_FALSE); } return (confirm_exit ()); } /** @brief Give a monitor error message. @param msg Error message. @param info Extra information. */ void monitor_error (char *msg, char *info) { QUIT_ON_ERROR; mon_errors++; bufcpy (error_text, msg, BUFFER_SIZE); WRITELN (STDOUT_FILENO, a68g_cmd_name); WRITE (STDOUT_FILENO, ": monitor error: "); WRITE (STDOUT_FILENO, error_text); if (info != NO_TEXT) { WRITE (STDOUT_FILENO, " ("); WRITE (STDOUT_FILENO, info); WRITE (STDOUT_FILENO, ")"); } WRITE (STDOUT_FILENO, "."); } /** @brief Scan symbol from input. @param f File number. @param p Node in syntax tree. */ static void scan_sym (FILE_T f, NODE_T * p) { int k = 0; (void) f; (void) p; symbol[0] = NULL_CHAR; attr = 0; QUIT_ON_ERROR; while (IS_SPACE (expr[pos])) { pos++; } if (expr[pos] == NULL_CHAR) { attr = 0; symbol[0] = NULL_CHAR; return; } else if (expr[pos] == ':') { if (strncmp (&(expr[pos]), ":=:", 3) == 0) { pos += 3; bufcpy (symbol, ":=:", BUFFER_SIZE); attr = IS_SYMBOL; } else if (strncmp (&(expr[pos]), ":/=:", 4) == 0) { pos += 4; bufcpy (symbol, ":/=:", BUFFER_SIZE); attr = ISNT_SYMBOL; } else if (strncmp (&(expr[pos]), ":=", 2) == 0) { pos += 2; bufcpy (symbol, ":=", BUFFER_SIZE); attr = ASSIGN_SYMBOL; } else { pos++; bufcpy (symbol, ":", BUFFER_SIZE); attr = COLON_SYMBOL; } return; } else if (expr[pos] == QUOTE_CHAR) { BOOL_T cont = A68_TRUE; pos++; while (cont) { while (expr[pos] != QUOTE_CHAR) { symbol[k++] = expr[pos++]; } if (expr[++pos] == QUOTE_CHAR) { symbol[k++] = QUOTE_CHAR; } else { cont = A68_FALSE; } } symbol[k] = NULL_CHAR; attr = ROW_CHAR_DENOTATION; return; } else if (IS_LOWER (expr[pos])) { while (IS_LOWER (expr[pos]) || IS_DIGIT (expr[pos]) || IS_SPACE (expr[pos])) { if (IS_SPACE (expr[pos])) { pos++; } else { symbol[k++] = expr[pos++]; } } symbol[k] = NULL_CHAR; attr = IDENTIFIER; return; } else if (IS_UPPER (expr[pos])) { KEYWORD_T *kw; while (IS_UPPER (expr[pos])) { symbol[k++] = expr[pos++]; } symbol[k] = NULL_CHAR; kw = find_keyword (top_keyword, symbol); if (kw != NO_KEYWORD) { attr = ATTRIBUTE (kw); } else { attr = OPERATOR; } return; } else if (IS_DIGIT (expr[pos])) { while (IS_DIGIT (expr[pos])) { symbol[k++] = expr[pos++]; } if (expr[pos] == 'r') { symbol[k++] = expr[pos++]; while (IS_XDIGIT (expr[pos])) { symbol[k++] = expr[pos++]; } symbol[k] = NULL_CHAR; attr = BITS_DENOTATION; return; } if (expr[pos] != POINT_CHAR && expr[pos] != 'e' && expr[pos] != 'E') { symbol[k] = NULL_CHAR; attr = INT_DENOTATION; return; } if (expr[pos] == POINT_CHAR) { symbol[k++] = expr[pos++]; while (IS_DIGIT (expr[pos])) { symbol[k++] = expr[pos++]; } } if (expr[pos] != 'e' && expr[pos] != 'E') { symbol[k] = NULL_CHAR; attr = REAL_DENOTATION; return; } symbol[k++] = (char) TO_UPPER (expr[pos++]); if (expr[pos] == '+' || expr[pos] == '-') { symbol[k++] = expr[pos++]; } while (IS_DIGIT (expr[pos])) { symbol[k++] = expr[pos++]; } symbol[k] = NULL_CHAR; attr = REAL_DENOTATION; return; } else if (a68g_strchr (MONADS, expr[pos]) != NO_TEXT || a68g_strchr (NOMADS, expr[pos]) != NO_TEXT) { symbol[k++] = expr[pos++]; if (a68g_strchr (NOMADS, expr[pos]) != NO_TEXT) { symbol[k++] = expr[pos++]; } if (expr[pos] == ':') { symbol[k++] = expr[pos++]; if (expr[pos] == '=') { symbol[k++] = expr[pos++]; } else { symbol[k] = NULL_CHAR; monitor_error ("invalid operator symbol", symbol); } } else if (expr[pos] == '=') { symbol[k++] = expr[pos++]; if (expr[pos] == ':') { symbol[k++] = expr[pos++]; } else { symbol[k] = NULL_CHAR; monitor_error ("invalid operator symbol", symbol); } } symbol[k] = NULL_CHAR; attr = OPERATOR; return; } else if (expr[pos] == '(') { pos++; attr = OPEN_SYMBOL; return; } else if (expr[pos] == ')') { pos++; attr = CLOSE_SYMBOL; return; } else if (expr[pos] == '[') { pos++; attr = SUB_SYMBOL; return; } else if (expr[pos] == ']') { pos++; attr = BUS_SYMBOL; return; } else if (expr[pos] == ',') { pos++; attr = COMMA_SYMBOL; return; } else if (expr[pos] == ';') { pos++; attr = SEMI_SYMBOL; return; } } /** @brief Find a tag, searching symbol tables towards the root. @param table Symbol table. @param a Attribute. @param name Name of token. @return Entry in symbol table. **/ static TAG_T *find_tag (TABLE_T * table, int a, char *name) { if (table != NO_TABLE) { TAG_T *s = NO_TAG; if (a == OP_SYMBOL) { s = OPERATORS (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 { ABEND (A68_TRUE, "impossible state in find_tag_global", NO_TEXT); } for (; s != NO_TAG; FORWARD (s)) { if (strcmp (NSYMBOL (NODE (s)), name) == 0) { return (s); } } return (find_tag_global (PREVIOUS (table), a, name)); } else { return (NO_TAG); } } /** @brief Priority for symbol at input. @param f File number. @param p Node in syntax tree. @return See brief description. */ static int prio (FILE_T f, NODE_T * p) { TAG_T *s = find_tag (a68g_standenv, PRIO_SYMBOL, symbol); (void) p; (void) f; if (s == NO_TAG) { monitor_error ("unknown operator, cannot set priority", symbol); return (0); } return (PRIO (s)); } /** @brief Push a mode on the stack. @param f File number. @param m Mode to push. */ static void push_mode (FILE_T f, MOID_T * m) { (void) f; if (_m_sp < STACK_SIZE) { _m_stack[_m_sp++] = m; } else { monitor_error ("expression too complex", NO_TEXT); } } /** @brief Dereference, WEAK or otherwise. @param k Position in mode stack. @param context Context. @return Whether value can be dereferenced further. */ static BOOL_T deref_condition (int k, int context) { MOID_T *u = _m_stack[k]; if (context == WEAK && SUB (u) != NO_MOID) { MOID_T *v = SUB (u); BOOL_T stowed = (BOOL_T) (IS (v, FLEX_SYMBOL) || IS (v, ROW_SYMBOL) || IS (v, STRUCT_SYMBOL)); return ((BOOL_T) (IS (u, REF_SYMBOL) && !stowed)); } else { return ((BOOL_T) (IS (u, REF_SYMBOL))); } } /** @brief Weak dereferencing. @param p Node in syntax tree. @param k Position in mode stack. @param context Context. */ static void deref (NODE_T * p, int k, int context) { while (deref_condition (k, context)) { A68_REF z; POP_REF (p, &z); CHECK_MON_REF (p, z, _m_stack[k]); _m_stack[k] = SUB (_m_stack[k]); PUSH (p, ADDRESS (&z), SIZE (_m_stack[k])); } } /** @brief Search moid that matches indicant. @param refs Whether we look for a REF indicant. @param leng Sizety of indicant. @param indy Indicant name. @return MoiD. **/ static MOID_T *search_mode (int refs, int leng, char *indy) { MOID_T *m = NO_MOID, *z = NO_MOID; for (m = TOP_MOID (&program); m != NO_MOID; FORWARD (m)) { if (NODE (m) != NO_NODE) { if (indy == NSYMBOL (NODE (m)) && leng == DIM (m)) { z = m; while (EQUIVALENT (z) != NO_MOID) { z = EQUIVALENT (z); } } } } if (z == NO_MOID) { monitor_error ("unknown indicant", indy); return (NO_MOID); } for (m = TOP_MOID (&program); m != NO_MOID; FORWARD (m)) { int k = 0; while (IS (m, REF_SYMBOL)) { k++; m = SUB (m); } if (k == refs && m == z) { while (EQUIVALENT (z) != NO_MOID) { z = EQUIVALENT (z); } return (z); } } return (NO_MOID); } /** @brief Search operator X SYM Y. @param sym Operator name. @param x Lhs mode. @param y Rhs mode. @return Entry in symbol table. */ static TAG_T *search_operator (char *sym, MOID_T * x, MOID_T * y) { TAG_T *t; for (t = OPERATORS (a68g_standenv); t != NO_TAG; FORWARD (t)) { if (strcmp (NSYMBOL (NODE (t)), sym) == 0) { PACK_T *p = PACK (MOID (t)); if (x == MOID (p)) { FORWARD (p); if (p == NO_PACK && y == NO_MOID) { /* Matched in case of a monad */ return (t); } else if (p != NO_PACK && y != NO_MOID && y == MOID (p)) { /* Matched in case of a nomad */ return (t); } } } } /* Not found yet, try dereferencing */ if (IS (x, REF_SYMBOL)) { return (search_operator (sym, SUB (x), y)); } if (y != NO_MOID && IS (y, REF_SYMBOL)) { return (search_operator (sym, x, SUB (y))); } /* Not found. Grrrr. Give a message */ if (y == NO_MOID) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s %s", sym, moid_to_string (x, MOID_WIDTH, NO_NODE)) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s %s %s", moid_to_string (x, MOID_WIDTH, NO_NODE), sym, moid_to_string (y, MOID_WIDTH, NO_NODE)) >= 0); } monitor_error ("cannot find operator in standard environ", edit_line); return (NO_TAG); } /** @brief Search identifier in frame stack and push value. @param f File number. @param p Node in syntax tree. @param a68g_link current frame pointer @param sym Identifier name. */ static void search_identifier (FILE_T f, NODE_T * p, ADDR_T a68g_link, char *sym) { if (a68g_link > 0) { int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link); if (current_frame == 0 || (current_frame == FRAME_NUMBER (a68g_link))) { NODE_T *u = FRAME_TREE (a68g_link); if (u != NO_NODE) { TABLE_T *q = TABLE (u); TAG_T *i = IDENTIFIERS (q); for (; i != NO_TAG; FORWARD (i)) { if (strcmp (NSYMBOL (NODE (i)), sym) == 0) { ADDR_T posit = a68g_link + FRAME_INFO_SIZE + OFFSET (i); MOID_T *m = MOID (i); PUSH (p, FRAME_ADDRESS (posit), SIZE (m)); push_mode (f, m); return; } } } } search_identifier (f, p, dynamic_a68g_link, sym); } else { TABLE_T *q = a68g_standenv; TAG_T *i = IDENTIFIERS (q); for (; i != NO_TAG; FORWARD (i)) { if (strcmp (NSYMBOL (NODE (i)), sym) == 0) { if (IS (MOID (i), PROC_SYMBOL)) { static A68_PROCEDURE z; STATUS (&z) = (STATUS_MASK) (INIT_MASK | STANDENV_PROC_MASK); PROCEDURE (&(BODY (&z))) = PROCEDURE (i); ENVIRON (&z) = 0; LOCALE (&z) = NO_HANDLE; MOID (&z) = MOID (i); PUSH_PROCEDURE (p, z); } else { (*(PROCEDURE (i))) (p); } push_mode (f, MOID (i)); return; } } monitor_error ("cannot find identifier", sym); } } /** @brief Coerce arguments in a call. @param f File number. @param p Node in syntax tree. @param proc MODE of procedure. @param bot Argument count. @param top Argument count. @param top_sp Value to restore stack pointer. */ static void coerce_arguments (FILE_T f, NODE_T * p, MOID_T * proc, int bot, int top, int top_sp) { int k; PACK_T *u; ADDR_T sp_2 = top_sp; (void) f; if ((top - bot) != DIM (proc)) { monitor_error ("invalid procedure argument count", NO_TEXT); } QUIT_ON_ERROR; for (k = bot, u = PACK (proc); k < top; k++, FORWARD (u)) { if (_m_stack[k] == MOID (u)) { PUSH (p, STACK_ADDRESS (sp_2), SIZE (MOID (u))); sp_2 += SIZE (MOID (u)); } else if (IS (_m_stack[k], REF_SYMBOL)) { A68_REF *v = (A68_REF *) STACK_ADDRESS (sp_2); PUSH_REF (p, *v); sp_2 += A68_REF_SIZE; deref (p, k, STRONG); if (_m_stack[k] != MOID (u)) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s to %s", moid_to_string (_m_stack[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0); monitor_error ("invalid argument mode", edit_line); } } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s to %s", moid_to_string (_m_stack[k], MOID_WIDTH, NO_NODE), moid_to_string (MOID (u), MOID_WIDTH, NO_NODE)) >= 0); monitor_error ("cannot coerce argument", edit_line); } QUIT_ON_ERROR; } MOVE (STACK_ADDRESS (top_sp), STACK_ADDRESS (sp_2), stack_pointer - sp_2); stack_pointer = top_sp + (stack_pointer - sp_2); } /** @brief Perform a selection. @param f File number. @param p Node in syntax tree. @param field Field name. */ static void selection (FILE_T f, NODE_T * p, char *field) { BOOL_T name; MOID_T *moid; PACK_T *u, *v; SCAN_CHECK (f, p); if (attr != IDENTIFIER && attr != OPEN_SYMBOL) { monitor_error ("invalid selection syntax", NO_TEXT); } QUIT_ON_ERROR; PARSE_CHECK (f, p, MAX_PRIORITY + 1); deref (p, _m_sp - 1, WEAK); if (IS (TOP_MODE, REF_SYMBOL)) { name = A68_TRUE; u = PACK (NAME (TOP_MODE)); moid = SUB (_m_stack[--_m_sp]); v = PACK (moid); } else { name = A68_FALSE; moid = _m_stack[--_m_sp]; u = PACK (moid); v = PACK (moid); } if (ISNT (moid, STRUCT_SYMBOL)) { monitor_error ("invalid selection mode", moid_to_string (moid, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; for (; u != NO_PACK; FORWARD (u), FORWARD (v)) { if (strcmp (field, TEXT (u)) == 0) { if (name) { A68_REF *z = (A68_REF *) (STACK_OFFSET (-A68_REF_SIZE)); CHECK_MON_REF (p, *z, moid); OFFSET (z) += OFFSET (v); } else { DECREMENT_STACK_POINTER (p, SIZE (moid)); MOVE (STACK_TOP, STACK_OFFSET (OFFSET (v)), (unsigned) SIZE (MOID (u))); INCREMENT_STACK_POINTER (p, SIZE (MOID (u))); } push_mode (f, MOID (u)); return; } } monitor_error ("invalid field name", field); } /** @brief Perform a call. @param f File number. @param p Node in syntax tree. @param depth Recursion depth. */ static void call (FILE_T f, NODE_T * p, int depth) { A68_PROCEDURE z; NODE_T q; int args, old_m_sp; ADDR_T top_sp; MOID_T *proc; (void) depth; QUIT_ON_ERROR; deref (p, _m_sp - 1, STRONG); proc = _m_stack[--_m_sp]; old_m_sp = _m_sp; if (ISNT (proc, PROC_SYMBOL)) { monitor_error ("invalid procedure mode", moid_to_string (proc, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP_PROCEDURE (p, &z); args = _m_sp; top_sp = stack_pointer; if (attr == OPEN_SYMBOL) { do { SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); } while (attr == COMMA_SYMBOL); if (attr != CLOSE_SYMBOL) { monitor_error ("unmatched parenthesis", NO_TEXT); } SCAN_CHECK (f, p); } coerce_arguments (f, p, proc, args, _m_sp, top_sp); if (STATUS (&z) & STANDENV_PROC_MASK) { MOID (&q) = _m_stack[--_m_sp]; INFO (&q) = INFO (p); NSYMBOL (&q) = NSYMBOL (p); (void) ((*PROCEDURE (&(BODY (&z)))) (&q)); _m_sp = old_m_sp; push_mode (f, SUB_MOID (&z)); } else { monitor_error ("can only call standard environ routines", NO_TEXT); } } /** @brief Perform a slice. @param f File number. @param p Node in syntax tree. @param depth Recursion depth. */ static void slice (FILE_T f, NODE_T * p, int depth) { MOID_T *moid, *res; A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; ADDR_T address; int dim, k, iindex, args; BOOL_T name; (void) depth; QUIT_ON_ERROR; deref (p, _m_sp - 1, WEAK); if (IS (TOP_MODE, REF_SYMBOL)) { name = A68_TRUE; res = NAME (TOP_MODE); deref (p, _m_sp - 1, STRONG); moid = _m_stack[--_m_sp]; } else { name = A68_FALSE; moid = _m_stack[--_m_sp]; res = SUB (moid); } if (ISNT (moid, ROW_SYMBOL) && ISNT (moid, FLEX_SYMBOL)) { monitor_error ("invalid row mode", moid_to_string (moid, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; /* Get descriptor */ POP_REF (p, &z); CHECK_MON_REF (p, z, moid); GET_DESCRIPTOR (arr, tup, &z); if (IS (moid, FLEX_SYMBOL)) { dim = DIM (SUB (moid)); } else { dim = DIM (moid); } /* Get iindexer */ args = _m_sp; if (attr == SUB_SYMBOL) { do { SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); } while (attr == COMMA_SYMBOL); if (attr != BUS_SYMBOL) { monitor_error ("unmatched parenthesis", NO_TEXT); } SCAN_CHECK (f, p); } if ((_m_sp - args) != dim) { monitor_error ("invalid slice index count", NO_TEXT); } QUIT_ON_ERROR; for (k = 0, iindex = 0; k < dim; k++, _m_sp--) { A68_TUPLE *t = &(tup[dim - k - 1]); A68_INT i; deref (p, _m_sp - 1, MEEK); if (TOP_MODE != MODE (INT)) { monitor_error ("invalid indexer mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP_OBJECT (p, &i, A68_INT); if (VALUE (&i) < LOWER_BOUND (t) || VALUE (&i) > UPPER_BOUND (t)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } QUIT_ON_ERROR; iindex += SPAN (t) * VALUE (&i) - SHIFT (t); } address = ROW_ELEMENT (arr, iindex); if (name) { z = ARRAY (arr); OFFSET (&z) += address; REF_SCOPE (&z) = PRIMAL_SCOPE; PUSH_REF (p, z); } else { PUSH (p, ADDRESS (&(ARRAY (arr))) + address, SIZE (res)); } push_mode (f, res); } /** @brief Perform a call or a slice. @param f File number. @param p Node in syntax tree. @param depth Recursion depth. */ static void call_or_slice (FILE_T f, NODE_T * p, int depth) { while (attr == OPEN_SYMBOL || attr == SUB_SYMBOL) { QUIT_ON_ERROR; if (attr == OPEN_SYMBOL) { call (f, p, depth); } else if (attr == SUB_SYMBOL) { slice (f, p, depth); } } } /** @brief Parse expression on input. @param f File number. @param p Node in syntax tree. @param depth Recursion depth. */ static void parse (FILE_T f, NODE_T * p, int depth) { LOW_STACK_ALERT (p); QUIT_ON_ERROR; if (depth <= MAX_PRIORITY) { if (depth == 0) { /* Identity relations */ PARSE_CHECK (f, p, 1); while (attr == IS_SYMBOL || attr == ISNT_SYMBOL) { A68_REF x, y; BOOL_T res; int op = attr; if (TOP_MODE != MODE (HIP) && ISNT (TOP_MODE, REF_SYMBOL)) { monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 1); if (TOP_MODE != MODE (HIP) && ISNT (TOP_MODE, REF_SYMBOL)) { monitor_error ("identity relation operand must yield a name", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; if (TOP_MODE != MODE (HIP) && _m_stack[_m_sp - 2] != MODE (HIP)) { if (TOP_MODE != _m_stack[_m_sp - 2]) { monitor_error ("invalid identity relation operand mode", NO_TEXT); } } QUIT_ON_ERROR; _m_sp -= 2; POP_REF (p, &y); POP_REF (p, &x); res = (BOOL_T) (ADDRESS (&x) == ADDRESS (&y)); PUSH_PRIMITIVE (p, (BOOL_T) (op == IS_SYMBOL ? res : !res), A68_BOOL); push_mode (f, MODE (BOOL)); } } else { /* Dyadic expressions */ PARSE_CHECK (f, p, depth + 1); while (attr == OPERATOR && prio (f, p) == depth) { int args; ADDR_T top_sp; NODE_T q; TAG_T *opt; char name[BUFFER_SIZE]; bufcpy (name, symbol, BUFFER_SIZE); args = _m_sp - 1; top_sp = stack_pointer - SIZE (_m_stack[args]); SCAN_CHECK (f, p); PARSE_CHECK (f, p, depth + 1); opt = search_operator (name, _m_stack[_m_sp - 2], TOP_MODE); QUIT_ON_ERROR; coerce_arguments (f, p, MOID (opt), args, _m_sp, top_sp); _m_sp -= 2; MOID (&q) = MOID (opt); INFO (&q) = INFO (p); NSYMBOL (&q) = NSYMBOL (p); (void) ((*(PROCEDURE (opt)))) (&q); push_mode (f, SUB_MOID (opt)); } } } else if (attr == OPERATOR) { int args; ADDR_T top_sp; NODE_T q; TAG_T *opt; char name[BUFFER_SIZE]; bufcpy (name, symbol, BUFFER_SIZE); args = _m_sp; top_sp = stack_pointer; SCAN_CHECK (f, p); PARSE_CHECK (f, p, depth); opt = search_operator (name, TOP_MODE, NO_MOID); QUIT_ON_ERROR; coerce_arguments (f, p, MOID (opt), args, _m_sp, top_sp); _m_sp--; MOID (&q) = MOID (opt); INFO (&q) = INFO (p); NSYMBOL (&q) = NSYMBOL (p); (void) ((*(PROCEDURE (opt))) (&q)); push_mode (f, SUB_MOID (opt)); } else if (attr == REF_SYMBOL) { int refs = 0, length = 0; MOID_T *m = NO_MOID; while (attr == REF_SYMBOL) { refs++; SCAN_CHECK (f, p); } while (attr == LONG_SYMBOL) { length++; SCAN_CHECK (f, p); } m = search_mode (refs, length, symbol); QUIT_ON_ERROR; if (m == NO_MOID) { monitor_error ("unknown reference to mode", NO_TEXT); } SCAN_CHECK (f, p); if (attr != OPEN_SYMBOL) { monitor_error ("cast expects open-symbol", NO_TEXT); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); if (attr != CLOSE_SYMBOL) { monitor_error ("cast expects close-symbol", NO_TEXT); } SCAN_CHECK (f, p); while (IS (TOP_MODE, REF_SYMBOL) && TOP_MODE != m) { MOID_T *sub = SUB (TOP_MODE); A68_REF z; POP_REF (p, &z); CHECK_MON_REF (p, z, TOP_MODE); PUSH (p, ADDRESS (&z), SIZE (sub)); TOP_MODE = sub; } if (TOP_MODE != m) { monitor_error ("invalid cast mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } } else if (attr == LONG_SYMBOL) { int length = 0; MOID_T *m; while (attr == LONG_SYMBOL) { length++; SCAN_CHECK (f, p); } /* Cast L INT -> L REAL */ if (attr == REAL_SYMBOL) { MOID_T *i = (length == 1 ? MODE (LONG_INT) : MODE (LONGLONG_INT)); MOID_T *r = (length == 1 ? MODE (LONG_REAL) : MODE (LONGLONG_REAL)); SCAN_CHECK (f, p); if (attr != OPEN_SYMBOL) { monitor_error ("cast expects open-symbol", NO_TEXT); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); if (attr != CLOSE_SYMBOL) { monitor_error ("cast expects close-symbol", NO_TEXT); } SCAN_CHECK (f, p); if (TOP_MODE != i) { monitor_error ("invalid cast argument mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; TOP_MODE = r; return; } /* L INT or L REAL denotation */ if (attr == INT_DENOTATION) { m = (length == 1 ? MODE (LONG_INT) : MODE (LONGLONG_INT)); } else if (attr == REAL_DENOTATION) { m = (length == 1 ? MODE (LONG_REAL) : MODE (LONGLONG_REAL)); } else if (attr == BITS_DENOTATION) { m = (length == 1 ? MODE (LONG_BITS) : MODE (LONGLONG_BITS)); } else { m = NO_MOID; } if (m != NO_MOID) { int digits = DIGITS (m); MP_T *z; STACK_MP (z, p, digits); if (genie_string_to_value_internal (p, m, symbol, (BYTE_T *) z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m); exit_genie (p, A68_RUNTIME_ERROR); } z[0] = (MP_T) (INIT_MASK | CONSTANT_MASK); push_mode (f, m); SCAN_CHECK (f, p); } else { monitor_error ("invalid mode", NO_TEXT); } } else if (attr == INT_DENOTATION) { A68_INT z; if (genie_string_to_value_internal (p, MODE (INT), symbol, (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, VALUE (&z), A68_INT); push_mode (f, MODE (INT)); SCAN_CHECK (f, p); } else if (attr == REAL_DENOTATION) { A68_REAL z; if (genie_string_to_value_internal (p, MODE (REAL), symbol, (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (REAL)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, VALUE (&z), A68_REAL); push_mode (f, MODE (REAL)); SCAN_CHECK (f, p); } else if (attr == BITS_DENOTATION) { A68_BITS z; if (genie_string_to_value_internal (p, MODE (BITS), symbol, (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (BITS)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, VALUE (&z), A68_BITS); push_mode (f, MODE (BITS)); SCAN_CHECK (f, p); } else if (attr == ROW_CHAR_DENOTATION) { if (strlen (symbol) == 1) { PUSH_PRIMITIVE (p, symbol[0], A68_CHAR); push_mode (f, MODE (CHAR)); } else { A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; z = c_to_a_string (p, symbol, DEFAULT_WIDTH); GET_DESCRIPTOR (arr, tup, &z); BLOCK_GC_HANDLE (&z); BLOCK_GC_HANDLE (&(ARRAY (arr))); PUSH_REF (p, z); push_mode (f, MODE (STRING)); } SCAN_CHECK (f, p); } else if (attr == TRUE_SYMBOL) { PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); push_mode (f, MODE (BOOL)); SCAN_CHECK (f, p); } else if (attr == FALSE_SYMBOL) { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); push_mode (f, MODE (BOOL)); SCAN_CHECK (f, p); } else if (attr == NIL_SYMBOL) { PUSH_REF (p, nil_ref); push_mode (f, MODE (HIP)); SCAN_CHECK (f, p); } else if (attr == REAL_SYMBOL) { A68_INT k; SCAN_CHECK (f, p); if (attr != OPEN_SYMBOL) { monitor_error ("cast expects open-symbol", NO_TEXT); } SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); if (attr != CLOSE_SYMBOL) { monitor_error ("cast expects close-symbol", NO_TEXT); } SCAN_CHECK (f, p); if (TOP_MODE != MODE (INT)) { monitor_error ("invalid cast argument mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP_OBJECT (p, &k, A68_INT); PUSH_PRIMITIVE (p, (double) VALUE (&k), A68_REAL); TOP_MODE = MODE (REAL); } else if (attr == IDENTIFIER) { ADDR_T old_sp = stack_pointer; BOOL_T init; MOID_T *moid; char name[BUFFER_SIZE]; bufcpy (name, symbol, BUFFER_SIZE); SCAN_CHECK (f, p); if (attr == OF_SYMBOL) { selection (f, p, name); } else { search_identifier (f, p, frame_pointer, name); QUIT_ON_ERROR; call_or_slice (f, p, depth); } moid = TOP_MODE; QUIT_ON_ERROR; if (check_initialisation (p, STACK_ADDRESS (old_sp), moid, &init)) { if (init == A68_FALSE) { monitor_error (NO_VALUE, name); } } else { monitor_error ("cannot process value of mode", moid_to_string (moid, MOID_WIDTH, NO_NODE)); } } else if (attr == OPEN_SYMBOL) { do { SCAN_CHECK (f, p); PARSE_CHECK (f, p, 0); } while (attr == COMMA_SYMBOL); if (attr != CLOSE_SYMBOL) { monitor_error ("unmatched parenthesis", NO_TEXT); } SCAN_CHECK (f, p); call_or_slice (f, p, depth); } else { monitor_error ("invalid expression syntax", NO_TEXT); } } /** @brief Perform assignment. @param f File number. @param p Node in syntax tree. */ static void assign (FILE_T f, NODE_T * p) { LOW_STACK_ALERT (p); PARSE_CHECK (f, p, 0); if (attr == ASSIGN_SYMBOL) { MOID_T *m = _m_stack[--_m_sp]; A68_REF z; if (ISNT (m, REF_SYMBOL)) { monitor_error ("invalid destination mode", moid_to_string (m, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP_REF (p, &z); CHECK_MON_REF (p, z, m); SCAN_CHECK (f, p); assign (f, p); QUIT_ON_ERROR; while (IS (TOP_MODE, REF_SYMBOL) && TOP_MODE != SUB (m)) { MOID_T *sub = SUB (TOP_MODE); A68_REF y; POP_REF (p, &y); CHECK_MON_REF (p, y, TOP_MODE); PUSH (p, ADDRESS (&y), SIZE (sub)); TOP_MODE = sub; } if (TOP_MODE != SUB (m) && TOP_MODE != MODE (HIP)) { monitor_error ("invalid source mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); } QUIT_ON_ERROR; POP (p, ADDRESS (&z), SIZE (TOP_MODE)); PUSH_REF (p, z); TOP_MODE = m; } } /** @brief Evaluate expression on input. @param f File number. @param p Node in syntax tree. @param str Expression string. */ static void evaluate (FILE_T f, NODE_T * p, char *str) { LOW_STACK_ALERT (p); _m_sp = 0; _m_stack[0] = NO_MOID; pos = 0; bufcpy (expr, str, BUFFER_SIZE); SCAN_CHECK (f, p); QUIT_ON_ERROR; assign (f, p); if (attr != 0) { monitor_error ("trailing character in expression", symbol); } } /** @brief Convert string to int. @param num Number to convert. @param rest Pointer to rest. @return Int value or NOT_A_NUM if we cannot. */ static int get_num_arg (char *num, char **rest) { char *end; int k; if (rest != NO_VAR) { *rest = NO_TEXT; } if (num == NO_TEXT) { return (NOT_A_NUM); } SKIP_ONE_SYMBOL (num); if (IS_DIGIT (num[0])) { RESET_ERRNO; k = (int) a68g_strtoul (num, &end, 10); if (end != num && errno == 0) { if (rest != NO_VAR) { *rest = end; } return (k); } else { monitor_error ("invalid numerical argument", error_specification ()); return (NOT_A_NUM); } } else { if (num[0] != NULL_CHAR) { monitor_error ("invalid numerical argument", num); } return (NOT_A_NUM); } } /** @brief Whether item at "w" of mode "q" is initialised. @param p Node in syntax tree. @param w Pointer to object. @param q Moid of object. @param result Whether object is initialised. @return Whether mode of object is recognised. **/ static BOOL_T check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q, BOOL_T * result) { BOOL_T initialised = A68_FALSE, recognised = A68_FALSE; (void) p; switch (SHORT_ID (q)) { case MODE_NO_CHECK: case UNION_SYMBOL: { initialised = A68_TRUE; recognised = A68_TRUE; break; } case REF_SYMBOL: { A68_REF *z = (A68_REF *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case PROC_SYMBOL: { A68_PROCEDURE *z = (A68_PROCEDURE *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_INT: { A68_INT *z = (A68_INT *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_REAL: { A68_REAL *z = (A68_REAL *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_COMPLEX: { A68_REAL *r = (A68_REAL *) w; A68_REAL *i = (A68_REAL *) (w + SIZE_AL (A68_REAL)); initialised = (BOOL_T) (INITIALISED (r) && INITIALISED (i)); recognised = A68_TRUE; break; } case MODE_LONG_INT: case MODE_LONG_REAL: case MODE_LONG_BITS: { MP_T *z = (MP_T *) w; initialised = (BOOL_T) ((unsigned) z[0] & INIT_MASK); recognised = A68_TRUE; break; } case MODE_LONGLONG_INT: case MODE_LONGLONG_REAL: case MODE_LONGLONG_BITS: { MP_T *z = (MP_T *) w; initialised = (BOOL_T) ((unsigned) z[0] & INIT_MASK); recognised = A68_TRUE; break; } case MODE_LONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_long_mp ()); initialised = (BOOL_T) (((unsigned) r[0] & INIT_MASK) && ((unsigned) i[0] & INIT_MASK)); recognised = A68_TRUE; break; } case MODE_LONGLONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_long_mp ()); initialised = (BOOL_T) (((unsigned) r[0] & INIT_MASK) && ((unsigned) i[0] & INIT_MASK)); recognised = A68_TRUE; break; } case MODE_BOOL: { A68_BOOL *z = (A68_BOOL *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_CHAR: { A68_CHAR *z = (A68_CHAR *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_BITS: { A68_BITS *z = (A68_BITS *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_BYTES: { A68_BYTES *z = (A68_BYTES *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_LONG_BYTES: { A68_LONG_BYTES *z = (A68_LONG_BYTES *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_FILE: { A68_FILE *z = (A68_FILE *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_FORMAT: { A68_FORMAT *z = (A68_FORMAT *) w; initialised = INITIALISED (z); recognised = A68_TRUE; break; } case MODE_PIPE: { A68_REF *pipe_read = (A68_REF *) w; A68_REF *pipe_write = (A68_REF *) (w + A68_REF_SIZE); A68_INT *pid = (A68_INT *) (w + 2 * A68_REF_SIZE); initialised = (BOOL_T) (INITIALISED (pipe_read) && INITIALISED (pipe_write) && INITIALISED (pid)); recognised = A68_TRUE; break; } case MODE_SOUND: { A68_SOUND *z = (A68_SOUND *) w; initialised = INITIALISED (z); recognised = A68_TRUE; } } if (result != NO_BOOL) { *result = initialised; } return (recognised); } /** @brief Show value of object. @param p Node in syntax tree. @param f File number. @param item Pointer to object. @param mode Mode of object. **/ void print_item (NODE_T * p, FILE_T f, BYTE_T * item, MOID_T * mode) { A68_REF nil_file = nil_ref; reset_transput_buffer (UNFORMATTED_BUFFER); genie_write_standard (p, mode, item, nil_file); if (get_transput_buffer_index (UNFORMATTED_BUFFER) > 0) { if (mode == MODE (CHAR) || mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " \"%s\"", get_transput_buffer (UNFORMATTED_BUFFER)) >= 0); WRITE (f, output_line); } else { char *str = get_transput_buffer (UNFORMATTED_BUFFER); while (IS_SPACE (str[0])) { str++; } ASSERT (snprintf (output_line, SNPRINTF_SIZE, " %s", str) >= 0); WRITE (f, output_line); } } else { WRITE (f, CANNOT_SHOW); } } /** @brief Indented indent_crlf. @param f File number. **/ static void indent_crlf (FILE_T f) { int k; io_close_tty_line (); for (k = 0; k < tabs; k++) { WRITE (f, " "); } } /** @brief Show value of object. @param p Node in syntax tree. @param f File number. @param item Pointer to object. @param mode Mode of object. **/ static void show_item (FILE_T f, NODE_T * p, BYTE_T * item, MOID_T * mode) { if (item == NO_BYTE || mode == NO_MOID) { return; } if (IS (mode, REF_SYMBOL)) { A68_REF *z = (A68_REF *) item; if (IS_NIL (*z)) { if (INITIALISED (z)) { WRITE (STDOUT_FILENO, " = NIL"); } else { WRITE (STDOUT_FILENO, NO_VALUE); } } else { if (INITIALISED (z)) { WRITE (STDOUT_FILENO, " refers to "); if (IS_IN_HEAP (z)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "heap(%p)", ADDRESS (z)) >= 0); WRITE (STDOUT_FILENO, output_line); tabs++; show_item (f, p, ADDRESS (z), SUB (mode)); tabs--; } else if (IS_IN_FRAME (z)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "frame(%d)", REF_OFFSET (z)) >= 0); WRITE (STDOUT_FILENO, output_line); } else if (IS_IN_STACK (z)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "stack(%d)", REF_OFFSET (z)) >= 0); WRITE (STDOUT_FILENO, output_line); } } else { WRITE (STDOUT_FILENO, NO_VALUE); } } } else if (mode == MODE (STRING)) { if (!INITIALISED ((A68_REF *) item)) { WRITE (STDOUT_FILENO, NO_VALUE); } else { print_item (p, f, item, mode); } } else if ((IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) && mode != MODE (STRING)) { MOID_T *deflexed = DEFLEX (mode); int old_tabs = tabs; tabs += 2; if (!INITIALISED ((A68_REF *) item)) { WRITE (STDOUT_FILENO, NO_VALUE); } else { A68_ARRAY *arr; A68_TUPLE *tup; int count = 0, act_count = 0, elems; GET_DESCRIPTOR (arr, tup, (A68_REF *) item); elems = get_row_size (tup, DIM (arr)); ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", %d element(s)", elems) >= 0); WRITE (f, output_line); if (get_row_size (tup, DIM (arr)) != 0) { BYTE_T *base_addr = ADDRESS (&ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done && ++count <= (max_row_elems + 1)) { if (count <= max_row_elems) { ADDR_T row_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, row_index); BYTE_T *elem = &base_addr[elem_addr]; indent_crlf (f); WRITE (f, "["); print_internal_index (f, tup, DIM (arr)); WRITE (f, "]"); show_item (f, p, elem, SUB (deflexed)); act_count++; done = increment_internal_index (tup, DIM (arr)); } } indent_crlf (f); ASSERT (snprintf (output_line, SNPRINTF_SIZE, " %d element(s) written (%d%%)", act_count, (int) ((100.0 * act_count) / elems)) >= 0); WRITE (f, output_line); } } tabs = old_tabs; } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); tabs++; for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; indent_crlf (f); ASSERT (snprintf (output_line, SNPRINTF_SIZE, " %s \"%s\"", moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), TEXT (q)) >= 0); WRITE (STDOUT_FILENO, output_line); show_item (f, p, elem, MOID (q)); } tabs--; } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; ASSERT (snprintf (output_line, SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, output_line); show_item (f, p, &item[SIZE_AL (A68_UNION)], (MOID_T *) (VALUE (z))); } else if (mode == MODE (SIMPLIN)) { A68_UNION *z = (A68_UNION *) item; ASSERT (snprintf (output_line, SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, output_line); } else if (mode == MODE (SIMPLOUT)) { A68_UNION *z = (A68_UNION *) item; ASSERT (snprintf (output_line, SNPRINTF_SIZE, " united-moid %s", moid_to_string ((MOID_T *) (VALUE (z)), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, output_line); } else { BOOL_T init; if (check_initialisation (p, item, mode, &init)) { if (init) { if (IS (mode, PROC_SYMBOL)) { A68_PROCEDURE *z = (A68_PROCEDURE *) item; if (z != NO_PROCEDURE && STATUS (z) & STANDENV_PROC_MASK) { char *fname = standard_environ_proc_name (*(PROCEDURE (&BODY (z)))); WRITE (STDOUT_FILENO, " standenv procedure"); if (fname != NO_TEXT) { WRITE (STDOUT_FILENO, " ("); WRITE (STDOUT_FILENO, fname); WRITE (STDOUT_FILENO, ")"); } } else if (z != NO_PROCEDURE && STATUS (z) & SKIP_PROCEDURE_MASK) { WRITE (STDOUT_FILENO, " skip procedure"); } else if (z != NO_PROCEDURE && (PROCEDURE (&BODY (z))) != NO_GPROC) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " line %d, environ at frame(%d), locale %p", LINE_NUMBER ((NODE_T *) NODE (&BODY (z))), ENVIRON (z), (void *) LOCALE (z)) >= 0); WRITE (STDOUT_FILENO, output_line); } else { WRITE (STDOUT_FILENO, " cannot show value"); } } else if (mode == MODE (FORMAT)) { A68_FORMAT *z = (A68_FORMAT *) item; if (z != NO_FORMAT && BODY (z) != NO_NODE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " line %d, environ at frame(%d)", LINE_NUMBER (BODY (z)), ENVIRON (z)) >= 0); WRITE (STDOUT_FILENO, output_line); } else { monitor_error (CANNOT_SHOW, NO_TEXT); } } else if (mode == MODE (SOUND)) { A68_SOUND *z = (A68_SOUND *) item; if (z != NO_SOUND) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%u channels, %u bits, %u rate, %u samples", NUM_CHANNELS (z), BITS_PER_SAMPLE (z), SAMPLE_RATE (z), NUM_SAMPLES (z)) >= 0); WRITE (STDOUT_FILENO, output_line); } else { monitor_error (CANNOT_SHOW, NO_TEXT); } } else { print_item (p, f, item, mode); } } else { WRITE (STDOUT_FILENO, NO_VALUE); } } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " mode %s, %s", moid_to_string (mode, MOID_WIDTH, NO_NODE), CANNOT_SHOW) >= 0); WRITE (STDOUT_FILENO, output_line); } } } /** @brief Overview of frame item. @param f File number. @param p Node in syntax tree. @param a68g_link current frame pointer @param q Tag. @param modif Output modifier. **/ static void show_frame_item (FILE_T f, NODE_T * p, ADDR_T a68g_link, TAG_T * q, int modif) { ADDR_T addr = a68g_link + FRAME_INFO_SIZE + OFFSET (q); ADDR_T loc = FRAME_INFO_SIZE + OFFSET (q); (void) p; indent_crlf (STDOUT_FILENO); if (modif != ANONYMOUS) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " frame(%d=%d+%d) %s \"%s\"", addr, a68g_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE), NSYMBOL (NODE (q))) >= 0); WRITE (STDOUT_FILENO, output_line); show_item (f, p, FRAME_ADDRESS (addr), MOID (q)); } else { switch (PRIO (q)) { case GENERATOR: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " frame(%d=%d+%d) LOC %s", addr, a68g_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, output_line); break; } default: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " frame(%d=%d+%d) internal %s", addr, a68g_link, loc, moid_to_string (MOID (q), MOID_WIDTH, NO_NODE)) >= 0); WRITE (STDOUT_FILENO, output_line); break; } } show_item (f, p, FRAME_ADDRESS (addr), MOID (q)); } } /** @brief Overview of frame items. @param f File number. @param p Node in syntax tree. @param a68g_link current frame pointer @param q Tag. @param modif Output modifier. **/ static void show_frame_items (FILE_T f, NODE_T * p, ADDR_T a68g_link, TAG_T * q, int modif) { (void) p; for (; q != NO_TAG; FORWARD (q)) { show_frame_item (f, p, a68g_link, q, modif); } } /** @brief Introduce stack frame. @param f File number. @param p Node in syntax tree. @param a68g_link current frame pointer @param printed Printed item counter. **/ static void intro_frame (FILE_T f, NODE_T * p, ADDR_T a68g_link, int *printed) { TABLE_T *q = TABLE (p); if (*printed > 0) { WRITELN (f, ""); } (*printed)++; where_in_source (f, p); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Stack frame %d at frame(%d), level=%d, size=%d bytes", FRAME_NUMBER (a68g_link), a68g_link, LEVEL (q), FRAME_INCREMENT (a68g_link) + FRAME_INFO_SIZE) >= 0); WRITELN (f, output_line); } /** @brief View contents of stack frame. @param f File number. @param p Node in syntax tree. @param a68g_link current frame pointer @param printed Printed item counter. **/ static void show_stack_frame (FILE_T f, NODE_T * p, ADDR_T a68g_link, int *printed) { /* show the frame starting at frame pointer 'a68g_link', using symbol table from p as a map */ if (p != NO_NODE) { TABLE_T *q = TABLE (p); intro_frame (f, p, a68g_link, printed); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Dynamic link=frame(%d), static link=frame(%d), parameters=frame(%d)", FRAME_DYNAMIC_LINK (a68g_link), FRAME_STATIC_LINK (a68g_link), FRAME_PARAMETERS (a68g_link)) >= 0); WRITELN (STDOUT_FILENO, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Procedure frame=%s", (FRAME_PROC_FRAME (a68g_link) ? "yes" : "no")) >= 0); WRITELN (STDOUT_FILENO, output_line); #if defined HAVE_PARALLEL_CLAUSE if (pthread_equal (FRAME_THREAD_ID (a68g_link), main_thread_id) != 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "In main thread") >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Not in main thread") >= 0); } WRITELN (STDOUT_FILENO, output_line); #endif show_frame_items (f, p, a68g_link, IDENTIFIERS (q), IDENTIFIER); show_frame_items (f, p, a68g_link, OPERATORS (q), OPERATOR); show_frame_items (f, p, a68g_link, ANONYMOUS (q), ANONYMOUS); } } /** @brief Shows lines around the line where 'p' is at. @param f File number. @param p Node in syntax tree. @param n First line number. @param m Last line number. **/ static void list (FILE_T f, NODE_T * p, int n, int m) { if (p != NO_NODE) { if (m == 0) { LINE_T *r = LINE (INFO (p)); LINE_T *l = TOP_LINE (&program); for (; l != NO_LINE; FORWARD (l)) { if (NUMBER (l) > 0 && abs (NUMBER (r) - NUMBER (l)) <= n) { write_source_line (f, l, NO_NODE, A68_TRUE); } } } else { LINE_T *l = TOP_LINE (&program); for (; l != NO_LINE; FORWARD (l)) { if (NUMBER (l) > 0 && NUMBER (l) >= n && NUMBER (l) <= m) { write_source_line (f, l, NO_NODE, A68_TRUE); } } } } } /** @brief Overview of the heap. @param f File number. @param p Node in syntax tree. @param z Handle where to start. @param top Maximum size. @param n Number of handles to print. **/ void show_heap (FILE_T f, NODE_T * p, A68_HANDLE * z, int top, int n) { int k = 0, m = n, sum = 0; (void) p; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "size=%d available=%d garbage collections=%d", heap_size, heap_available (), garbage_collects) >= 0); WRITELN (f, output_line); for (; z != NO_HANDLE; FORWARD (z), k++) { if (n > 0 && sum <= top) { n--; indent_crlf (f); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "heap(%p+%d) %s", POINTER (z), SIZE (z), moid_to_string (MOID (z), MOID_WIDTH, NO_NODE)) >= 0); WRITE (f, output_line); sum += SIZE (z); } } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "printed %d out of %d handles", m, k) >= 0); WRITELN (f, output_line); } /** @brief Search current frame and print it. @param f File number. @param a68g_link current frame pointer **/ void stack_dump_current (FILE_T f, ADDR_T a68g_link) { if (a68g_link > 0) { int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link); NODE_T *p = FRAME_TREE (a68g_link); if (p != NO_NODE && LEVEL (TABLE (p)) > 3) { if (FRAME_NUMBER (a68g_link) == current_frame) { int printed = 0; show_stack_frame (f, p, a68g_link, &printed); } else { stack_dump_current (f, dynamic_a68g_link); } } } } /** @brief Overview of the stack. @param f File number. @param a68g_link current frame pointer @param depth Number of frames left to print. @param printed Counts items printed. **/ void stack_a68g_link_dump (FILE_T f, ADDR_T a68g_link, int depth, int *printed) { if (depth > 0 && a68g_link > 0) { NODE_T *p = FRAME_TREE (a68g_link); if (p != NO_NODE && LEVEL (TABLE (p)) > 3) { show_stack_frame (f, p, a68g_link, printed); stack_a68g_link_dump (f, FRAME_STATIC_LINK (a68g_link), depth - 1, printed); } } } /** @brief Overview of the stack. @param f File number. @param a68g_link current frame pointer @param depth Number of frames left to print. @param printed Counts items printed. **/ void stack_dump (FILE_T f, ADDR_T a68g_link, int depth, int *printed) { if (depth > 0 && a68g_link > 0) { NODE_T *p = FRAME_TREE (a68g_link); if (p != NO_NODE && LEVEL (TABLE (p)) > 3) { show_stack_frame (f, p, a68g_link, printed); stack_dump (f, FRAME_DYNAMIC_LINK (a68g_link), depth - 1, printed); } } } /** @brief Overview of the stack. @param f File number. @param a68g_link current frame pointer @param depth Number of frames left to print. @param printed Counts items printed. **/ void stack_trace (FILE_T f, ADDR_T a68g_link, int depth, int *printed) { if (depth > 0 && a68g_link > 0) { int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link); if (FRAME_PROC_FRAME (a68g_link)) { NODE_T *p = FRAME_TREE (a68g_link); show_stack_frame (f, p, a68g_link, printed); stack_trace (f, dynamic_a68g_link, depth - 1, printed); } else { stack_trace (f, dynamic_a68g_link, depth, printed); } } } /** @brief Examine tags. @param f File number. @param p Node in syntax tree. @param a68g_link Current frame pointer. @param q Tag. @param sym Symbol name. @param printed Counts items printed. **/ void examine_tags (FILE_T f, NODE_T * p, ADDR_T a68g_link, TAG_T * q, char *sym, int *printed) { for (; q != NO_TAG; FORWARD (q)) { if (NODE (q) != NO_NODE && strcmp (NSYMBOL (NODE (q)), sym) == 0) { intro_frame (f, p, a68g_link, printed); show_frame_item (f, p, a68g_link, q, PRIO (q)); } } } /** @brief Search symbol in stack. @param f File number. @param a68g_link Current frame pointer. @param sym Symbol name. @param printed Counts items printed. **/ void examine_stack (FILE_T f, ADDR_T a68g_link, char *sym, int *printed) { if (a68g_link > 0) { int dynamic_a68g_link = FRAME_DYNAMIC_LINK (a68g_link); NODE_T *p = FRAME_TREE (a68g_link); if (p != NO_NODE) { TABLE_T *q = TABLE (p); examine_tags (f, p, a68g_link, IDENTIFIERS (q), sym, printed); examine_tags (f, p, a68g_link, OPERATORS (q), sym, printed); } examine_stack (f, dynamic_a68g_link, sym, printed); } } /** @brief Set or reset breakpoints. @param p Node in syntax tree. @param set Mask indicating what to set. @param num Line number. @param is_set To check whether breakpoint is already set. @param loc_expr Expression associated with breakpoint. **/ void change_breakpoints (NODE_T * p, unsigned set, int num, BOOL_T * is_set, char *loc_expr) { for (; p != NO_NODE; FORWARD (p)) { change_breakpoints (SUB (p), set, num, is_set, loc_expr); if (set == BREAKPOINT_MASK) { if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) { STATUS_SET (p, BREAKPOINT_MASK); if (EXPR (INFO (p)) != NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = loc_expr; *is_set = A68_TRUE; } } else if (set == BREAKPOINT_TEMPORARY_MASK) { if (LINE_NUMBER (p) == num && (STATUS_TEST (p, INTERRUPTIBLE_MASK)) && num != 0) { STATUS_SET (p, BREAKPOINT_TEMPORARY_MASK); if (EXPR (INFO (p)) != NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = loc_expr; *is_set = A68_TRUE; } } else if (set == NULL_MASK) { if (LINE_NUMBER (p) != num) { STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK)); if (EXPR (INFO (p)) == NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = NO_TEXT; } else if (num == 0) { STATUS_CLEAR (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK)); if (EXPR (INFO (p)) != NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = NO_TEXT; } } } } /** @brief List breakpoints. @param p Node in syntax tree. @param listed Counts listed items. **/ static void list_breakpoints (NODE_T * p, int *listed) { for (; p != NO_NODE; FORWARD (p)) { list_breakpoints (SUB (p), listed); if (STATUS_TEST (p, BREAKPOINT_MASK)) { (*listed)++; WIS (p); if (EXPR (INFO (p)) != NO_TEXT) { WRITELN (STDOUT_FILENO, "breakpoint condition \""); WRITE (STDOUT_FILENO, EXPR (INFO (p))); WRITE (STDOUT_FILENO, "\""); } } } } /** @brief Execute monitor command. @param p Node in syntax tree. @param cmd Command text. @return Whether execution continues. **/ static BOOL_T single_stepper (NODE_T * p, char *cmd) { mon_errors = 0; errno = 0; if (strlen (cmd) == 0) { return (A68_FALSE); } while (IS_SPACE (cmd[strlen (cmd) - 1])) { cmd[strlen (cmd) - 1] = NULL_CHAR; } if (match_string (cmd, "CAlls", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); int printed = 0; if (k > 0) { stack_trace (STDOUT_FILENO, frame_pointer, k, &printed); } else if (k == 0) { stack_trace (STDOUT_FILENO, frame_pointer, 3, &printed); } return (A68_FALSE); } else if (match_string (cmd, "Continue", NULL_CHAR) || match_string (cmd, "Resume", NULL_CHAR)) { do_confirm_exit = A68_TRUE; return (A68_TRUE); } else if (match_string (cmd, "DO", BLANK_CHAR) || match_string (cmd, "EXEC", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); if (sym[0] != NULL_CHAR) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "return code %d", system (sym)) >= 0); WRITELN (STDOUT_FILENO, output_line); } return (A68_FALSE); } else if (match_string (cmd, "ELems", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); if (k > 0) { max_row_elems = k; } return (A68_FALSE); } else if (match_string (cmd, "Evaluate", BLANK_CHAR) || match_string (cmd, "X", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); if (sym[0] != NULL_CHAR) { ADDR_T old_sp = stack_pointer; evaluate (STDOUT_FILENO, p, sym); if (mon_errors == 0 && _m_sp > 0) { MOID_T *res; BOOL_T cont = A68_TRUE; while (cont) { res = _m_stack[0]; WRITELN (STDOUT_FILENO, "("); WRITE (STDOUT_FILENO, moid_to_string (res, MOID_WIDTH, NO_NODE)); WRITE (STDOUT_FILENO, ")"); show_item (STDOUT_FILENO, p, STACK_ADDRESS (old_sp), res); cont = (BOOL_T) (IS (res, REF_SYMBOL) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (old_sp))); if (cont) { A68_REF z; POP_REF (p, &z); _m_stack[0] = SUB (_m_stack[0]); PUSH (p, ADDRESS (&z), SIZE (_m_stack[0])); } } } else { monitor_error (CANNOT_SHOW, NO_TEXT); } stack_pointer = old_sp; _m_sp = 0; } return (A68_FALSE); } else if (match_string (cmd, "EXamine", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); if (sym[0] != NULL_CHAR && (IS_LOWER (sym[0]) || IS_UPPER (sym[0]))) { int printed = 0; examine_stack (STDOUT_FILENO, frame_pointer, sym, &printed); if (printed == 0) { monitor_error ("tag not found", sym); } } else { monitor_error ("tag expected", NO_TEXT); } return (A68_FALSE); } else if (match_string (cmd, "EXIt", NULL_CHAR) || match_string (cmd, "HX", NULL_CHAR) || match_string (cmd, "Quit", NULL_CHAR) || strcmp (cmd, LOGOUT_STRING) == 0) { if (confirm_exit ()) { exit_genie (p, A68_RUNTIME_ERROR + A68_FORCE_QUIT); } return (A68_FALSE); } else if (match_string (cmd, "Frame", NULL_CHAR)) { if (current_frame == 0) { int printed = 0; stack_dump (STDOUT_FILENO, frame_pointer, 1, &printed); } else { stack_dump_current (STDOUT_FILENO, frame_pointer); } return (A68_FALSE); } else if (match_string (cmd, "Frame", BLANK_CHAR)) { int n = get_num_arg (cmd, NO_VAR); current_frame = (n > 0 ? n : 0); stack_dump_current (STDOUT_FILENO, frame_pointer); return (A68_FALSE); } else if (match_string (cmd, "HEAp", BLANK_CHAR)) { int top = get_num_arg (cmd, NO_VAR); if (top <= 0) { top = heap_size; } show_heap (STDOUT_FILENO, p, busy_handles, top, term_heigth - 4); return (A68_FALSE); } else if (match_string (cmd, "APropos", NULL_CHAR) || match_string (cmd, "Help", NULL_CHAR) || match_string (cmd, "INfo", NULL_CHAR)) { apropos (STDOUT_FILENO, NO_TEXT, "monitor"); return (A68_FALSE); } else if (match_string (cmd, "APropos", BLANK_CHAR) || match_string (cmd, "Help", BLANK_CHAR) || match_string (cmd, "INfo", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); apropos (STDOUT_FILENO, NO_TEXT, sym); return (A68_FALSE); } else if (match_string (cmd, "HT", NULL_CHAR)) { halt_typing = A68_TRUE; do_confirm_exit = A68_TRUE; return (A68_TRUE); } else if (match_string (cmd, "RT", NULL_CHAR)) { halt_typing = A68_FALSE; do_confirm_exit = A68_TRUE; return (A68_TRUE); } else if (match_string (cmd, "Breakpoint", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); if (sym[0] == NULL_CHAR) { int listed = 0; list_breakpoints (TOP_NODE (&program), &listed); if (listed == 0) { WRITELN (STDOUT_FILENO, "No breakpoints set"); } if (watchpoint_expression != NO_TEXT) { WRITELN (STDOUT_FILENO, "Watchpoint condition \""); WRITE (STDOUT_FILENO, watchpoint_expression); WRITE (STDOUT_FILENO, "\""); } else { WRITELN (STDOUT_FILENO, "No watchpoint expression set"); } } else if (IS_DIGIT (sym[0])) { char *mod; int k = get_num_arg (cmd, &mod); SKIP_SPACE (mod); if (mod[0] == NULL_CHAR) { BOOL_T set = A68_FALSE; change_breakpoints (TOP_NODE (&program), BREAKPOINT_MASK, k, &set, NULL); if (set == A68_FALSE) { monitor_error ("cannot set breakpoint in that line", NO_TEXT); } } else if (match_string (mod, "IF", BLANK_CHAR)) { char *cexpr = mod; BOOL_T set = A68_FALSE; SKIP_ONE_SYMBOL (cexpr); change_breakpoints (TOP_NODE (&program), BREAKPOINT_MASK, k, &set, new_string (cexpr, NO_TEXT)); if (set == A68_FALSE) { monitor_error ("cannot set breakpoint in that line", NO_TEXT); } } else if (match_string (mod, "Clear", NULL_CHAR)) { change_breakpoints (TOP_NODE (&program), NULL_MASK, k, NULL, NULL); } else { monitor_error ("invalid breakpoint command", NO_TEXT); } } else if (match_string (sym, "List", NULL_CHAR)) { int listed = 0; list_breakpoints (TOP_NODE (&program), &listed); if (listed == 0) { WRITELN (STDOUT_FILENO, "No breakpoints set"); } if (watchpoint_expression != NO_TEXT) { WRITELN (STDOUT_FILENO, "Watchpoint condition \""); WRITE (STDOUT_FILENO, watchpoint_expression); WRITE (STDOUT_FILENO, "\""); } else { WRITELN (STDOUT_FILENO, "No watchpoint expression set"); } } else if (match_string (sym, "Watch", BLANK_CHAR)) { char *cexpr = sym; SKIP_ONE_SYMBOL (cexpr); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } watchpoint_expression = new_string (cexpr, NO_TEXT); change_masks (TOP_NODE (&program), BREAKPOINT_WATCH_MASK, A68_TRUE); } else if (match_string (sym, "Clear", BLANK_CHAR)) { char *mod = sym; SKIP_ONE_SYMBOL (mod); if (mod[0] == NULL_CHAR) { change_breakpoints (TOP_NODE (&program), NULL_MASK, 0, NULL, NULL); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } change_masks (TOP_NODE (&program), BREAKPOINT_WATCH_MASK, A68_FALSE); } else if (match_string (mod, "ALL", NULL_CHAR)) { change_breakpoints (TOP_NODE (&program), NULL_MASK, 0, NULL, NULL); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } change_masks (TOP_NODE (&program), BREAKPOINT_WATCH_MASK, A68_FALSE); } else if (match_string (mod, "Breakpoints", NULL_CHAR)) { change_breakpoints (TOP_NODE (&program), NULL_MASK, 0, NULL, NULL); } else if (match_string (mod, "Watchpoint", NULL_CHAR)) { if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } change_masks (TOP_NODE (&program), BREAKPOINT_WATCH_MASK, A68_FALSE); } else { monitor_error ("invalid breakpoint command", NO_TEXT); } } else { monitor_error ("invalid breakpoint command", NO_TEXT); } return (A68_FALSE); } else if (match_string (cmd, "List", BLANK_CHAR)) { char *cwhere; int n = get_num_arg (cmd, &cwhere); int m = get_num_arg (cwhere, NO_VAR); if (m == NOT_A_NUM) { if (n > 0) { list (STDOUT_FILENO, p, n, 0); } else if (n == NOT_A_NUM) { list (STDOUT_FILENO, p, 10, 0); } } else if (n > 0 && m > 0 && n <= m) { list (STDOUT_FILENO, p, n, m); } return (A68_FALSE); } else if (match_string (cmd, "PROmpt", BLANK_CHAR)) { char *sym = cmd; SKIP_ONE_SYMBOL (sym); if (sym[0] != NULL_CHAR) { if (sym[0] == QUOTE_CHAR) { sym++; } if (sym[strlen (sym) - 1] == QUOTE_CHAR) { sym[strlen (sym) - 1] = NULL_CHAR; } bufcpy (prompt, sym, BUFFER_SIZE); } return (A68_FALSE); } else if (match_string (cmd, "RERun", NULL_CHAR) || match_string (cmd, "REStart", NULL_CHAR)) { if (confirm_exit ()) { exit_genie (p, A68_RERUN); } return (A68_FALSE); } else if (match_string (cmd, "RESET", NULL_CHAR)) { if (confirm_exit ()) { change_breakpoints (TOP_NODE (&program), NULL_MASK, 0, NULL, NULL); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } change_masks (TOP_NODE (&program), BREAKPOINT_WATCH_MASK, A68_FALSE); exit_genie (p, A68_RERUN); } return (A68_FALSE); } else if (match_string (cmd, "LINk", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); int printed = 0; if (k > 0) { stack_a68g_link_dump (STDOUT_FILENO, frame_pointer, k, &printed); } else if (k == NOT_A_NUM) { stack_a68g_link_dump (STDOUT_FILENO, frame_pointer, 3, &printed); } return (A68_FALSE); } else if (match_string (cmd, "STAck", BLANK_CHAR) || match_string (cmd, "BT", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); int printed = 0; if (k > 0) { stack_dump (STDOUT_FILENO, frame_pointer, k, &printed); } else if (k == NOT_A_NUM) { stack_dump (STDOUT_FILENO, frame_pointer, 3, &printed); } return (A68_FALSE); } else if (match_string (cmd, "Next", NULL_CHAR)) { change_masks (TOP_NODE (&program), BREAKPOINT_TEMPORARY_MASK, A68_TRUE); do_confirm_exit = A68_FALSE; break_proc_level = PROCEDURE_LEVEL (INFO (p)); return (A68_TRUE); } else if (match_string (cmd, "STEp", NULL_CHAR)) { change_masks (TOP_NODE (&program), BREAKPOINT_TEMPORARY_MASK, A68_TRUE); do_confirm_exit = A68_FALSE; return (A68_TRUE); } else if (match_string (cmd, "FINish", NULL_CHAR) || match_string (cmd, "OUT", NULL_CHAR)) { finish_frame_pointer = FRAME_PARAMETERS (frame_pointer); do_confirm_exit = A68_FALSE; return (A68_TRUE); } else if (match_string (cmd, "Until", BLANK_CHAR)) { int k = get_num_arg (cmd, NO_VAR); if (k > 0) { BOOL_T set = A68_FALSE; change_breakpoints (TOP_NODE (&program), BREAKPOINT_TEMPORARY_MASK, k, &set, NULL); if (set == A68_FALSE) { monitor_error ("cannot set breakpoint in that line", NO_TEXT); return (A68_FALSE); } do_confirm_exit = A68_FALSE; return (A68_TRUE); } else { monitor_error ("line number expected", NO_TEXT); return (A68_FALSE); } } else if (match_string (cmd, "Where", NULL_CHAR)) { WIS (p); return (A68_FALSE); } else if (strcmp (cmd, "?") == 0) { apropos (STDOUT_FILENO, prompt, "monitor"); return (A68_FALSE); } else if (match_string (cmd, "Sizes", NULL_CHAR)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Frame stack pointer=%d available=%d", frame_pointer, frame_stack_size - frame_pointer) >= 0); WRITELN (STDOUT_FILENO, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Expression stack pointer=%d available=%d", stack_pointer, expr_stack_size - stack_pointer) >= 0); WRITELN (STDOUT_FILENO, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Heap size=%d available=%d", heap_size, heap_available ()) >= 0); WRITELN (STDOUT_FILENO, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Garbage collections=%d", garbage_collects) >= 0); WRITELN (STDOUT_FILENO, output_line); return (A68_FALSE); } else if (match_string (cmd, "XRef", NULL_CHAR)) { int k = LINE_NUMBER (p); LINE_T *line = TOP_LINE (&program); for (; line != NO_LINE; FORWARD (line)) { if (NUMBER (line) > 0 && NUMBER (line) == k) { list_source_line (STDOUT_FILENO, line, A68_TRUE); } } return (A68_FALSE); } else if (match_string (cmd, "XRef", BLANK_CHAR)) { LINE_T *line = TOP_LINE (&program); int k = get_num_arg (cmd, NO_VAR); if (k == NOT_A_NUM) { monitor_error ("line number expected", NO_TEXT); } else { for (; line != NO_LINE; FORWARD (line)) { if (NUMBER (line) > 0 && NUMBER (line) == k) { list_source_line (STDOUT_FILENO, line, A68_TRUE); } } } return (A68_FALSE); } else if (strlen (cmd) == 0) { return (A68_FALSE); } else { monitor_error ("unrecognised command", NO_TEXT); return (A68_FALSE); } } /** @brief Evaluate conditional breakpoint expression. @param p Node in syntax tree. @return Whether expression evaluates to TRUE. **/ static BOOL_T evaluate_breakpoint_expression (NODE_T * p) { ADDR_T top_sp = stack_pointer; volatile BOOL_T res = A68_FALSE; mon_errors = 0; if (EXPR (INFO (p)) != NO_TEXT) { evaluate (STDOUT_FILENO, p, EXPR (INFO (p))); if (_m_sp != 1 || mon_errors != 0) { mon_errors = 0; monitor_error ("deleted invalid breakpoint expression", NO_TEXT); if (EXPR (INFO (p)) != NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = expr; res = A68_TRUE; } else if (TOP_MODE == MODE (BOOL)) { A68_BOOL z; POP_OBJECT (p, &z, A68_BOOL); res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68_TRUE); } else { monitor_error ("deleted invalid breakpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); if (EXPR (INFO (p)) != NO_TEXT) { free (EXPR (INFO (p))); } EXPR (INFO (p)) = expr; res = A68_TRUE; } } stack_pointer = top_sp; return (res); } /** @brief Evaluate conditional watchpoint expression. @return Whether expression evaluates to TRUE. **/ static BOOL_T evaluate_watchpoint_expression (NODE_T * p) { ADDR_T top_sp = stack_pointer; volatile BOOL_T res = A68_FALSE; mon_errors = 0; if (watchpoint_expression != NO_TEXT) { evaluate (STDOUT_FILENO, p, watchpoint_expression); if (_m_sp != 1 || mon_errors != 0) { mon_errors = 0; monitor_error ("deleted invalid watchpoint expression", NO_TEXT); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } res = A68_TRUE; } if (TOP_MODE == MODE (BOOL)) { A68_BOOL z; POP_OBJECT (p, &z, A68_BOOL); res = (BOOL_T) (STATUS (&z) == INIT_MASK && VALUE (&z) == A68_TRUE); } else { monitor_error ("deleted invalid watchpoint expression yielding mode", moid_to_string (TOP_MODE, MOID_WIDTH, NO_NODE)); if (watchpoint_expression != NO_TEXT) { free (watchpoint_expression); watchpoint_expression = NO_TEXT; } res = A68_TRUE; } } stack_pointer = top_sp; return (res); } /** @brief Execute monitor. @param p Node in syntax tree. @param mask Reason for single step. **/ void single_step (NODE_T * p, unsigned mask) { volatile BOOL_T do_cmd = A68_TRUE; ADDR_T top_sp = stack_pointer; if (LINE_NUMBER (p) == 0) { return; } #if defined HAVE_CURSES genie_curses_end (NO_NODE); #endif if (mask == (unsigned) BREAKPOINT_ERROR_MASK) { WRITELN (STDOUT_FILENO, "Monitor entered after an error"); WIS ((p)); } else if ((mask & BREAKPOINT_INTERRUPT_MASK) != 0) { WRITELN (STDOUT_FILENO, NEWLINE_STRING); WIS ((p)); if (do_confirm_exit && confirm_exit ()) { exit_genie ((p), A68_RUNTIME_ERROR + A68_FORCE_QUIT); } } else if ((mask & BREAKPOINT_MASK) != 0) { if (EXPR (INFO (p)) != NO_TEXT) { if (!evaluate_breakpoint_expression (p)) { return; } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Breakpoint (%s)", EXPR (INFO (p))) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Breakpoint") >= 0); } WRITELN (STDOUT_FILENO, output_line); WIS (p); } else if ((mask & BREAKPOINT_TEMPORARY_MASK) != 0) { if (break_proc_level != 0 && PROCEDURE_LEVEL (INFO (p)) > break_proc_level) { return; } change_masks (TOP_NODE (&program), BREAKPOINT_TEMPORARY_MASK, A68_FALSE); WRITELN (STDOUT_FILENO, "Temporary breakpoint (now removed)"); WIS (p); } else if ((mask & BREAKPOINT_WATCH_MASK) != 0) { if (!evaluate_watchpoint_expression (p)) { return; } if (watchpoint_expression != NO_TEXT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Watchpoint (%s)", watchpoint_expression) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Watchpoint (now removed)") >= 0); } WRITELN (STDOUT_FILENO, output_line); WIS (p); } else if ((mask & BREAKPOINT_TRACE_MASK) != 0) { PROP_T *prop = &GPROP (p); WIS ((p)); if (propagator_name (UNIT (prop)) != NO_TEXT) { WRITELN (STDOUT_FILENO, propagator_name (UNIT (prop))); } return; } else { WRITELN (STDOUT_FILENO, "Monitor entered with no valid reason (continuing execution)"); WIS ((p)); return; } #if defined HAVE_PARALLEL_CLAUSE if (is_main_thread ()) { WRITELN (STDOUT_FILENO, "This is the main thread"); } else { WRITELN (STDOUT_FILENO, "This is not the main thread"); } #endif /* Entry into the monitor */ if (prompt_set == A68_FALSE) { bufcpy (prompt, "(a68g) ", BUFFER_SIZE); prompt_set = A68_TRUE; } in_monitor = A68_TRUE; break_proc_level = 0; change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_FALSE); STATUS_CLEAR (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK); while (do_cmd) { char *cmd; stack_pointer = top_sp; io_close_tty_line (); while (strlen (cmd = read_string_from_tty (prompt)) == 0) {; } if (TO_UCHAR (cmd[0]) == TO_UCHAR (EOF_CHAR)) { bufcpy (cmd, LOGOUT_STRING, BUFFER_SIZE); WRITE (STDOUT_FILENO, LOGOUT_STRING); WRITE (STDOUT_FILENO, NEWLINE_STRING); } _m_sp = 0; do_cmd = (BOOL_T) (!single_stepper (p, cmd)); } stack_pointer = top_sp; in_monitor = A68_FALSE; if (mask == (unsigned) BREAKPOINT_ERROR_MASK) { WRITELN (STDOUT_FILENO, "Continuing from an error might corrupt things"); single_step (p, (unsigned) BREAKPOINT_ERROR_MASK); } else { WRITELN (STDOUT_FILENO, "Continuing ..."); WRITELN (STDOUT_FILENO, ""); } } /** @brief PROC debug = VOID @param p Node in syntax tree. **/ void genie_debug (NODE_T * p) { single_step (p, BREAKPOINT_INTERRUPT_MASK); } /** @brief PROC break = VOID @param p Node in syntax tree. **/ void genie_break (NODE_T * p) { (void) p; change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE); } /** @brief PROC evaluate = (STRING) STRING @param p Node in syntax tree. */ void genie_evaluate (NODE_T * p) { A68_REF u, v; volatile ADDR_T top_sp; v = empty_string (p); /* Pop argument */ POP_REF (p, (A68_REF *) & u); top_sp = stack_pointer; CHECK_MON_REF (p, u, MODE (STRING)); reset_transput_buffer (UNFORMATTED_BUFFER); add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u); v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH); /* Evaluate in the monitor */ in_monitor = A68_TRUE; mon_errors = 0; evaluate (STDOUT_FILENO, p, get_transput_buffer (UNFORMATTED_BUFFER)); in_monitor = A68_FALSE; if (_m_sp != 1) { monitor_error ("invalid expression", NO_TEXT); } if (mon_errors == 0) { MOID_T *res; BOOL_T cont = A68_TRUE; while (cont) { res = TOP_MODE; cont = (BOOL_T) (IS (res, REF_SYMBOL) && !IS_NIL (*(A68_REF *) STACK_ADDRESS (top_sp))); if (cont) { A68_REF w; POP_REF (p, &w); TOP_MODE = SUB (TOP_MODE); PUSH (p, ADDRESS (&w), SIZE (TOP_MODE)); } } reset_transput_buffer (UNFORMATTED_BUFFER); genie_write_standard (p, TOP_MODE, STACK_ADDRESS (top_sp), nil_ref); v = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH); } stack_pointer = top_sp; PUSH_REF (p, v); } /** @brief PROC abend = (STRING) VOID @param p Node in syntax tree. */ void genie_abend (NODE_T * p) { A68_REF u; POP_REF (p, (A68_REF *) & u); reset_transput_buffer (UNFORMATTED_BUFFER); add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, (BYTE_T *) & u); diagnostic_node (A68_RUNTIME_ERROR | A68_NO_SYNTHESIS, p, get_transput_buffer (UNFORMATTED_BUFFER), NO_TEXT); exit_genie (p, A68_RUNTIME_ERROR); } algol68g-2.8/source/pretty.c0000644000175000001440000010554112113475754012735 00000000000000/** @file pretty.c @author J. Marcel van der Veer. @brief Pretty-printer for Algol 68 programs. @section Copyright This file is part of Algol68G - an Algol 68 compiler-interpreter. Copyright (C) 2001-2013 J. Marcel van der Veer . @section License 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 . @section Description Basic indenter for hopeless code. It applies one style only. **/ #include "a68g.h" #define ONE_LINER (A68_TRUE) #define KEYWORD (A68_TRUE) #define BLANK {put_str (" ");} #define IS_OPEN_SYMBOL(p) (IS (p, OPEN_SYMBOL) || IS (p, SUB_SYMBOL) || IS (p, ACCO_SYMBOL)) #define IS_CLOSE_SYMBOL(p) (IS (p, CLOSE_SYMBOL) || IS (p, BUS_SYMBOL) || IS (p, OCCA_SYMBOL)) #define IS_IDENTIFIER(p) (IS (p, IDENTIFIER) || IS (p, DEFINING_IDENTIFIER) || IS (p, FIELD_IDENTIFIER)) static char in_line[BUFFER_SIZE]; static FILE_T fd; static int ind, col; static int indentation = 0; static BOOL_T use_folder; static void in_declarer (NODE_T *); static void in_serial (NODE_T *, BOOL_T, NODE_T **); static void in_statement (NODE_T *); static void in_format (NODE_T *); /** @brief Write newline and indent. **/ static void put_nl (void) { WRITE (fd, "\n"); for (col = 1; col < ind % 72; col ++) { WRITE (fd, " "); } } /** @brief Write a string. @param txt **/ static void put_str (char *txt) { WRITE (fd, txt); col += (int) strlen (txt); } /** @brief Write a character. @param ch **/ static void put_ch (char ch) { char str[2]; str[0] = ch; str[1] = NULL_CHAR; put_str (str); } /** @brief Write pragment string. @param p Node in syntax tree. **/ static void put_pragment (NODE_T *p) { char *txt = NPRAGMENT (p); for (; txt != NO_TEXT && txt[0] != NULL_CHAR; txt++) { if (txt[0] == NEWLINE_CHAR) { put_nl (); } else { put_ch (txt[0]); } } } /** @brief Write pragment string. @param p Node in syntax tree. @param keyw Whether keyword. **/ static void pragment (NODE_T *p, BOOL_T keyw) { if (NPRAGMENT (p) != NO_TEXT) { if (NPRAGMENT_TYPE (p) == BOLD_COMMENT_SYMBOL || NPRAGMENT_TYPE (p) == BOLD_PRAGMAT_SYMBOL) { if (! keyw) { put_nl (); } put_pragment (p); put_nl (); put_nl (); } else { if (! keyw && (int) strlen (NPRAGMENT (p)) < 20) { if (col > ind) { BLANK; } put_pragment (p); BLANK; } else { if (col > ind) { put_nl (); } put_pragment (p); put_nl (); } } }} /** @brief Write with typographic display features. @param p Node in syntax tree. @param keyw Whether p is a keyword. **/ static void put_sym (NODE_T *p, BOOL_T keyw) { char *txt = NSYMBOL (p); char *sym = NCHAR_IN_LINE (p); int n = 0, size = (int) strlen (txt); pragment (p, keyw); if (txt[0] != sym[0] || (int) strlen (sym) - 1 <= size) { /* Without features. */ put_str (txt); } else { /* With features. Preserves spaces in identifiers etcetera. */ while (n < size) { put_ch (sym[0]); if (TO_LOWER (txt[0]) == TO_LOWER (sym[0])) { txt ++; n ++; } sym ++; } } } /** @brief Count units and separators in a sub-tree. @param p Node in syntax tree. @param units @param seps **/ static void count (NODE_T *p, int *units, int *seps) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { (*units) ++; count (SUB (p), units, seps); } else if (IS (p, SEMI_SYMBOL)) { (*seps) ++; } else if (IS (p, COMMA_SYMBOL)) { (*seps) ++; } else { count (SUB (p), units, seps); } } } /** @brief Count units and separators in a sub-tree. @param p Node in syntax tree. @param units @param seps **/ static void count_stowed (NODE_T *p, int *units, int *seps) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { MOID_T *v = MOID (p); BOOL_T stowed = (BOOL_T) (IS (v, FLEX_SYMBOL) || IS (v, ROW_SYMBOL) || IS (v, STRUCT_SYMBOL)); if (stowed) { (*units) ++; } } else if (IS (p, SEMI_SYMBOL)) { (*seps) ++; } else if (IS (p, COMMA_SYMBOL)) { (*seps) ++; } else { count_stowed (SUB (p), units, seps); } } } /** @brief Count enclosed_clauses in a sub-tree. @param p Node in syntax tree. @param enclos @param seps **/ static void count_enclos (NODE_T *p, int *enclos, int *seps) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, ENCLOSED_CLAUSE)) { (*enclos) ++; } else if (IS (p, SEMI_SYMBOL)) { (*seps) ++; } else if (IS (p, COMMA_SYMBOL)) { (*seps) ++; } else { count_enclos (SUB (p), enclos, seps); } } } /** @brief Indent sizety. @param p Node in syntax tree. **/ static void in_sizety (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, LONGETY) || IS (p, SHORTETY)) { in_sizety (SUB (p)); } else if (IS (p, LONG_SYMBOL) || IS (p, SHORT_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } } } /** @brief Indent generic list. @param p Node in syntax tree. @param what Pointer to node that will explain list type. @param one_liner Whether construct is one-liner. **/ static void in_generic_list (NODE_T * p, NODE_T ** what, BOOL_T one_liner) { for (; p != NULL; FORWARD (p)) { if (IS_OPEN_SYMBOL (p)) { put_sym (p, KEYWORD); ind = col; } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } else if (IS (p, BEGIN_SYMBOL)) { put_sym (p, KEYWORD); BLANK; } else if (IS (p, END_SYMBOL)) { BLANK; put_sym (p, KEYWORD); } else if (IS (p, AT_SYMBOL)) { if (NSYMBOL (p)[0] == '@') { put_sym (p, !KEYWORD); } else { BLANK; put_sym (p, !KEYWORD); BLANK; } } else if (IS (p, COLON_SYMBOL)) { BLANK; put_sym (p, !KEYWORD); BLANK; } else if (IS (p, DOTDOT_SYMBOL)) { BLANK; put_sym (p, !KEYWORD); BLANK; } else if (IS (p, UNIT)) { *what = p; in_statement (SUB (p)); } else if (IS (p, SPECIFIER)) { NODE_T *q = SUB (p); put_sym (q, KEYWORD); FORWARD (q); in_declarer (q); FORWARD (q); if (IS_IDENTIFIER (q)) { BLANK; put_sym (q, !KEYWORD); FORWARD (q); } put_sym (q, !KEYWORD); FORWARD (q); put_sym (NEXT (p), !KEYWORD); /* : */ BLANK; FORWARD (p); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); if (one_liner) { BLANK; } else { put_nl (); } } else { in_generic_list (SUB (p), what, one_liner); } } } /** @brief Indent declarer pack. @param p Node in syntax tree. **/ static void in_pack (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS_OPEN_SYMBOL (p) || IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } else if (IS (p, VOID_SYMBOL)) { put_sym (p, !KEYWORD); } else if (IS (p, DECLARER)) { in_declarer (p); if (NEXT (p) != NO_NODE && IS_IDENTIFIER (NEXT (p))) { BLANK; } } else if (IS_IDENTIFIER (p)) { put_sym (p, !KEYWORD); } else { in_pack (SUB (p)); } } } /** @brief Indent declarer. @param p Node in syntax tree. **/ static void in_declarer (NODE_T *p) { if (IS (p, DECLARER)) { in_declarer (SUB (p)); } else if (IS (p, LONGETY) || IS (p, SHORTETY)) { in_sizety (SUB (p)); in_declarer (NEXT (p)); } else if (IS (p, VOID_SYMBOL)) { put_sym (p, !KEYWORD); } else if (IS (p, REF_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; in_declarer (NEXT (p)); } else if (IS (p, FLEX_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; in_declarer (NEXT (p)); } else if (IS (p, BOUNDS) || IS (p, FORMAL_BOUNDS)) { NODE_T *what = NO_NODE; int pop_ind = ind; in_generic_list (SUB (p), &what, ONE_LINER); ind = pop_ind; BLANK; in_declarer (NEXT (p)); } else if (IS (p, STRUCT_SYMBOL) || IS (p, UNION_SYMBOL)) { NODE_T *pack = NEXT (p); put_sym (p, !KEYWORD); BLANK; in_pack (pack); } else if (IS (p, PROC_SYMBOL)) { NODE_T *q = NEXT (p); put_sym (p, KEYWORD); BLANK; if (IS (q, FORMAL_DECLARERS)) { in_pack (SUB (q)); BLANK; FORWARD (q); } in_declarer (q); return; } else if (IS (p, OP_SYMBOL)) { /* Operator plan */ NODE_T *q = NEXT (p); put_sym (p, KEYWORD); BLANK; if (IS (q, FORMAL_DECLARERS)) { in_pack (SUB (q)); BLANK; FORWARD (q); } in_declarer (q); return; } else if (IS (p, INDICANT)) { put_sym (p, !KEYWORD); } } /** @brief Indent conditional. @param p Node in syntax tree. **/ static void in_conditional (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, IF_PART) || IS (p, ELIF_IF_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, THEN_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, ELSE_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, ELIF_PART)) { in_conditional (SUB (p)); } else if (IS (p, FI_SYMBOL)) { put_sym (p, KEYWORD); } else if (IS (p, OPEN_PART)) { NODE_T *what = NO_NODE; put_sym (SUB (p), KEYWORD); in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, ELSE_OPEN_PART)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, CHOICE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, BRIEF_ELIF_PART)) { in_conditional (SUB (p)); } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } } } /** @brief Indent integer case clause. @param p Node in syntax tree. **/ static void in_case (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, CASE_PART) || IS (p, OUSE_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, CASE_IN_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_generic_list (NEXT_SUB (p), &what, ONE_LINER); ind = pop_ind; put_nl (); } else if (IS (p, OUT_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, CASE_OUSE_PART)) { in_case (SUB (p)); } else if (IS (p, ESAC_SYMBOL)) { put_sym (p, KEYWORD); } else if (IS (p, OPEN_PART)) { NODE_T *what = NO_NODE; put_sym (SUB (p), KEYWORD); in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, ELSE_OPEN_PART)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, CASE_CHOICE_CLAUSE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_generic_list (NEXT_SUB (p), &what, ONE_LINER); } else if (IS (p, CHOICE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, BRIEF_OUSE_PART)) { in_case (SUB (p)); } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } } } /** @brief Indent conformity clause. @param p Node in syntax tree. **/ static void in_conformity (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, CASE_PART) || IS (p, OUSE_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, CONFORMITY_IN_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_generic_list (NEXT_SUB (p), &what, ONE_LINER); ind = pop_ind; put_nl (); } else if (IS (p, OUT_PART)) { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; put_nl (); } else if (IS (p, CONFORMITY_OUSE_PART)) { in_conformity (SUB (p)); } else if (IS (p, ESAC_SYMBOL)) { put_sym (p, KEYWORD); } else if (IS (p, OPEN_PART)) { NODE_T *what = NO_NODE; put_sym (SUB (p), KEYWORD); in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, ELSE_OPEN_PART)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, CONFORMITY_CHOICE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_generic_list (NEXT_SUB (p), &what, ONE_LINER); } else if (IS (p, CHOICE)) { NODE_T *what = NO_NODE; BLANK; put_sym (SUB (p), KEYWORD); BLANK; in_serial (NEXT_SUB (p), ONE_LINER, &what); } else if (IS (p, BRIEF_CONFORMITY_OUSE_PART)) { in_conformity (SUB (p)); } else if (IS_CLOSE_SYMBOL (p)) { put_sym (p, KEYWORD); } } } /** @brief Indent loop. @param p Node in syntax tree. **/ static void in_loop (NODE_T * p) { int parts = 0, pop_ind = col; for (; p != NO_NODE; FORWARD (p)) { if (IS (p, FOR_PART)) { put_sym (SUB (p), KEYWORD); BLANK; put_sym (NEXT_SUB (p), !KEYWORD); BLANK; parts ++; } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) { put_sym (SUB (p), KEYWORD); BLANK; in_statement (NEXT_SUB (p)); BLANK; parts ++; } else if (IS (p, WHILE_PART)) { NODE_T *what = NO_NODE; ind = pop_ind; if (parts > 0) { put_nl (); } put_sym (SUB (p), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (p), !ONE_LINER, &what); ind = pop_ind; parts ++; } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) { NODE_T *q = SUB (p); NODE_T *what = NO_NODE; ind = pop_ind; if (parts > 0) { put_nl (); } put_sym (q, KEYWORD); /* DO */ BLANK; ind = col; FORWARD (q); parts = 0; if (IS (q, SERIAL_CLAUSE)) { in_serial (SUB (q), !ONE_LINER, &what); FORWARD (q); parts ++; } if (IS (q, UNTIL_PART)) { int pop_ind2 = ind; if (parts > 0) { put_nl (); } put_sym (SUB (q), KEYWORD); BLANK; ind = col; in_serial (NEXT_SUB (q), !ONE_LINER, &what); ind = pop_ind2; FORWARD (q); } ind = pop_ind; put_nl (); put_sym (q, KEYWORD); /* OD */ parts ++; } } } /** @brief Indent closed clause. @param p Node in syntax tree. **/ static void in_closed (NODE_T *p) { int units = 0, seps = 0; count (SUB_NEXT (p), &units, &seps); if (units == 1 && seps == 0) { put_sym (p, KEYWORD); if (IS (p, BEGIN_SYMBOL)) { NODE_T *what = NO_NODE; BLANK; in_serial (SUB_NEXT (p), ONE_LINER, &what); BLANK; } else { NODE_T *what = NO_NODE; in_serial (SUB_NEXT (p), ONE_LINER, &what); } put_sym (NEXT_NEXT (p), KEYWORD); } else if (units <= 3 && seps == (units - 1) && IS_OPEN_SYMBOL (p)) { NODE_T *what = NO_NODE; put_sym (p, KEYWORD); in_serial (SUB_NEXT (p), ONE_LINER, &what); put_sym (NEXT_NEXT (p), KEYWORD); } else { NODE_T *what = NO_NODE; int pop_ind = ind; put_sym (p, KEYWORD); if (IS (p, BEGIN_SYMBOL)) { BLANK; } ind = col; in_serial (SUB_NEXT (p), !ONE_LINER, &what); ind = pop_ind; if (IS (NEXT_NEXT (p), END_SYMBOL)) { put_nl (); } put_sym (NEXT_NEXT (p), KEYWORD); } } /** @brief Indent collateral clause. @param p Node in syntax tree. **/ static void in_collateral (NODE_T *p) { int units = 0, seps = 0; NODE_T *what = NO_NODE; int pop_ind = ind; count_stowed (p, &units, &seps); if (units <= 3) { in_generic_list (p, &what, ONE_LINER); } else { in_generic_list (p, &what, !ONE_LINER); } ind = pop_ind; } /** @brief Indent enclosed clause. @param p Node in syntax tree. **/ static void in_enclosed (NODE_T *p) { if (IS (p, ENCLOSED_CLAUSE)) { in_enclosed (SUB (p)); } else if (IS (p, CLOSED_CLAUSE)) { in_closed (SUB (p)); } else if (IS (p, COLLATERAL_CLAUSE)) { in_collateral (SUB (p)); } else if (IS (p, PARALLEL_CLAUSE)) { put_sym (SUB (p), KEYWORD); in_enclosed (NEXT_SUB (p)); } else if (IS (p, CONDITIONAL_CLAUSE)) { in_conditional (SUB (p)); } else if (IS (p, CASE_CLAUSE)) { in_case (SUB (p)); } else if (IS (p, CONFORMITY_CLAUSE)) { in_conformity (SUB (p)); } else if (IS (p, LOOP_CLAUSE)) { in_loop (SUB (p)); } } /** @brief Indent a literal. @param txt **/ static void in_literal (char *txt) { put_str ("\""); while (txt[0] != NULL_CHAR) { if (txt[0] == '\"') { put_str ("\"\""); } else { put_ch (txt[0]); } txt ++; } put_str ("\""); } /** @brief Indent denotation. @param p Node in syntax tree. **/ static void in_denotation (NODE_T *p) { if (IS (p, ROW_CHAR_DENOTATION)) { in_literal (NSYMBOL (p)); } else if (IS (p, LONGETY) || IS (p, SHORTETY)) { in_sizety (SUB (p)); in_denotation (NEXT (p)); } else { put_sym (p, !KEYWORD); } } /** @brief Indent label. @param p Node in syntax tree. **/ static void in_label (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NULL) { in_label (SUB (p)); } else if (IS (p, DEFINING_IDENTIFIER)) { put_sym (p, !KEYWORD); put_sym (NEXT (p), KEYWORD); } } } /** @brief Indent literal list. @param p Node in syntax tree. **/ static void in_collection (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, FORMAT_OPEN_SYMBOL) || IS (p, FORMAT_CLOSE_SYMBOL)) { put_sym (p, !KEYWORD); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } else { in_format (SUB (p)); } } } /** @brief Indent format text. @param p Node in syntax tree. **/ static void in_format (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, FORMAT_DELIMITER_SYMBOL)) { put_sym (p, !KEYWORD); } else if (IS (p, COLLECTION)) { in_collection (SUB (p)); } else if (IS (p, ENCLOSED_CLAUSE)) { in_enclosed (SUB (p)); } else if (IS (p, LITERAL)) { in_literal (NSYMBOL (p)); } else if (IS (p, STATIC_REPLICATOR)) { in_denotation (p); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } else { if (SUB (p) != NO_NODE) { in_format (SUB (p)); } else { switch (ATTRIBUTE (p)) { case FORMAT_ITEM_A: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_B: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_C: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_D: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_E: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_ESCAPE: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_F: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_G: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_H: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_I: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_J: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_K: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_L: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_M: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_MINUS: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_N: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_O: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_P: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_PLUS: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_POINT: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_Q: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_R: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_S: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_T: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_U: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_V: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_W: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_X: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_Y: put_sym (p, !KEYWORD); break; case FORMAT_ITEM_Z: put_sym (p, !KEYWORD); break; } } } } } /** @brief Constant folder - replace constant statement with value. @param p Node in syntax tree. **/ static BOOL_T in_folder (NODE_T *p) { if (MOID (p) == MODE (INT)) { A68_INT k; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &k, A68_INT); if (ERROR_COUNT (&program) == 0) { ASSERT (snprintf (in_line, SNPRINTF_SIZE, "%d", VALUE (&k)) >= 0); put_str (in_line); return (A68_TRUE); } else { return (A68_FALSE); } } else if (MOID (p) == MODE (REAL)) { A68_REAL x; double conv; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &x, A68_REAL); /* Mind overflowing or underflowing values */ if (ERROR_COUNT (&program) != 0) { return (A68_FALSE); } else if (VALUE (&x) == DBL_MAX) { return (A68_FALSE); } else if (VALUE (&x) == -DBL_MAX) { return (A68_FALSE); } else { ASSERT (snprintf (in_line, SNPRINTF_SIZE, "%.*g", REAL_WIDTH, VALUE (&x)) >= 0); errno = 0; conv = strtod (in_line, NO_VAR); if (errno == ERANGE && conv == 0.0) { put_str ("0.0"); return (A68_TRUE); } else if (errno == ERANGE) { return (A68_FALSE); } else { if (strchr (in_line, '.') == NO_TEXT && strchr (in_line, 'e') == NO_TEXT && strchr (in_line, 'E') == NO_TEXT) { strncat (in_line, ".0", BUFFER_SIZE); } put_str (in_line); return (A68_TRUE); } } } else if (MOID (p) == MODE (BOOL)) { A68_BOOL b; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &b, A68_BOOL); if (ERROR_COUNT (&program) != 0) { return (A68_FALSE); } else { ASSERT (snprintf (in_line, SNPRINTF_SIZE, "%s", (VALUE (&b) ? "TRUE" : "FALSE")) >= 0); put_str (in_line); return (A68_TRUE); } } else if (MOID (p) == MODE (CHAR)) { A68_CHAR c; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &c, A68_CHAR); if (ERROR_COUNT (&program) == 0) { return (A68_FALSE); } else if (VALUE (&c) == '\"') { put_str ("\"\"\"\""); return (A68_TRUE); } else { ASSERT (snprintf (in_line, SNPRINTF_SIZE, "\"%c\"", VALUE (&c)) >= 0); return (A68_TRUE); } } return (A68_FALSE); } /** @brief Indent statement. @param p Node in syntax tree. **/ static void in_statement (NODE_T *p) { if (IS (p, LABEL)) { int enclos = 0, seps = 0; in_label (SUB (p)); FORWARD (p); count_enclos (SUB (p), &enclos, &seps); if (enclos == 0) { BLANK; } else { put_nl (); } } if (use_folder && folder_mode (MOID (p)) && constant_unit (p)) { if (in_folder (p)) { return; }; } if (is_coercion (p)) { in_statement (SUB (p)); } else if (is_one_of (p, PRIMARY, SECONDARY, TERTIARY, UNIT, LABELED_UNIT, STOP)) { in_statement (SUB (p)); } else if (IS (p, ENCLOSED_CLAUSE)) { in_enclosed (SUB (p)); } else if (IS (p, DENOTATION)) { in_denotation (SUB (p)); } else if (IS (p, FORMAT_TEXT)) { in_format (SUB (p)); } else if (IS (p, IDENTIFIER)) { put_sym (p, !KEYWORD); } else if (IS (p, CAST)) { NODE_T *decl = SUB (p); NODE_T *rhs = NEXT (decl); in_declarer (decl); BLANK; in_enclosed (rhs); } else if (IS (p, CALL)) { NODE_T *primary = SUB (p); NODE_T *arguments = NEXT (primary); NODE_T *what = NO_NODE; int pop_ind = ind; in_statement (primary); BLANK; in_generic_list (arguments, &what, ONE_LINER); ind = pop_ind; } else if (IS (p, SLICE)) { NODE_T *primary = SUB (p); NODE_T *indexer = NEXT (primary); NODE_T *what = NO_NODE; int pop_ind = ind; in_statement (primary); in_generic_list (indexer, &what, ONE_LINER); ind = pop_ind; } else if (IS (p, SELECTION)) { NODE_T *selector = SUB (p); NODE_T *secondary = NEXT (selector); in_statement (selector); in_statement (secondary); } else if (IS (p, SELECTOR)) { NODE_T *identifier = SUB (p); put_sym (identifier, !KEYWORD); BLANK; put_sym (NEXT (identifier), !KEYWORD); /* OF */ BLANK; } else if (IS (p, GENERATOR)) { NODE_T *q = SUB (p); put_sym (q, !KEYWORD); BLANK; in_declarer (NEXT (q)); } else if (IS (p, FORMULA)) { NODE_T *lhs = SUB (p); NODE_T *op = NEXT (lhs); in_statement (lhs); if (op != NO_NODE) { NODE_T *rhs = NEXT (op); BLANK; put_sym (op, !KEYWORD); BLANK; in_statement (rhs); } } else if (IS (p, MONADIC_FORMULA)) { NODE_T *op = SUB (p); NODE_T *rhs = NEXT (op); put_sym (op, !KEYWORD); if (a68g_strchr (MONADS, (NSYMBOL (op))[0]) == NO_TEXT) { BLANK; } in_statement (rhs); } else if (IS (p, NIHIL)) { put_sym (p, !KEYWORD); } else if (IS (p, AND_FUNCTION) || IS (p, OR_FUNCTION)) { NODE_T *lhs = SUB (p); NODE_T *op = NEXT (lhs); NODE_T *rhs = NEXT (op); in_statement (lhs); BLANK; put_sym (op, !KEYWORD); BLANK; in_statement (rhs); } else if (IS (p, TRANSPOSE_FUNCTION) || IS (p, DIAGONAL_FUNCTION) || IS (p, ROW_FUNCTION) || IS (p, COLUMN_FUNCTION)) { NODE_T *q = SUB (p); if (IS (p, TERTIARY)) { in_statement (q); BLANK; FORWARD (q); } put_sym (q, !KEYWORD); BLANK; in_statement (NEXT (q)); } else if (IS (p, ASSIGNATION)) { NODE_T *dst = SUB (p); NODE_T *bec = NEXT (dst); NODE_T *src = NEXT (bec); in_statement (dst); BLANK; put_sym (bec, !KEYWORD); BLANK; in_statement (src); } else if (IS (p, ROUTINE_TEXT)) { NODE_T *q = SUB (p); int units, seps; if (IS (q, PARAMETER_PACK)) { in_pack (SUB (q)); BLANK; FORWARD (q); } in_declarer (q); FORWARD (q); put_sym (q, !KEYWORD); /* : */ FORWARD (q); units = 0; seps = 0; count (q, &units, &seps); if (units <= 1 && seps == 0) { BLANK; in_statement (q); } else { put_nl (); in_statement (q); } } else if (IS (p, IDENTITY_RELATION)) { NODE_T *lhs = SUB (p); NODE_T *op = NEXT (lhs); NODE_T *rhs = NEXT (op); in_statement (lhs); BLANK; put_sym (op, !KEYWORD); BLANK; in_statement (rhs); } else if (IS (p, JUMP)) { NODE_T *q = SUB (p); if (IS (q, GOTO_SYMBOL)) { put_sym (q, !KEYWORD); BLANK; FORWARD (q); } put_sym (q, !KEYWORD); } else if (IS (p, SKIP)) { put_sym (p, !KEYWORD); } else if (IS (p, ASSERTION)) { NODE_T *q = SUB (p); put_sym (q, KEYWORD); BLANK; in_enclosed (NEXT (q)); } else if (IS (p, CODE_CLAUSE)) { NODE_T *q = SUB (p); put_sym (q, KEYWORD); BLANK; FORWARD (q); in_collection(SUB (q)); FORWARD (q); put_sym (q, KEYWORD); } } /** @brief Indent identifier declarations. @param p Node in syntax tree. **/ static void in_iddecl (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, IDENTITY_DECLARATION) || IS (p, VARIABLE_DECLARATION)) { in_iddecl (SUB (p)); } else if (IS (p, QUALIFIER)) { put_sym (SUB (p), !KEYWORD); BLANK; } else if (IS (p, DECLARER)) { in_declarer (SUB (p)); BLANK; } else if (IS (p, DEFINING_IDENTIFIER)) { NODE_T *q = p; put_sym (q, !KEYWORD); FORWARD (q); if (q != NO_NODE) { /* := unit */ BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); in_statement (q); } } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } } } /** @brief Indent procedure declarations. @param p Node in syntax tree. **/ static void in_procdecl (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PROCEDURE_DECLARATION) || IS (p, PROCEDURE_VARIABLE_DECLARATION)) { in_procdecl (SUB (p)); } else if (IS (p, PROC_SYMBOL)) { put_sym (p, KEYWORD); BLANK; ind = col; } else if (IS (p, DEFINING_IDENTIFIER)) { NODE_T *q = p; put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); in_statement (q); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); put_nl (); BLANK; } } } /** @brief Indent operator declarations. @param p Node in syntax tree. **/ static void in_opdecl (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, OPERATOR_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) { in_opdecl (SUB (p)); } else if (IS (p, OP_SYMBOL)) { put_sym (p, KEYWORD); BLANK; ind = col; } else if (IS (p, OPERATOR_PLAN)) { in_declarer (SUB (p)); BLANK; ind = col; } else if (IS (p, DEFINING_OPERATOR)) { NODE_T *q = p; put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); in_statement (q); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); put_nl (); BLANK; } } } /** @brief Indent priority declarations. @param p Node in syntax tree. **/ static void in_priodecl (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PRIORITY_DECLARATION)) { in_priodecl (SUB (p)); } else if (IS (p, PRIO_SYMBOL)) { put_sym (p, KEYWORD); BLANK; } else if (IS (p, DEFINING_OPERATOR)) { NODE_T *q = p; put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); put_sym (q, !KEYWORD); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); BLANK; } } } /** @brief Indent mode declarations. @param p Node in syntax tree. **/ static void in_modedecl (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, MODE_DECLARATION)) { in_modedecl (SUB (p)); } else if (IS (p, MODE_SYMBOL)) { put_sym (p, KEYWORD); BLANK; ind = col; } else if (IS (p, DEFINING_INDICANT)) { NODE_T *q = p; put_sym (q, !KEYWORD); FORWARD (q); BLANK; put_sym (q, !KEYWORD); BLANK; FORWARD (q); in_declarer (q); } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); put_nl (); BLANK; } } } /** @brief Indent declaration list. @param p Node in syntax tree. @param one_liner Whether construct is one-liner. **/ static void in_declist (NODE_T *p, BOOL_T one_liner) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, IDENTITY_DECLARATION) || IS (p, VARIABLE_DECLARATION)) { int pop_ind = ind; in_iddecl (p); ind = pop_ind; } else if (IS (p, PROCEDURE_DECLARATION) || IS (p, PROCEDURE_VARIABLE_DECLARATION)) { int pop_ind = ind; in_procdecl (p); ind = pop_ind; } else if (IS (p, OPERATOR_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) { int pop_ind = ind; in_opdecl (p); ind = pop_ind; } else if (IS (p, PRIORITY_DECLARATION)) { int pop_ind = ind; in_priodecl (p); ind = pop_ind; } else if (IS (p, MODE_DECLARATION)) { int pop_ind = ind; in_modedecl (p); ind = pop_ind; } else if (IS (p, COMMA_SYMBOL)) { put_sym (p, !KEYWORD); if (one_liner) { BLANK; } else { put_nl (); } } else { in_declist (SUB (p), one_liner); } } } /** @brief Indent serial clause. @param p Node in syntax tree. @param one_liner Whether construct is one-liner. @param what Pointer telling type of construct. **/ static void in_serial (NODE_T *p, BOOL_T one_liner, NODE_T **what) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT) || IS (p, LABELED_UNIT)) { int pop_ind = ind; (*what) = p; in_statement (p); ind = pop_ind; } else if (IS (p, DECLARATION_LIST)) { (*what) = p; in_declist (p, one_liner); } else if (IS (p, SEMI_SYMBOL)) { put_sym (p, !KEYWORD); if (!one_liner) { put_nl (); if ((*what) != NO_NODE && IS ((*what), DECLARATION_LIST)) { put_nl (); } } else { BLANK; } } else if (IS (p, EXIT_SYMBOL)) { if (NPRAGMENT (p) == NO_TEXT) { BLANK; } put_sym (p, !KEYWORD); if (!one_liner) { put_nl (); } else { BLANK; } } else { in_serial (SUB (p), one_liner, what); } } } /** @brief Do not pretty-print the environ. @param p Node in syntax tree. **/ static void skip_environ (NODE_T *p) { for (; p != NO_NODE; FORWARD (p)) { if (LINE_NUMBER (p) == 0) { pragment (p, ! KEYWORD); skip_environ (SUB (p)); } else { NODE_T *what = NO_NODE; in_serial (p, !ONE_LINER, &what); } } } /** @brief Indenter driver. @param q Module to indent. **/ void indenter (MODULE_T *q) { ind = 1; col = 1; indentation = OPTION_INDENT (q); use_folder = OPTION_FOLD (q); FILE_PRETTY_FD (q) = open (FILE_PRETTY_NAME (q), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (FILE_PRETTY_FD (q) == -1, "cannot open listing file", NO_TEXT); FILE_PRETTY_OPENED (q) = A68_TRUE; fd = FILE_PRETTY_FD (q); skip_environ (TOP_NODE (q)); ASSERT (close (fd) == 0); FILE_PRETTY_OPENED (q) = A68_FALSE; return; } algol68g-2.8/source/environ.c0000644000175000001440000212755512224275321013070 00000000000000/** @file environ.c @author J. Marcel van der Veer. @brief Standard prelude implementation. @section Copyright This file is part of Algol68G - an Algol 68 compiler-interpreter. Copyright (C) 2001-2013 J. Marcel van der Veer . @section License 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 . @section Description This file implements the standard environ, both as required by the Revised Report as well as the Algol 68 Genie extensions. **/ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" #define A68_STD A68_TRUE #define A68_EXT A68_FALSE TABLE_T *a68g_standenv; static MOID_T *proc_int, *proc_real, *proc_real_real, *proc_real_real_real, *proc_real_real_real_real, *proc_complex_complex, *proc_bool, *proc_char, *proc_void; /** @brief Enter tag in standenv symbol table. @param portable Whether portable. @param a Attribute. @param n Node where defined. @param c Name of token. @param m Moid of token. @param p Priority, if applicable. @param q Interpreter routine that executes this token. **/ static void add_a68g_standenv (BOOL_T portable, int a, NODE_T * n, char *c, MOID_T * m, int p, GPROC * q) { #define INSERT_TAG(l, n) {\ NEXT (n) = *(l);\ *(l) = (n);\ } TAG_T *new_one = new_tag (); PROCEDURE_LEVEL (INFO (n)) = 0; USE (new_one) = A68_FALSE; HEAP (new_one) = HEAP_SYMBOL; TAG_TABLE (new_one) = a68g_standenv; NODE (new_one) = n; VALUE (new_one) = (c != NO_TEXT ? TEXT (add_token (&top_token, c)) : NO_TEXT); PRIO (new_one) = p; PROCEDURE (new_one) = q; A68G_STANDENV_PROC (new_one) = (BOOL_T) (q != NO_GPROC); UNIT (new_one) = NULL; PORTABLE (new_one) = portable; MOID (new_one) = m; NEXT (new_one) = NO_TAG; if (a == IDENTIFIER) { INSERT_TAG (&IDENTIFIERS (a68g_standenv), new_one); } else if (a == OP_SYMBOL) { INSERT_TAG (&OPERATORS (a68g_standenv), new_one); } else if (a == PRIO_SYMBOL) { INSERT_TAG (&PRIO (a68g_standenv), new_one); } else if (a == INDICANT) { INSERT_TAG (&INDICANTS (a68g_standenv), new_one); } else if (a == LABEL) { INSERT_TAG (&LABELS (a68g_standenv), new_one); } #undef INSERT_TAG } /** @brief Compose PROC moid from arguments - first result, than arguments. @param m Result moid. @return Entry in mode table. **/ static MOID_T *a68_proc (MOID_T * m, ...) { MOID_T *y, **z = &TOP_MOID (&program); PACK_T *p = NO_PACK, *q = NO_PACK; va_list attribute; va_start (attribute, m); while ((y = va_arg (attribute, MOID_T *)) != NO_MOID) { PACK_T *new_one = 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 (add_mode (z, PROC_SYMBOL, count_pack_members (p), NO_NODE, m, p)); } /** @brief Enter an identifier in standenv. @param portable Whether item is portable. @param n Name of identifier. @param m Mode of identifier. @param q Interpreter routine that executes this token. **/ static void a68_idf (BOOL_T portable, char *n, MOID_T * m, GPROC * q) { add_a68g_standenv (portable, IDENTIFIER, some_node (TEXT (add_token (&top_token, n))), NO_TEXT, m, 0, q); } /** @brief Enter a moid in standenv. @param p Sizety. @param t Name of moid. @param m Will point to entry in mode table. **/ static void a68_mode (int p, char *t, MOID_T ** m) { (*m) = add_mode (&TOP_MOID (&program), STANDARD, p, some_node (TEXT (find_keyword (top_keyword, t))), NO_MOID, NO_PACK); } /** @brief Enter a priority in standenv. @param p Name of operator. @param b Priority of operator. **/ static void a68_prio (char *p, int b) { add_a68g_standenv (A68_TRUE, PRIO_SYMBOL, some_node (TEXT (add_token (&top_token, p))), NO_TEXT, NO_MOID, b, NO_GPROC); } /** @brief Enter operator in standenv. @param portable Whether item is portable. @param n Name of operator. @param m Mode of operator. @param q Interpreter routine that executes this token. **/ static void a68_op (BOOL_T portable, char *n, MOID_T * m, GPROC * q) { add_a68g_standenv (portable, OP_SYMBOL, some_node (TEXT (add_token (&top_token, n))), NO_TEXT, m, 0, q); } /** @brief Enter standard modes in standenv. **/ static void stand_moids (void) { MOID_T *m; PACK_T *z; /* Primitive A68 moids */ a68_mode (0, "VOID", &MODE (VOID)); /* Standard precision */ a68_mode (0, "INT", &MODE (INT)); a68_mode (0, "REAL", &MODE (REAL)); a68_mode (0, "COMPLEX", &MODE (COMPLEX)); a68_mode (0, "COMPL", &MODE (COMPL)); a68_mode (0, "BITS", &MODE (BITS)); a68_mode (0, "BYTES", &MODE (BYTES)); /* Multiple precision */ a68_mode (1, "INT", &MODE (LONG_INT)); a68_mode (1, "REAL", &MODE (LONG_REAL)); a68_mode (1, "COMPLEX", &MODE (LONG_COMPLEX)); a68_mode (1, "COMPL", &MODE (LONG_COMPL)); a68_mode (1, "BITS", &MODE (LONG_BITS)); a68_mode (1, "BYTES", &MODE (LONG_BYTES)); a68_mode (2, "REAL", &MODE (LONGLONG_REAL)); a68_mode (2, "INT", &MODE (LONGLONG_INT)); a68_mode (2, "COMPLEX", &MODE (LONGLONG_COMPLEX)); a68_mode (2, "COMPL", &MODE (LONGLONG_COMPL)); a68_mode (2, "BITS", &MODE (LONGLONG_BITS)); /* Other */ a68_mode (0, "BOOL", &MODE (BOOL)); a68_mode (0, "CHAR", &MODE (CHAR)); a68_mode (0, "STRING", &MODE (STRING)); a68_mode (0, "FILE", &MODE (FILE)); a68_mode (0, "CHANNEL", &MODE (CHANNEL)); a68_mode (0, "PIPE", &MODE (PIPE)); a68_mode (0, "FORMAT", &MODE (FORMAT)); a68_mode (0, "SEMA", &MODE (SEMA)); a68_mode (0, "SOUND", &MODE (SOUND)); PORTABLE (MODE (PIPE)) = A68_FALSE; HAS_ROWS (MODE (SOUND)) = A68_TRUE; PORTABLE (MODE (SOUND)) = A68_FALSE; /* ROWS */ MODE (ROWS) = add_mode (&TOP_MOID (&program), ROWS_SYMBOL, 0, NO_NODE, NO_MOID, NO_PACK); /* REFs */ MODE (REF_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (INT), NO_PACK); MODE (REF_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (REAL), NO_PACK); MODE (REF_COMPLEX) = MODE (REF_COMPL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (COMPLEX), NO_PACK); MODE (REF_BITS) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (BITS), NO_PACK); MODE (REF_BYTES) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (BYTES), NO_PACK); MODE (REF_FORMAT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (FORMAT), NO_PACK); MODE (REF_PIPE) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (PIPE), NO_PACK); /* Multiple precision */ MODE (REF_LONG_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_INT), NO_PACK); MODE (REF_LONG_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_REAL), NO_PACK); MODE (REF_LONG_COMPLEX) = MODE (REF_LONG_COMPL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_COMPLEX), NO_PACK); MODE (REF_LONGLONG_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_INT), NO_PACK); MODE (REF_LONGLONG_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_REAL), NO_PACK); MODE (REF_LONGLONG_COMPLEX) = MODE (REF_LONGLONG_COMPL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_COMPLEX), NO_PACK); MODE (REF_LONG_BITS) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_BITS), NO_PACK); MODE (REF_LONGLONG_BITS) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONGLONG_BITS), NO_PACK); MODE (REF_LONG_BYTES) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (LONG_BYTES), NO_PACK); /* Other */ MODE (REF_BOOL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (BOOL), NO_PACK); MODE (REF_CHAR) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (CHAR), NO_PACK); MODE (REF_FILE) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (FILE), NO_PACK); MODE (REF_REF_FILE) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (REF_FILE), NO_PACK); MODE (REF_SOUND) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (SOUND), NO_PACK); /* [] INT */ MODE (ROW_INT) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (INT), NO_PACK); HAS_ROWS (MODE (ROW_INT)) = A68_TRUE; SLICE (MODE (ROW_INT)) = MODE (INT); MODE (REF_ROW_INT) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_INT), NO_PACK); NAME (MODE (REF_ROW_INT)) = MODE (REF_INT); /* [] REAL */ MODE (ROW_REAL) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (REAL), NO_PACK); HAS_ROWS (MODE (ROW_REAL)) = A68_TRUE; SLICE (MODE (ROW_REAL)) = MODE (REAL); MODE (REF_ROW_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_REAL), NO_PACK); NAME (MODE (REF_ROW_REAL)) = MODE (REF_REAL); /* [,] REAL */ MODE (ROWROW_REAL) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 2, NO_NODE, MODE (REAL), NO_PACK); HAS_ROWS (MODE (ROWROW_REAL)) = A68_TRUE; SLICE (MODE (ROWROW_REAL)) = MODE (ROW_REAL); MODE (REF_ROWROW_REAL) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROWROW_REAL), NO_PACK); NAME (MODE (REF_ROWROW_REAL)) = MODE (REF_ROW_REAL); /* [] COMPLEX */ MODE (ROW_COMPLEX) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (COMPLEX), NO_PACK); HAS_ROWS (MODE (ROW_COMPLEX)) = A68_TRUE; SLICE (MODE (ROW_COMPLEX)) = MODE (COMPLEX); MODE (REF_ROW_COMPLEX) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_COMPLEX), NO_PACK); NAME (MODE (REF_ROW_COMPLEX)) = MODE (REF_COMPLEX); /* [,] COMPLEX */ MODE (ROWROW_COMPLEX) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 2, NO_NODE, MODE (COMPLEX), NO_PACK); HAS_ROWS (MODE (ROWROW_COMPLEX)) = A68_TRUE; SLICE (MODE (ROWROW_COMPLEX)) = MODE (ROW_COMPLEX); MODE (REF_ROWROW_COMPLEX) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROWROW_COMPLEX), NO_PACK); NAME (MODE (REF_ROWROW_COMPLEX)) = MODE (REF_ROW_COMPLEX); /* [] BOOL */ MODE (ROW_BOOL) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (BOOL), NO_PACK); HAS_ROWS (MODE (ROW_BOOL)) = A68_TRUE; SLICE (MODE (ROW_BOOL)) = MODE (BOOL); /* FLEX [] BOOL */ m = add_mode (&TOP_MOID (&program), FLEX_SYMBOL, 0, NO_NODE, MODE (ROW_BOOL), NO_PACK); HAS_ROWS (m) = A68_TRUE; MODE (FLEX_ROW_BOOL) = m; /* [] BITS */ MODE (ROW_BITS) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (BITS), NO_PACK); HAS_ROWS (MODE (ROW_BITS)) = A68_TRUE; SLICE (MODE (ROW_BITS)) = MODE (BITS); /* [] LONG BITS */ MODE (ROW_LONG_BITS) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (LONG_BITS), NO_PACK); HAS_ROWS (MODE (ROW_LONG_BITS)) = A68_TRUE; SLICE (MODE (ROW_LONG_BITS)) = MODE (LONG_BITS); /* [] LONG LONG BITS */ MODE (ROW_LONGLONG_BITS) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (LONGLONG_BITS), NO_PACK); HAS_ROWS (MODE (ROW_LONGLONG_BITS)) = A68_TRUE; SLICE (MODE (ROW_LONGLONG_BITS)) = MODE (LONGLONG_BITS); /* [] CHAR */ MODE (ROW_CHAR) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (CHAR), NO_PACK); HAS_ROWS (MODE (ROW_CHAR)) = A68_TRUE; SLICE (MODE (ROW_CHAR)) = MODE (CHAR); /* [][] CHAR */ MODE (ROW_ROW_CHAR) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (ROW_CHAR), NO_PACK); HAS_ROWS (MODE (ROW_ROW_CHAR)) = A68_TRUE; SLICE (MODE (ROW_ROW_CHAR)) = MODE (ROW_CHAR); /* MODE STRING = FLEX [] CHAR */ m = add_mode (&TOP_MOID (&program), FLEX_SYMBOL, 0, NO_NODE, MODE (ROW_CHAR), NO_PACK); HAS_ROWS (m) = A68_TRUE; MODE (FLEX_ROW_CHAR) = m; EQUIVALENT (MODE (STRING)) = m; /* REF [] CHAR */ MODE (REF_ROW_CHAR) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, MODE (ROW_CHAR), NO_PACK); NAME (MODE (REF_ROW_CHAR)) = MODE (REF_CHAR); /* PROC [] CHAR */ MODE (PROC_ROW_CHAR) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, 0, NO_NODE, MODE (ROW_CHAR), NO_PACK); /* REF STRING = REF FLEX [] CHAR */ MODE (REF_STRING) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, EQUIVALENT (MODE (STRING)), NO_PACK); NAME (MODE (REF_STRING)) = MODE (REF_CHAR); DEFLEXED (MODE (REF_STRING)) = MODE (REF_ROW_CHAR); /* [] STRING */ MODE (ROW_STRING) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (STRING), NO_PACK); HAS_ROWS (MODE (ROW_STRING)) = A68_TRUE; SLICE (MODE (ROW_STRING)) = MODE (STRING); DEFLEXED (MODE (ROW_STRING)) = MODE (ROW_ROW_CHAR); /* PROC STRING */ MODE (PROC_STRING) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, 0, NO_NODE, MODE (STRING), NO_PACK); DEFLEXED (MODE (PROC_STRING)) = MODE (PROC_ROW_CHAR); /* COMPLEX */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); EQUIVALENT (MODE (COMPLEX)) = EQUIVALENT (MODE (COMPL)) = m; z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); NAME (MODE (REF_COMPLEX)) = NAME (MODE (REF_COMPL)) = m; /* LONG COMPLEX */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (LONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (LONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); EQUIVALENT (MODE (LONG_COMPLEX)) = EQUIVALENT (MODE (LONG_COMPL)) = m; z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_LONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_LONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); NAME (MODE (REF_LONG_COMPLEX)) = NAME (MODE (REF_LONG_COMPL)) = m; /* LONG_LONG COMPLEX */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (LONGLONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (LONGLONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); EQUIVALENT (MODE (LONGLONG_COMPLEX)) = EQUIVALENT (MODE (LONGLONG_COMPL)) = m; z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_LONGLONG_REAL), TEXT (add_token (&top_token, "im")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_LONGLONG_REAL), TEXT (add_token (&top_token, "re")), NO_NODE); m = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); NAME (MODE (REF_LONGLONG_COMPLEX)) = NAME (MODE (REF_LONGLONG_COMPL)) = m; /* NUMBER */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (INT), NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, MODE (LONG_INT), NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, MODE (LONGLONG_INT), NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, MODE (REAL), NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, MODE (LONG_REAL), NO_TEXT, NO_NODE); (void) add_mode_to_pack (&z, MODE (LONGLONG_REAL), NO_TEXT, NO_NODE); MODE (NUMBER) = add_mode (&TOP_MOID (&program), UNION_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); /* SEMA */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_INT), NO_TEXT, NO_NODE); EQUIVALENT (MODE (SEMA)) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); /* PROC VOID */ z = NO_PACK; MODE (PROC_VOID) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (VOID), z); /* PROC (REAL) REAL */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REAL), NO_TEXT, NO_NODE); MODE (PROC_REAL_REAL) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (REAL), z); /* IO: PROC (REF FILE) BOOL */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_FILE), NO_TEXT, NO_NODE); MODE (PROC_REF_FILE_BOOL) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (BOOL), z); /* IO: PROC (REF FILE) VOID */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_FILE), NO_TEXT, NO_NODE); MODE (PROC_REF_FILE_VOID) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (z), NO_NODE, MODE (VOID), z); /* IO: SIMPLIN and SIMPLOUT */ MODE (SIMPLIN) = add_mode (&TOP_MOID (&program), IN_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK); MODE (ROW_SIMPLIN) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (SIMPLIN), NO_PACK); SLICE (MODE (ROW_SIMPLIN)) = MODE (SIMPLIN); MODE (SIMPLOUT) = add_mode (&TOP_MOID (&program), OUT_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK); MODE (ROW_SIMPLOUT) = add_mode (&TOP_MOID (&program), ROW_SYMBOL, 1, NO_NODE, MODE (SIMPLOUT), NO_PACK); SLICE (MODE (ROW_SIMPLOUT)) = MODE (SIMPLOUT); /* PIPE */ z = NO_PACK; (void) add_mode_to_pack (&z, MODE (INT), TEXT (add_token (&top_token, "pid")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_FILE), TEXT (add_token (&top_token, "write")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_FILE), TEXT (add_token (&top_token, "read")), NO_NODE); EQUIVALENT (MODE (PIPE)) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); z = NO_PACK; (void) add_mode_to_pack (&z, MODE (REF_INT), TEXT (add_token (&top_token, "pid")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_REF_FILE), TEXT (add_token (&top_token, "write")), NO_NODE); (void) add_mode_to_pack (&z, MODE (REF_REF_FILE), TEXT (add_token (&top_token, "read")), NO_NODE); NAME (MODE (REF_PIPE)) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, count_pack_members (z), NO_NODE, NO_MOID, z); } /** @brief Set up standenv - general RR but not transput. **/ static void stand_prelude (void) { MOID_T *m; /* Identifiers */ a68_idf (A68_STD, "intlengths", MODE (INT), genie_int_lengths); a68_idf (A68_STD, "intshorths", MODE (INT), genie_int_shorths); a68_idf (A68_STD, "maxint", MODE (INT), genie_max_int); a68_idf (A68_STD, "maxreal", MODE (REAL), genie_max_real); a68_idf (A68_STD, "minreal", MODE (REAL), genie_min_real); a68_idf (A68_STD, "smallreal", MODE (REAL), genie_small_real); a68_idf (A68_STD, "reallengths", MODE (INT), genie_real_lengths); a68_idf (A68_STD, "realshorths", MODE (INT), genie_real_shorths); a68_idf (A68_STD, "compllengths", MODE (INT), genie_complex_lengths); a68_idf (A68_STD, "complshorths", MODE (INT), genie_complex_shorths); a68_idf (A68_STD, "bitslengths", MODE (INT), genie_bits_lengths); a68_idf (A68_STD, "bitsshorths", MODE (INT), genie_bits_shorths); a68_idf (A68_STD, "bitswidth", MODE (INT), genie_bits_width); a68_idf (A68_STD, "longbitswidth", MODE (INT), genie_long_bits_width); a68_idf (A68_STD, "longlongbitswidth", MODE (INT), genie_longlong_bits_width); a68_idf (A68_STD, "maxbits", MODE (BITS), genie_max_bits); a68_idf (A68_STD, "longmaxbits", MODE (LONG_BITS), genie_long_max_bits); a68_idf (A68_STD, "longlongmaxbits", MODE (LONGLONG_BITS), genie_longlong_max_bits); a68_idf (A68_STD, "byteslengths", MODE (INT), genie_bytes_lengths); a68_idf (A68_STD, "bytesshorths", MODE (INT), genie_bytes_shorths); a68_idf (A68_STD, "byteswidth", MODE (INT), genie_bytes_width); a68_idf (A68_STD, "maxabschar", MODE (INT), genie_max_abs_char); a68_idf (A68_STD, "pi", MODE (REAL), genie_pi); a68_idf (A68_STD, "dpi", MODE (LONG_REAL), genie_pi_long_mp); a68_idf (A68_STD, "longpi", MODE (LONG_REAL), genie_pi_long_mp); a68_idf (A68_STD, "qpi", MODE (LONGLONG_REAL), genie_pi_long_mp); a68_idf (A68_STD, "longlongpi", MODE (LONGLONG_REAL), genie_pi_long_mp); a68_idf (A68_STD, "intwidth", MODE (INT), genie_int_width); a68_idf (A68_STD, "realwidth", MODE (INT), genie_real_width); a68_idf (A68_STD, "expwidth", MODE (INT), genie_exp_width); a68_idf (A68_STD, "longintwidth", MODE (INT), genie_long_int_width); a68_idf (A68_STD, "longlongintwidth", MODE (INT), genie_longlong_int_width); a68_idf (A68_STD, "longrealwidth", MODE (INT), genie_long_real_width); a68_idf (A68_STD, "longlongrealwidth", MODE (INT), genie_longlong_real_width); a68_idf (A68_STD, "longexpwidth", MODE (INT), genie_long_exp_width); a68_idf (A68_STD, "longlongexpwidth", MODE (INT), genie_longlong_exp_width); a68_idf (A68_STD, "longmaxint", MODE (LONG_INT), genie_long_max_int); a68_idf (A68_STD, "longlongmaxint", MODE (LONGLONG_INT), genie_longlong_max_int); a68_idf (A68_STD, "longsmallreal", MODE (LONG_REAL), genie_long_small_real); a68_idf (A68_STD, "longlongsmallreal", MODE (LONGLONG_REAL), genie_longlong_small_real); a68_idf (A68_STD, "longmaxreal", MODE (LONG_REAL), genie_long_max_real); a68_idf (A68_STD, "longminreal", MODE (LONG_REAL), genie_long_min_real); a68_idf (A68_STD, "longlongmaxreal", MODE (LONGLONG_REAL), genie_longlong_max_real); a68_idf (A68_STD, "longlongminreal", MODE (LONGLONG_REAL), genie_longlong_min_real); a68_idf (A68_STD, "longbyteswidth", MODE (INT), genie_long_bytes_width); a68_idf (A68_EXT, "seconds", MODE (REAL), genie_cputime); a68_idf (A68_EXT, "clock", MODE (REAL), genie_cputime); a68_idf (A68_EXT, "cputime", MODE (REAL), genie_cputime); a68_idf (A68_EXT, "collections", proc_int, genie_garbage_collections); a68_idf (A68_EXT, "blocks",proc_int, genie_block); m = a68_proc (MODE (VOID), proc_void, NO_MOID); a68_idf (A68_EXT, "ongcevent", m, genie_on_gc_event); m = a68_proc (MODE (LONG_INT), NO_MOID); a68_idf (A68_EXT, "garbage", m, genie_garbage_freed); a68_idf (A68_EXT, "collectseconds", proc_real, genie_garbage_seconds); a68_idf (A68_EXT, "stackpointer", MODE (INT), genie_stack_pointer); a68_idf (A68_EXT, "systemstackpointer", MODE (INT), genie_system_stack_pointer); a68_idf (A68_EXT, "systemstacksize", MODE (INT), genie_system_stack_size); a68_idf (A68_EXT, "actualstacksize", MODE (INT), genie_stack_pointer); m = proc_void; a68_idf (A68_EXT, "gcheap", m, genie_gc_heap); a68_idf (A68_EXT, "sweepheap", m, genie_gc_heap); a68_idf (A68_EXT, "preemptivegc", m, genie_preemptive_gc_heap); a68_idf (A68_EXT, "preemptivesweep", m, genie_preemptive_gc_heap); a68_idf (A68_EXT, "preemptivesweepheap", m, genie_preemptive_gc_heap); a68_idf (A68_EXT, "break", m, genie_break); a68_idf (A68_EXT, "debug", m, genie_debug); a68_idf (A68_EXT, "monitor", m, genie_debug); m = a68_proc (MODE (VOID), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "abend", m, genie_abend); m = a68_proc (MODE (STRING), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "evaluate", m, genie_evaluate); m = a68_proc (MODE (INT), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "system", m, genie_system); m = a68_proc (MODE (STRING), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "acronym", m, genie_acronym); a68_idf (A68_EXT, "vmsacronym", m, genie_acronym); /* BITS procedures */ m = a68_proc (MODE (BITS), MODE (ROW_BOOL), NO_MOID); a68_idf (A68_STD, "bitspack", m, genie_bits_pack); m = a68_proc (MODE (LONG_BITS), MODE (ROW_BOOL), NO_MOID); a68_idf (A68_STD, "longbitspack", m, genie_long_bits_pack); m = a68_proc (MODE (LONGLONG_BITS), MODE (ROW_BOOL), NO_MOID); a68_idf (A68_STD, "longlongbitspack", m, genie_long_bits_pack); /* RNG procedures */ m = a68_proc (MODE (VOID), MODE (INT), NO_MOID); a68_idf (A68_STD, "firstrandom", m, genie_first_random); m = proc_real; a68_idf (A68_STD, "nextrandom", m, genie_next_random); a68_idf (A68_STD, "random", m, genie_next_random); a68_idf (A68_STD, "rnd", m, genie_next_rnd); m = a68_proc (MODE (LONG_REAL), NO_MOID); a68_idf (A68_STD, "longnextrandom", m, genie_long_next_random); a68_idf (A68_STD, "longrandom", m, genie_long_next_random); m = a68_proc (MODE (LONGLONG_REAL), NO_MOID); a68_idf (A68_STD, "longlongnextrandom", m, genie_long_next_random); a68_idf (A68_STD, "longlongrandom", m, genie_long_next_random); /* 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 ("&", 3); a68_prio ("XOR", 3); a68_prio ("=", 4); a68_prio ("/=", 4); 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 ("SET", 7); a68_prio ("CLEAR", 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 ("ELEMS", 8); a68_prio ("LWB", 8); a68_prio ("UPB", 8); a68_prio ("SORT", 8); a68_prio ("I", 9); a68_prio ("+*", 9); /* INT ops */ m = a68_proc (MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_int); a68_op (A68_STD, "ABS", m, genie_abs_int); a68_op (A68_STD, "SIGN", m, genie_sign_int); m = a68_proc (MODE (BOOL), MODE (INT), NO_MOID); a68_op (A68_STD, "ODD", m, genie_odd_int); m = a68_proc (MODE (BOOL), MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_int); a68_op (A68_STD, "/=", m, genie_ne_int); a68_op (A68_STD, "~=", m, genie_ne_int); a68_op (A68_STD, "^=", m, genie_ne_int); a68_op (A68_STD, "<", m, genie_lt_int); a68_op (A68_STD, "<=", m, genie_le_int); a68_op (A68_STD, ">", m, genie_gt_int); a68_op (A68_STD, ">=", m, genie_ge_int); a68_op (A68_STD, "EQ", m, genie_eq_int); a68_op (A68_STD, "NE", m, genie_ne_int); a68_op (A68_STD, "LT", m, genie_lt_int); a68_op (A68_STD, "LE", m, genie_le_int); a68_op (A68_STD, "GT", m, genie_gt_int); a68_op (A68_STD, "GE", m, genie_ge_int); m = a68_proc (MODE (INT), MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "+", m, genie_add_int); a68_op (A68_STD, "-", m, genie_sub_int); a68_op (A68_STD, "*", m, genie_mul_int); a68_op (A68_STD, "OVER", m, genie_over_int); a68_op (A68_STD, "%", m, genie_over_int); a68_op (A68_STD, "MOD", m, genie_mod_int); a68_op (A68_STD, "%*", m, genie_mod_int); a68_op (A68_STD, "**", m, genie_pow_int); a68_op (A68_STD, "UP", m, genie_pow_int); a68_op (A68_STD, "^", m, genie_pow_int); m = a68_proc (MODE (REAL), MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "/", m, genie_div_int); m = a68_proc (MODE (REF_INT), MODE (REF_INT), MODE (INT), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_int); a68_op (A68_STD, "-:=", m, genie_minusab_int); a68_op (A68_STD, "*:=", m, genie_timesab_int); a68_op (A68_STD, "%:=", m, genie_overab_int); a68_op (A68_STD, "%*:=", m, genie_modab_int); a68_op (A68_STD, "PLUSAB", m, genie_plusab_int); a68_op (A68_STD, "MINUSAB", m, genie_minusab_int); a68_op (A68_STD, "TIMESAB", m, genie_timesab_int); a68_op (A68_STD, "OVERAB", m, genie_overab_int); a68_op (A68_STD, "MODAB", m, genie_modab_int); /* REAL ops */ m = proc_real_real; a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_real); a68_op (A68_STD, "ABS", m, genie_abs_real); m = a68_proc (MODE (INT), MODE (REAL), NO_MOID); a68_op (A68_STD, "SIGN", m, genie_sign_real); a68_op (A68_STD, "ROUND", m, genie_round_real); a68_op (A68_STD, "ENTIER", m, genie_entier_real); m = a68_proc (MODE (BOOL), MODE (REAL), MODE (REAL), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_real); a68_op (A68_STD, "/=", m, genie_ne_real); a68_op (A68_STD, "~=", m, genie_ne_real); a68_op (A68_STD, "^=", m, genie_ne_real); a68_op (A68_STD, "<", m, genie_lt_real); a68_op (A68_STD, "<=", m, genie_le_real); a68_op (A68_STD, ">", m, genie_gt_real); a68_op (A68_STD, ">=", m, genie_ge_real); a68_op (A68_STD, "EQ", m, genie_eq_real); a68_op (A68_STD, "NE", m, genie_ne_real); a68_op (A68_STD, "LT", m, genie_lt_real); a68_op (A68_STD, "LE", m, genie_le_real); a68_op (A68_STD, "GT", m, genie_gt_real); a68_op (A68_STD, "GE", m, genie_ge_real); m = proc_real_real_real; a68_op (A68_STD, "+", m, genie_add_real); a68_op (A68_STD, "-", m, genie_sub_real); a68_op (A68_STD, "*", m, genie_mul_real); a68_op (A68_STD, "/", m, genie_div_real); a68_op (A68_STD, "**", m, genie_pow_real); a68_op (A68_STD, "UP", m, genie_pow_real); a68_op (A68_STD, "^", m, genie_pow_real); m = a68_proc (MODE (REAL), MODE (REAL), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_real_int); a68_op (A68_STD, "UP", m, genie_pow_real_int); a68_op (A68_STD, "^", m, genie_pow_real_int); m = a68_proc (MODE (REF_REAL), MODE (REF_REAL), MODE (REAL), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_real); a68_op (A68_STD, "-:=", m, genie_minusab_real); a68_op (A68_STD, "*:=", m, genie_timesab_real); a68_op (A68_STD, "/:=", m, genie_divab_real); a68_op (A68_STD, "PLUSAB", m, genie_plusab_real); a68_op (A68_STD, "MINUSAB", m, genie_minusab_real); a68_op (A68_STD, "TIMESAB", m, genie_timesab_real); a68_op (A68_STD, "DIVAB", m, genie_divab_real); m = proc_real_real; a68_idf (A68_STD, "sqrt", m, genie_sqrt_real); a68_idf (A68_EXT, "cbrt", m, genie_curt_real); a68_idf (A68_EXT, "curt", m, genie_curt_real); a68_idf (A68_STD, "exp", m, genie_exp_real); a68_idf (A68_STD, "ln", m, genie_ln_real); a68_idf (A68_STD, "log", m, genie_log_real); a68_idf (A68_STD, "sin", m, genie_sin_real); a68_idf (A68_STD, "cos", m, genie_cos_real); a68_idf (A68_STD, "tan", m, genie_tan_real); a68_idf (A68_STD, "asin", m, genie_arcsin_real); a68_idf (A68_STD, "acos", m, genie_arccos_real); a68_idf (A68_STD, "atan", m, genie_arctan_real); a68_idf (A68_STD, "arcsin", m, genie_arcsin_real); a68_idf (A68_STD, "arccos", m, genie_arccos_real); a68_idf (A68_STD, "arctan", m, genie_arctan_real); a68_idf (A68_EXT, "sinh", m, genie_sinh_real); a68_idf (A68_EXT, "cosh", m, genie_cosh_real); a68_idf (A68_EXT, "tanh", m, genie_tanh_real); a68_idf (A68_EXT, "asinh", m, genie_arcsinh_real); a68_idf (A68_EXT, "acosh", m, genie_arccosh_real); a68_idf (A68_EXT, "atanh", m, genie_arctanh_real); a68_idf (A68_EXT, "arcsinh", m, genie_arcsinh_real); a68_idf (A68_EXT, "arccosh", m, genie_arccosh_real); a68_idf (A68_EXT, "arctanh", m, genie_arctanh_real); a68_idf (A68_EXT, "inverseerf", m, genie_inverf_real); a68_idf (A68_EXT, "inverseerfc", m, genie_inverfc_real); m = proc_real_real_real; a68_idf (A68_EXT, "arctan2", m, genie_atan2_real); m = proc_real_real_real_real; a68_idf (A68_EXT, "lje126", m, genie_lj_e_12_6); a68_idf (A68_EXT, "ljf126", m, genie_lj_f_12_6); /* COMPLEX ops */ m = a68_proc (MODE (COMPLEX), MODE (REAL), MODE (REAL), NO_MOID); a68_op (A68_STD, "I", m, genie_icomplex); a68_op (A68_STD, "+*", m, genie_icomplex); m = a68_proc (MODE (COMPLEX), MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "I", m, genie_iint_complex); a68_op (A68_STD, "+*", m, genie_iint_complex); m = a68_proc (MODE (REAL), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "RE", m, genie_re_complex); a68_op (A68_STD, "IM", m, genie_im_complex); a68_op (A68_STD, "ABS", m, genie_abs_complex); a68_op (A68_STD, "ARG", m, genie_arg_complex); m = proc_complex_complex; a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_complex); a68_op (A68_STD, "CONJ", m, genie_conj_complex); m = a68_proc (MODE (BOOL), MODE (COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_complex); a68_op (A68_STD, "/=", m, genie_ne_complex); a68_op (A68_STD, "~=", m, genie_ne_complex); a68_op (A68_STD, "^=", m, genie_ne_complex); a68_op (A68_STD, "EQ", m, genie_eq_complex); a68_op (A68_STD, "NE", m, genie_ne_complex); m = a68_proc (MODE (COMPLEX), MODE (COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "+", m, genie_add_complex); a68_op (A68_STD, "-", m, genie_sub_complex); a68_op (A68_STD, "*", m, genie_mul_complex); a68_op (A68_STD, "/", m, genie_div_complex); m = a68_proc (MODE (COMPLEX), MODE (COMPLEX), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_complex_int); a68_op (A68_STD, "UP", m, genie_pow_complex_int); a68_op (A68_STD, "^", m, genie_pow_complex_int); m = a68_proc (MODE (REF_COMPLEX), MODE (REF_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_complex); a68_op (A68_STD, "-:=", m, genie_minusab_complex); a68_op (A68_STD, "*:=", m, genie_timesab_complex); a68_op (A68_STD, "/:=", m, genie_divab_complex); a68_op (A68_STD, "PLUSAB", m, genie_plusab_complex); a68_op (A68_STD, "MINUSAB", m, genie_minusab_complex); a68_op (A68_STD, "TIMESAB", m, genie_timesab_complex); a68_op (A68_STD, "DIVAB", m, genie_divab_complex); /* BOOL ops */ m = a68_proc (MODE (BOOL), MODE (BOOL), NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_bool); a68_op (A68_STD, "~", m, genie_not_bool); m = a68_proc (MODE (INT), MODE (BOOL), NO_MOID); a68_op (A68_STD, "ABS", m, genie_abs_bool); m = a68_proc (MODE (BOOL), MODE (BOOL), MODE (BOOL), NO_MOID); a68_op (A68_STD, "OR", m, genie_or_bool); a68_op (A68_STD, "AND", m, genie_and_bool); a68_op (A68_STD, "&", m, genie_and_bool); a68_op (A68_EXT, "XOR", m, genie_xor_bool); a68_op (A68_STD, "=", m, genie_eq_bool); a68_op (A68_STD, "/=", m, genie_ne_bool); a68_op (A68_STD, "~=", m, genie_ne_bool); a68_op (A68_STD, "^=", m, genie_ne_bool); a68_op (A68_STD, "EQ", m, genie_eq_bool); a68_op (A68_STD, "NE", m, genie_ne_bool); /* CHAR ops */ m = a68_proc (MODE (BOOL), MODE (CHAR), MODE (CHAR), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_char); a68_op (A68_STD, "/=", m, genie_ne_char); a68_op (A68_STD, "~=", m, genie_ne_char); a68_op (A68_STD, "^=", m, genie_ne_char); a68_op (A68_STD, "<", m, genie_lt_char); a68_op (A68_STD, "<=", m, genie_le_char); a68_op (A68_STD, ">", m, genie_gt_char); a68_op (A68_STD, ">=", m, genie_ge_char); a68_op (A68_STD, "EQ", m, genie_eq_char); a68_op (A68_STD, "NE", m, genie_ne_char); a68_op (A68_STD, "LT", m, genie_lt_char); a68_op (A68_STD, "LE", m, genie_le_char); a68_op (A68_STD, "GT", m, genie_gt_char); a68_op (A68_STD, "GE", m, genie_ge_char); m = a68_proc (MODE (INT), MODE (CHAR), NO_MOID); a68_op (A68_STD, "ABS", m, genie_abs_char); m = a68_proc (MODE (CHAR), MODE (INT), NO_MOID); a68_op (A68_STD, "REPR", m, genie_repr_char); m = a68_proc (MODE (BOOL), MODE (CHAR), NO_MOID); a68_idf (A68_EXT, "isalnum", m, genie_is_alnum); a68_idf (A68_EXT, "isalpha", m, genie_is_alpha); a68_idf (A68_EXT, "iscntrl", m, genie_is_cntrl); a68_idf (A68_EXT, "isdigit", m, genie_is_digit); a68_idf (A68_EXT, "isgraph", m, genie_is_graph); a68_idf (A68_EXT, "islower", m, genie_is_lower); a68_idf (A68_EXT, "isprint", m, genie_is_print); a68_idf (A68_EXT, "ispunct", m, genie_is_punct); a68_idf (A68_EXT, "isspace", m, genie_is_space); a68_idf (A68_EXT, "isupper", m, genie_is_upper); a68_idf (A68_EXT, "isxdigit", m, genie_is_xdigit); m = a68_proc (MODE (CHAR), MODE (CHAR), NO_MOID); a68_idf (A68_EXT, "tolower", m, genie_to_lower); a68_idf (A68_EXT, "toupper", m, genie_to_upper); /* BITS ops */ m = a68_proc (MODE (INT), MODE (BITS), NO_MOID); a68_op (A68_STD, "ABS", m, genie_abs_bits); m = a68_proc (MODE (BITS), MODE (INT), NO_MOID); a68_op (A68_STD, "BIN", m, genie_bin_int); m = a68_proc (MODE (BITS), MODE (BITS), NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_bits); a68_op (A68_STD, "~", m, genie_not_bits); m = a68_proc (MODE (BOOL), MODE (BITS), MODE (BITS), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_bits); a68_op (A68_STD, "/=", m, genie_ne_bits); a68_op (A68_STD, "~=", m, genie_ne_bits); a68_op (A68_STD, "^=", m, genie_ne_bits); a68_op (A68_STD, "<=", m, genie_le_bits); a68_op (A68_STD, ">=", m, genie_ge_bits); a68_op (A68_STD, "EQ", m, genie_eq_bits); a68_op (A68_STD, "NE", m, genie_ne_bits); a68_op (A68_STD, "LE", m, genie_le_bits); a68_op (A68_STD, "GE", m, genie_ge_bits); m = a68_proc (MODE (BITS), MODE (BITS), MODE (BITS), NO_MOID); a68_op (A68_STD, "AND", m, genie_and_bits); a68_op (A68_STD, "&", m, genie_and_bits); a68_op (A68_STD, "OR", m, genie_or_bits); a68_op (A68_EXT, "XOR", m, genie_xor_bits); m = a68_proc (MODE (BITS), MODE (BITS), MODE (INT), NO_MOID); a68_op (A68_STD, "SHL", m, genie_shl_bits); a68_op (A68_STD, "UP", m, genie_shl_bits); a68_op (A68_STD, "SHR", m, genie_shr_bits); a68_op (A68_STD, "DOWN", m, genie_shr_bits); m = a68_proc (MODE (BOOL), MODE (INT), MODE (BITS), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_bits); m = a68_proc (MODE (BITS), MODE (INT), MODE (BITS), NO_MOID); a68_op (A68_STD, "SET", m, genie_set_bits); a68_op (A68_STD, "CLEAR", m, genie_clear_bits); /* BYTES ops */ m = a68_proc (MODE (BYTES), MODE (STRING), NO_MOID); a68_idf (A68_STD, "bytespack", m, genie_bytespack); m = a68_proc (MODE (CHAR), MODE (INT), MODE (BYTES), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_bytes); m = a68_proc (MODE (BYTES), MODE (BYTES), MODE (BYTES), NO_MOID); a68_op (A68_STD, "+", m, genie_add_bytes); m = a68_proc (MODE (REF_BYTES), MODE (REF_BYTES), MODE (BYTES), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_bytes); a68_op (A68_STD, "PLUSAB", m, genie_plusab_bytes); m = a68_proc (MODE (REF_BYTES), MODE (BYTES), MODE (REF_BYTES), NO_MOID); a68_op (A68_STD, "+=:", m, genie_plusto_bytes); a68_op (A68_STD, "PLUSTO", m, genie_plusto_bytes); m = a68_proc (MODE (BOOL), MODE (BYTES), MODE (BYTES), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_bytes); a68_op (A68_STD, "/=", m, genie_ne_bytes); a68_op (A68_STD, "~=", m, genie_ne_bytes); a68_op (A68_STD, "^=", m, genie_ne_bytes); a68_op (A68_STD, "<", m, genie_lt_bytes); a68_op (A68_STD, "<=", m, genie_le_bytes); a68_op (A68_STD, ">", m, genie_gt_bytes); a68_op (A68_STD, ">=", m, genie_ge_bytes); a68_op (A68_STD, "EQ", m, genie_eq_bytes); a68_op (A68_STD, "NE", m, genie_ne_bytes); a68_op (A68_STD, "LT", m, genie_lt_bytes); a68_op (A68_STD, "LE", m, genie_le_bytes); a68_op (A68_STD, "GT", m, genie_gt_bytes); a68_op (A68_STD, "GE", m, genie_ge_bytes); /* LONG BYTES ops */ m = a68_proc (MODE (LONG_BYTES), MODE (BYTES), NO_MOID); a68_op (A68_STD, "LENG", m, genie_leng_bytes); m = a68_proc (MODE (BYTES), MODE (LONG_BYTES), NO_MOID); a68_idf (A68_STD, "SHORTEN", m, genie_shorten_bytes); m = a68_proc (MODE (LONG_BYTES), MODE (STRING), NO_MOID); a68_idf (A68_STD, "longbytespack", m, genie_long_bytespack); m = a68_proc (MODE (CHAR), MODE (INT), MODE (LONG_BYTES), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_long_bytes); m = a68_proc (MODE (LONG_BYTES), MODE (LONG_BYTES), MODE (LONG_BYTES), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_bytes); m = a68_proc (MODE (REF_LONG_BYTES), MODE (REF_LONG_BYTES), MODE (LONG_BYTES), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_bytes); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_bytes); m = a68_proc (MODE (REF_LONG_BYTES), MODE (LONG_BYTES), MODE (REF_LONG_BYTES), NO_MOID); a68_op (A68_STD, "+=:", m, genie_plusto_long_bytes); a68_op (A68_STD, "PLUSTO", m, genie_plusto_long_bytes); m = a68_proc (MODE (BOOL), MODE (LONG_BYTES), MODE (LONG_BYTES), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_bytes); a68_op (A68_STD, "/=", m, genie_ne_long_bytes); a68_op (A68_STD, "~=", m, genie_ne_long_bytes); a68_op (A68_STD, "^=", m, genie_ne_long_bytes); a68_op (A68_STD, "<", m, genie_lt_long_bytes); a68_op (A68_STD, "<=", m, genie_le_long_bytes); a68_op (A68_STD, ">", m, genie_gt_long_bytes); a68_op (A68_STD, ">=", m, genie_ge_long_bytes); a68_op (A68_STD, "EQ", m, genie_eq_long_bytes); a68_op (A68_STD, "NE", m, genie_ne_long_bytes); a68_op (A68_STD, "LT", m, genie_lt_long_bytes); a68_op (A68_STD, "LE", m, genie_le_long_bytes); a68_op (A68_STD, "GT", m, genie_gt_long_bytes); a68_op (A68_STD, "GE", m, genie_ge_long_bytes); /* STRING ops */ m = a68_proc (MODE (BOOL), MODE (STRING), MODE (STRING), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_string); a68_op (A68_STD, "/=", m, genie_ne_string); a68_op (A68_STD, "~=", m, genie_ne_string); a68_op (A68_STD, "^=", m, genie_ne_string); a68_op (A68_STD, "<", m, genie_lt_string); a68_op (A68_STD, "<=", m, genie_le_string); a68_op (A68_STD, ">=", m, genie_ge_string); a68_op (A68_STD, ">", m, genie_gt_string); a68_op (A68_STD, "EQ", m, genie_eq_string); a68_op (A68_STD, "NE", m, genie_ne_string); a68_op (A68_STD, "LT", m, genie_lt_string); a68_op (A68_STD, "LE", m, genie_le_string); a68_op (A68_STD, "GE", m, genie_ge_string); a68_op (A68_STD, "GT", m, genie_gt_string); m = a68_proc (MODE (STRING), MODE (CHAR), MODE (CHAR), NO_MOID); a68_op (A68_STD, "+", m, genie_add_char); m = a68_proc (MODE (STRING), MODE (STRING), MODE (STRING), NO_MOID); a68_op (A68_STD, "+", m, genie_add_string); m = a68_proc (MODE (REF_STRING), MODE (REF_STRING), MODE (STRING), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_string); a68_op (A68_STD, "PLUSAB", m, genie_plusab_string); m = a68_proc (MODE (REF_STRING), MODE (REF_STRING), MODE (INT), NO_MOID); a68_op (A68_STD, "*:=", m, genie_timesab_string); a68_op (A68_STD, "TIMESAB", m, genie_timesab_string); m = a68_proc (MODE (REF_STRING), MODE (STRING), MODE (REF_STRING), NO_MOID); a68_op (A68_STD, "+=:", m, genie_plusto_string); a68_op (A68_STD, "PLUSTO", m, genie_plusto_string); m = a68_proc (MODE (STRING), MODE (STRING), MODE (INT), NO_MOID); a68_op (A68_STD, "*", m, genie_times_string_int); m = a68_proc (MODE (STRING), MODE (INT), MODE (STRING), NO_MOID); a68_op (A68_STD, "*", m, genie_times_int_string); m = a68_proc (MODE (STRING), MODE (INT), MODE (CHAR), NO_MOID); a68_op (A68_STD, "*", m, genie_times_int_char); m = a68_proc (MODE (STRING), MODE (CHAR), MODE (INT), NO_MOID); a68_op (A68_STD, "*", m, genie_times_char_int); m = a68_proc (MODE (CHAR), MODE (INT), MODE (ROW_CHAR), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_string); /* SEMA ops */ #if defined HAVE_PARALLEL_CLAUSE m = a68_proc (MODE (SEMA), MODE (INT), NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_level_sema_int); m = a68_proc (MODE (INT), MODE (SEMA), NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_level_int_sema); m = a68_proc (MODE (VOID), MODE (SEMA), NO_MOID); a68_op (A68_STD, "UP", m, genie_up_sema); a68_op (A68_STD, "DOWN", m, genie_down_sema); #else m = a68_proc (MODE (SEMA), MODE (INT), NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_unimplemented); m = a68_proc (MODE (INT), MODE (SEMA), NO_MOID); a68_op (A68_STD, "LEVEL", m, genie_unimplemented); m = a68_proc (MODE (VOID), MODE (SEMA), NO_MOID); a68_op (A68_STD, "UP", m, genie_unimplemented); a68_op (A68_STD, "DOWN", m, genie_unimplemented); #endif /* ROWS ops */ m = a68_proc (MODE (INT), MODE (ROWS), NO_MOID); a68_op (A68_EXT, "ELEMS", m, genie_monad_elems); a68_op (A68_STD, "LWB", m, genie_monad_lwb); a68_op (A68_STD, "UPB", m, genie_monad_upb); m = a68_proc (MODE (INT), MODE (INT), MODE (ROWS), NO_MOID); a68_op (A68_EXT, "ELEMS", m, genie_dyad_elems); a68_op (A68_STD, "LWB", m, genie_dyad_lwb); a68_op (A68_STD, "UPB", m, genie_dyad_upb); m = a68_proc (MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID); a68_op (A68_EXT, "SORT", m, genie_sort_row_string); /* Binding for the multiple-precision library */ /* LONG INT */ m = a68_proc (MODE (LONG_INT), MODE (INT), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_int_to_long_mp); m = a68_proc (MODE (LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_mp); a68_op (A68_STD, "ABS", m, genie_abs_long_mp); m = a68_proc (MODE (INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_int); a68_op (A68_STD, "SIGN", m, genie_sign_long_mp); m = a68_proc (MODE (BOOL), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "ODD", m, genie_odd_long_mp); m = a68_proc (MODE (LONG_INT), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "ENTIER", m, genie_entier_long_mp); a68_op (A68_STD, "ROUND", m, genie_round_long_mp); m = a68_proc (MODE (LONG_INT), MODE (LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_int); a68_op (A68_STD, "-", m, genie_sub_long_int); a68_op (A68_STD, "*", m, genie_mul_long_int); a68_op (A68_STD, "OVER", m, genie_over_long_mp); a68_op (A68_STD, "%", m, genie_over_long_mp); a68_op (A68_STD, "MOD", m, genie_mod_long_mp); a68_op (A68_STD, "%*", m, genie_mod_long_mp); m = a68_proc (MODE (REF_LONG_INT), MODE (REF_LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_int); a68_op (A68_STD, "-:=", m, genie_minusab_long_int); a68_op (A68_STD, "*:=", m, genie_timesab_long_int); a68_op (A68_STD, "%:=", m, genie_overab_long_mp); a68_op (A68_STD, "%*:=", m, genie_modab_long_mp); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_int); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_int); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_int); a68_op (A68_STD, "OVERAB", m, genie_overab_long_mp); a68_op (A68_STD, "MODAB", m, genie_modab_long_mp); m = a68_proc (MODE (BOOL), MODE (LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<", m, genie_lt_long_mp); a68_op (A68_STD, "LT", m, genie_lt_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_mp); a68_op (A68_STD, "LE", m, genie_le_long_mp); a68_op (A68_STD, ">", m, genie_gt_long_mp); a68_op (A68_STD, "GT", m, genie_gt_long_mp); a68_op (A68_STD, ">=", m, genie_ge_long_mp); a68_op (A68_STD, "GE", m, genie_ge_long_mp); m = a68_proc (MODE (LONG_REAL), MODE (LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "/", m, genie_div_long_mp); m = a68_proc (MODE (LONG_INT), MODE (LONG_INT), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_mp_int_int); a68_op (A68_STD, "^", m, genie_pow_long_mp_int_int); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); /* LONG REAL */ m = a68_proc (MODE (LONG_REAL), MODE (REAL), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_real_to_long_mp); m = a68_proc (MODE (REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_real); m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_mp); a68_op (A68_STD, "ABS", m, genie_abs_long_mp); a68_idf (A68_STD, "longsqrt", m, genie_sqrt_long_mp); a68_idf (A68_EXT, "longcbrt", m, genie_curt_long_mp); a68_idf (A68_EXT, "longcurt", m, genie_curt_long_mp); a68_idf (A68_STD, "longexp", m, genie_exp_long_mp); a68_idf (A68_STD, "longln", m, genie_ln_long_mp); a68_idf (A68_STD, "longlog", m, genie_log_long_mp); a68_idf (A68_STD, "longsin", m, genie_sin_long_mp); a68_idf (A68_STD, "longcos", m, genie_cos_long_mp); a68_idf (A68_STD, "longtan", m, genie_tan_long_mp); a68_idf (A68_STD, "longasin", m, genie_asin_long_mp); a68_idf (A68_STD, "longacos", m, genie_acos_long_mp); a68_idf (A68_STD, "longatan", m, genie_atan_long_mp); a68_idf (A68_STD, "longarcsin", m, genie_asin_long_mp); a68_idf (A68_STD, "longarccos", m, genie_acos_long_mp); a68_idf (A68_STD, "longarctan", m, genie_atan_long_mp); a68_idf (A68_EXT, "longsinh", m, genie_sinh_long_mp); a68_idf (A68_EXT, "longcosh", m, genie_cosh_long_mp); a68_idf (A68_EXT, "longtanh", m, genie_tanh_long_mp); a68_idf (A68_EXT, "longasinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "longacosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "longatanh", m, genie_arctanh_long_mp); a68_idf (A68_EXT, "longarcsinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "longarccosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "longarctanh", m, genie_arctanh_long_mp); a68_idf (A68_EXT, "dsqrt", m, genie_sqrt_long_mp); a68_idf (A68_EXT, "dcbrt", m, genie_curt_long_mp); a68_idf (A68_EXT, "dcurt", m, genie_curt_long_mp); a68_idf (A68_EXT, "dexp", m, genie_exp_long_mp); a68_idf (A68_EXT, "dln", m, genie_ln_long_mp); a68_idf (A68_EXT, "dlog", m, genie_log_long_mp); a68_idf (A68_EXT, "dsin", m, genie_sin_long_mp); a68_idf (A68_EXT, "dcos", m, genie_cos_long_mp); a68_idf (A68_EXT, "dtan", m, genie_tan_long_mp); a68_idf (A68_EXT, "dasin", m, genie_asin_long_mp); a68_idf (A68_EXT, "dacos", m, genie_acos_long_mp); a68_idf (A68_EXT, "datan", m, genie_atan_long_mp); a68_idf (A68_EXT, "dsinh", m, genie_sinh_long_mp); a68_idf (A68_EXT, "dcosh", m, genie_cosh_long_mp); a68_idf (A68_EXT, "dtanh", m, genie_tanh_long_mp); a68_idf (A68_EXT, "dasinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "dacosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "datanh", m, genie_arctanh_long_mp); m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_idf (A68_STD, "longarctan2", m, genie_atan2_long_mp); a68_idf (A68_STD, "darctan2", m, genie_atan2_long_mp); m = a68_proc (MODE (INT), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "SIGN", m, genie_sign_long_mp); m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_mp); a68_op (A68_STD, "-", m, genie_sub_long_mp); a68_op (A68_STD, "*", m, genie_mul_long_mp); a68_op (A68_STD, "/", m, genie_div_long_mp); a68_op (A68_STD, "**", m, genie_pow_long_mp); a68_op (A68_STD, "UP", m, genie_pow_long_mp); a68_op (A68_STD, "^", m, genie_pow_long_mp); m = a68_proc (MODE (REF_LONG_REAL), MODE (REF_LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_mp); a68_op (A68_STD, "-:=", m, genie_minusab_long_mp); a68_op (A68_STD, "*:=", m, genie_timesab_long_mp); a68_op (A68_STD, "/:=", m, genie_divab_long_mp); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_mp); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_mp); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_mp); a68_op (A68_STD, "DIVAB", m, genie_divab_long_mp); m = a68_proc (MODE (BOOL), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<", m, genie_lt_long_mp); a68_op (A68_STD, "LT", m, genie_lt_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_mp); a68_op (A68_STD, "LE", m, genie_le_long_mp); a68_op (A68_STD, ">", m, genie_gt_long_mp); a68_op (A68_STD, "GT", m, genie_gt_long_mp); a68_op (A68_STD, ">=", m, genie_ge_long_mp); a68_op (A68_STD, "GE", m, genie_ge_long_mp); m = a68_proc (MODE (LONG_REAL), MODE (LONG_REAL), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_mp_int); a68_op (A68_STD, "UP", m, genie_pow_long_mp_int); a68_op (A68_STD, "^", m, genie_pow_long_mp_int); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); /* LONG COMPLEX */ m = a68_proc (MODE (LONG_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_complex_to_long_complex); m = a68_proc (MODE (COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_complex_to_complex); m = a68_proc (MODE (LONG_REAL), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "RE", m, genie_re_long_complex); a68_op (A68_STD, "IM", m, genie_im_long_complex); a68_op (A68_STD, "ARG", m, genie_arg_long_complex); a68_op (A68_STD, "ABS", m, genie_abs_long_complex); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_complex); a68_op (A68_STD, "CONJ", m, genie_conj_long_complex); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_complex); a68_op (A68_STD, "-", m, genie_sub_long_complex); a68_op (A68_STD, "*", m, genie_mul_long_complex); a68_op (A68_STD, "/", m, genie_div_long_complex); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_complex_int); a68_op (A68_STD, "UP", m, genie_pow_long_complex_int); a68_op (A68_STD, "^", m, genie_pow_long_complex_int); m = a68_proc (MODE (BOOL), MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_complex); a68_op (A68_STD, "EQ", m, genie_eq_long_complex); a68_op (A68_STD, "/=", m, genie_ne_long_complex); a68_op (A68_STD, "~=", m, genie_ne_long_complex); a68_op (A68_STD, "^=", m, genie_ne_long_complex); a68_op (A68_STD, "NE", m, genie_ne_long_complex); m = a68_proc (MODE (REF_LONG_COMPLEX), MODE (REF_LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_complex); a68_op (A68_STD, "-:=", m, genie_minusab_long_complex); a68_op (A68_STD, "*:=", m, genie_timesab_long_complex); a68_op (A68_STD, "/:=", m, genie_divab_long_complex); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_complex); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_complex); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_complex); a68_op (A68_STD, "DIVAB", m, genie_divab_long_complex); /* LONG BITS ops */ m = a68_proc (MODE (LONG_INT), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "ABS", m, genie_idle); m = a68_proc (MODE (LONG_BITS), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "BIN", m, genie_bin_long_mp); m = a68_proc (MODE (BITS), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_long_mp_to_bits); m = a68_proc (MODE (LONG_BITS), MODE (BITS), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_unsigned_to_long_mp); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_long_mp_to_longlong_mp); m = a68_proc (MODE (LONG_BITS), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_long_mp); a68_op (A68_STD, "~", m, genie_not_long_mp); m = a68_proc (MODE (BOOL), MODE (LONG_BITS), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_bits); a68_op (A68_STD, "LE", m, genie_le_long_bits); a68_op (A68_STD, ">=", m, genie_ge_long_bits); a68_op (A68_STD, "GE", m, genie_ge_long_bits); m = a68_proc (MODE (LONG_BITS), MODE (LONG_BITS), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "AND", m, genie_and_long_mp); a68_op (A68_STD, "&", m, genie_and_long_mp); a68_op (A68_STD, "OR", m, genie_or_long_mp); a68_op (A68_EXT, "XOR", m, genie_xor_long_mp); m = a68_proc (MODE (LONG_BITS), MODE (LONG_BITS), MODE (INT), NO_MOID); a68_op (A68_STD, "SHL", m, genie_shl_long_mp); a68_op (A68_STD, "UP", m, genie_shl_long_mp); a68_op (A68_STD, "SHR", m, genie_shr_long_mp); a68_op (A68_STD, "DOWN", m, genie_shr_long_mp); m = a68_proc (MODE (BOOL), MODE (INT), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_long_bits); m = a68_proc (MODE (LONG_BITS), MODE (INT), MODE (LONG_BITS), NO_MOID); a68_op (A68_STD, "SET", m, genie_set_long_bits); a68_op (A68_STD, "CLEAR", m, genie_clear_long_bits); /* LONG LONG INT */ m = a68_proc (MODE (LONGLONG_INT), MODE (LONG_INT), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_long_mp_to_longlong_mp); m = a68_proc (MODE (LONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_mp_to_long_mp); m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_mp); a68_op (A68_STD, "ABS", m, genie_abs_long_mp); m = a68_proc (MODE (INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "SIGN", m, genie_sign_long_mp); m = a68_proc (MODE (BOOL), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "ODD", m, genie_odd_long_mp); m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "ENTIER", m, genie_entier_long_mp); a68_op (A68_STD, "ROUND", m, genie_round_long_mp); m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_int); a68_op (A68_STD, "-", m, genie_sub_long_int); a68_op (A68_STD, "*", m, genie_mul_long_int); a68_op (A68_STD, "OVER", m, genie_over_long_mp); a68_op (A68_STD, "%", m, genie_over_long_mp); a68_op (A68_STD, "MOD", m, genie_mod_long_mp); a68_op (A68_STD, "%*", m, genie_mod_long_mp); m = a68_proc (MODE (REF_LONGLONG_INT), MODE (REF_LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_int); a68_op (A68_STD, "-:=", m, genie_minusab_long_int); a68_op (A68_STD, "*:=", m, genie_timesab_long_int); a68_op (A68_STD, "%:=", m, genie_overab_long_mp); a68_op (A68_STD, "%*:=", m, genie_modab_long_mp); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_int); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_int); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_int); a68_op (A68_STD, "OVERAB", m, genie_overab_long_mp); a68_op (A68_STD, "MODAB", m, genie_modab_long_mp); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "/", m, genie_div_long_mp); m = a68_proc (MODE (BOOL), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<", m, genie_lt_long_mp); a68_op (A68_STD, "LT", m, genie_lt_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_mp); a68_op (A68_STD, "LE", m, genie_le_long_mp); a68_op (A68_STD, ">", m, genie_gt_long_mp); a68_op (A68_STD, "GT", m, genie_gt_long_mp); a68_op (A68_STD, ">=", m, genie_ge_long_mp); a68_op (A68_STD, "GE", m, genie_ge_long_mp); m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_mp_int_int); a68_op (A68_STD, "^", m, genie_pow_long_mp_int_int); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); /* LONG LONG REAL */ m = a68_proc (MODE (LONGLONG_REAL), MODE (LONG_REAL), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_long_mp_to_longlong_mp); m = a68_proc (MODE (LONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_mp_to_long_mp); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_mp); a68_op (A68_STD, "ABS", m, genie_abs_long_mp); a68_idf (A68_STD, "longlongsqrt", m, genie_sqrt_long_mp); a68_idf (A68_EXT, "longlongcbrt", m, genie_curt_long_mp); a68_idf (A68_EXT, "longlongcurt", m, genie_curt_long_mp); a68_idf (A68_STD, "longlongexp", m, genie_exp_long_mp); a68_idf (A68_STD, "longlongln", m, genie_ln_long_mp); a68_idf (A68_STD, "longlonglog", m, genie_log_long_mp); a68_idf (A68_STD, "longlongsin", m, genie_sin_long_mp); a68_idf (A68_STD, "longlongcos", m, genie_cos_long_mp); a68_idf (A68_STD, "longlongtan", m, genie_tan_long_mp); a68_idf (A68_STD, "longlongasin", m, genie_asin_long_mp); a68_idf (A68_STD, "longlongacos", m, genie_acos_long_mp); a68_idf (A68_STD, "longlongatan", m, genie_atan_long_mp); a68_idf (A68_STD, "longlongarcsin", m, genie_asin_long_mp); a68_idf (A68_STD, "longlongarccos", m, genie_acos_long_mp); a68_idf (A68_STD, "longlongarctan", m, genie_atan_long_mp); a68_idf (A68_EXT, "longlongsinh", m, genie_sinh_long_mp); a68_idf (A68_EXT, "longlongcosh", m, genie_cosh_long_mp); a68_idf (A68_EXT, "longlongtanh", m, genie_tanh_long_mp); a68_idf (A68_EXT, "longlongasinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "longlongacosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "longlongatanh", m, genie_arctanh_long_mp); a68_idf (A68_EXT, "longlongarcsinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "longlongarccosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "longlongarctanh", m, genie_arctanh_long_mp); a68_idf (A68_EXT, "qsqrt", m, genie_sqrt_long_mp); a68_idf (A68_EXT, "qcbrt", m, genie_curt_long_mp); a68_idf (A68_EXT, "qcurt", m, genie_curt_long_mp); a68_idf (A68_EXT, "qexp", m, genie_exp_long_mp); a68_idf (A68_EXT, "qln", m, genie_ln_long_mp); a68_idf (A68_EXT, "qlog", m, genie_log_long_mp); a68_idf (A68_EXT, "qsin", m, genie_sin_long_mp); a68_idf (A68_EXT, "qcos", m, genie_cos_long_mp); a68_idf (A68_EXT, "qtan", m, genie_tan_long_mp); a68_idf (A68_EXT, "qasin", m, genie_asin_long_mp); a68_idf (A68_EXT, "qacos", m, genie_acos_long_mp); a68_idf (A68_EXT, "qatan", m, genie_atan_long_mp); a68_idf (A68_EXT, "qsinh", m, genie_sinh_long_mp); a68_idf (A68_EXT, "qcosh", m, genie_cosh_long_mp); a68_idf (A68_EXT, "qtanh", m, genie_tanh_long_mp); a68_idf (A68_EXT, "qasinh", m, genie_arcsinh_long_mp); a68_idf (A68_EXT, "qacosh", m, genie_arccosh_long_mp); a68_idf (A68_EXT, "qatanh", m, genie_arctanh_long_mp); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_idf (A68_STD, "longarctan2", m, genie_atan2_long_mp); a68_idf (A68_STD, "qarctan2", m, genie_atan2_long_mp); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_mp); a68_op (A68_STD, "-", m, genie_sub_long_mp); a68_op (A68_STD, "*", m, genie_mul_long_mp); a68_op (A68_STD, "/", m, genie_div_long_mp); a68_op (A68_STD, "**", m, genie_pow_long_mp); a68_op (A68_STD, "UP", m, genie_pow_long_mp); a68_op (A68_STD, "^", m, genie_pow_long_mp); m = a68_proc (MODE (REF_LONGLONG_REAL), MODE (REF_LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_mp); a68_op (A68_STD, "-:=", m, genie_minusab_long_mp); a68_op (A68_STD, "*:=", m, genie_timesab_long_mp); a68_op (A68_STD, "/:=", m, genie_divab_long_mp); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_mp); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_mp); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_mp); a68_op (A68_STD, "DIVAB", m, genie_divab_long_mp); m = a68_proc (MODE (BOOL), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<", m, genie_lt_long_mp); a68_op (A68_STD, "LT", m, genie_lt_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_mp); a68_op (A68_STD, "LE", m, genie_le_long_mp); a68_op (A68_STD, ">", m, genie_gt_long_mp); a68_op (A68_STD, "GT", m, genie_gt_long_mp); a68_op (A68_STD, ">=", m, genie_ge_long_mp); a68_op (A68_STD, "GE", m, genie_ge_long_mp); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_mp_int); a68_op (A68_STD, "UP", m, genie_pow_long_mp_int); a68_op (A68_STD, "^", m, genie_pow_long_mp_int); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "I", m, genie_idle); a68_op (A68_STD, "+*", m, genie_idle); /* LONGLONG COMPLEX */ m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_op (A68_STD, "LENG", m, genie_lengthen_long_complex_to_longlong_complex); m = a68_proc (MODE (LONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_complex_to_long_complex); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "RE", m, genie_re_long_complex); a68_op (A68_STD, "IM", m, genie_im_long_complex); a68_op (A68_STD, "ARG", m, genie_arg_long_complex); a68_op (A68_STD, "ABS", m, genie_abs_long_complex); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+", m, genie_idle); a68_op (A68_STD, "-", m, genie_minus_long_complex); a68_op (A68_STD, "CONJ", m, genie_conj_long_complex); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+", m, genie_add_long_complex); a68_op (A68_STD, "-", m, genie_sub_long_complex); a68_op (A68_STD, "*", m, genie_mul_long_complex); a68_op (A68_STD, "/", m, genie_div_long_complex); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), MODE (INT), NO_MOID); a68_op (A68_STD, "**", m, genie_pow_long_complex_int); a68_op (A68_STD, "UP", m, genie_pow_long_complex_int); a68_op (A68_STD, "^", m, genie_pow_long_complex_int); m = a68_proc (MODE (BOOL), MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_complex); a68_op (A68_STD, "EQ", m, genie_eq_long_complex); a68_op (A68_STD, "/=", m, genie_ne_long_complex); a68_op (A68_STD, "~=", m, genie_ne_long_complex); a68_op (A68_STD, "^=", m, genie_ne_long_complex); a68_op (A68_STD, "NE", m, genie_ne_long_complex); m = a68_proc (MODE (REF_LONGLONG_COMPLEX), MODE (REF_LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "+:=", m, genie_plusab_long_complex); a68_op (A68_STD, "-:=", m, genie_minusab_long_complex); a68_op (A68_STD, "*:=", m, genie_timesab_long_complex); a68_op (A68_STD, "/:=", m, genie_divab_long_complex); a68_op (A68_STD, "PLUSAB", m, genie_plusab_long_complex); a68_op (A68_STD, "MINUSAB", m, genie_minusab_long_complex); a68_op (A68_STD, "TIMESAB", m, genie_timesab_long_complex); a68_op (A68_STD, "DIVAB", m, genie_divab_long_complex); /* LONG LONG BITS */ m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "ABS", m, genie_idle); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "BIN", m, genie_bin_long_mp); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "NOT", m, genie_not_long_mp); a68_op (A68_STD, "~", m, genie_not_long_mp); m = a68_proc (MODE (LONG_BITS), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_shorten_longlong_mp_to_long_mp); m = a68_proc (MODE (BOOL), MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "=", m, genie_eq_long_mp); a68_op (A68_STD, "EQ", m, genie_eq_long_mp); a68_op (A68_STD, "/=", m, genie_ne_long_mp); a68_op (A68_STD, "~=", m, genie_ne_long_mp); a68_op (A68_STD, "^=", m, genie_ne_long_mp); a68_op (A68_STD, "NE", m, genie_ne_long_mp); a68_op (A68_STD, "<=", m, genie_le_long_mp); a68_op (A68_STD, "LE", m, genie_le_long_mp); a68_op (A68_STD, ">=", m, genie_ge_long_mp); a68_op (A68_STD, "GE", m, genie_ge_long_mp); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "AND", m, genie_and_long_mp); a68_op (A68_STD, "&", m, genie_and_long_mp); a68_op (A68_STD, "OR", m, genie_or_long_mp); a68_op (A68_EXT, "XOR", m, genie_xor_long_mp); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), MODE (INT), NO_MOID); a68_op (A68_STD, "SHL", m, genie_shl_long_mp); a68_op (A68_STD, "UP", m, genie_shl_long_mp); a68_op (A68_STD, "SHR", m, genie_shr_long_mp); a68_op (A68_STD, "DOWN", m, genie_shr_long_mp); m = a68_proc (MODE (BOOL), MODE (INT), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "ELEM", m, genie_elem_longlong_bits); m = a68_proc (MODE (LONGLONG_BITS), MODE (INT), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "SET", m, genie_set_longlong_bits); a68_op (A68_STD, "CLEAR", m, genie_clear_longlong_bits); /* Some "terminators" to handle the mapping of very short or very long modes. This allows you to write SHORT REAL z = SHORTEN pi while everything is silently mapped onto REAL */ m = a68_proc (MODE (LONGLONG_INT), MODE (LONGLONG_INT), NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (MODE (LONGLONG_BITS), MODE (LONGLONG_BITS), NO_MOID); a68_op (A68_STD, "LENG", m, genie_idle); m = a68_proc (MODE (INT), MODE (INT), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = a68_proc (MODE (REAL), MODE (REAL), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = a68_proc (MODE (COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = a68_proc (MODE (BITS), MODE (BITS), NO_MOID); a68_op (A68_STD, "SHORTEN", m, genie_idle); m = proc_complex_complex; a68_idf (A68_EXT, "complexsqrt", m, genie_sqrt_complex); a68_idf (A68_EXT, "csqrt", m, genie_sqrt_complex); a68_idf (A68_EXT, "complexexp", m, genie_exp_complex); a68_idf (A68_EXT, "cexp", m, genie_exp_complex); a68_idf (A68_EXT, "complexln", m, genie_ln_complex); a68_idf (A68_EXT, "cln", m, genie_ln_complex); a68_idf (A68_EXT, "complexsin", m, genie_sin_complex); a68_idf (A68_EXT, "csin", m, genie_sin_complex); a68_idf (A68_EXT, "complexcos", m, genie_cos_complex); a68_idf (A68_EXT, "ccos", m, genie_cos_complex); a68_idf (A68_EXT, "complextan", m, genie_tan_complex); a68_idf (A68_EXT, "ctan", m, genie_tan_complex); a68_idf (A68_EXT, "complexasin", m, genie_arcsin_complex); a68_idf (A68_EXT, "casin", m, genie_arcsin_complex); a68_idf (A68_EXT, "complexacos", m, genie_arccos_complex); a68_idf (A68_EXT, "cacos", m, genie_arccos_complex); a68_idf (A68_EXT, "complexatan", m, genie_arctan_complex); a68_idf (A68_EXT, "catan", m, genie_arctan_complex); a68_idf (A68_EXT, "complexarcsin", m, genie_arcsin_complex); a68_idf (A68_EXT, "carcsin", m, genie_arcsin_complex); a68_idf (A68_EXT, "complexarccos", m, genie_arccos_complex); a68_idf (A68_EXT, "carccos", m, genie_arccos_complex); a68_idf (A68_EXT, "complexarctan", m, genie_arctan_complex); a68_idf (A68_EXT, "carctan", m, genie_arctan_complex); #if defined HAVE_GNU_GSL a68_idf (A68_EXT, "complexsinh", m, genie_sinh_complex); a68_idf (A68_EXT, "csinh", m, genie_sinh_complex); a68_idf (A68_EXT, "complexcosh", m, genie_cosh_complex); a68_idf (A68_EXT, "ccosh", m, genie_cosh_complex); a68_idf (A68_EXT, "complextanh", m, genie_tanh_complex); a68_idf (A68_EXT, "ctanh", m, genie_tanh_complex); a68_idf (A68_EXT, "complexasinh", m, genie_arcsinh_complex); a68_idf (A68_EXT, "casinh", m, genie_arcsinh_complex); a68_idf (A68_EXT, "complexacosh", m, genie_arccosh_complex); a68_idf (A68_EXT, "cacosh", m, genie_arccosh_complex); a68_idf (A68_EXT, "complexatanh", m, genie_arctanh_complex); a68_idf (A68_EXT, "catanh", m, genie_arctanh_complex); a68_idf (A68_EXT, "complexarcsinh", m, genie_arcsinh_complex); a68_idf (A68_EXT, "carcsinh", m, genie_arcsinh_complex); a68_idf (A68_EXT, "complexarccosh", m, genie_arccosh_complex); a68_idf (A68_EXT, "carccosh", m, genie_arccosh_complex); a68_idf (A68_EXT, "complexarctanh", m, genie_arctanh_complex); a68_idf (A68_EXT, "carctanh", m, genie_arctanh_complex); m = a68_proc (MODE (REAL), proc_real_real, MODE (REAL), MODE (REF_REAL), NO_MOID); a68_idf (A68_EXT, "laplace", m, genie_laplace); #endif m = a68_proc (MODE (LONG_COMPLEX), MODE (LONG_COMPLEX), NO_MOID); a68_idf (A68_EXT, "longcomplexsqrt", m, genie_sqrt_long_complex); a68_idf (A68_EXT, "dcsqrt", m, genie_sqrt_long_complex); a68_idf (A68_EXT, "longcomplexexp", m, genie_exp_long_complex); a68_idf (A68_EXT, "dcexp", m, genie_exp_long_complex); a68_idf (A68_EXT, "longcomplexln", m, genie_ln_long_complex); a68_idf (A68_EXT, "dcln", m, genie_ln_long_complex); a68_idf (A68_EXT, "longcomplexsin", m, genie_sin_long_complex); a68_idf (A68_EXT, "dcsin", m, genie_sin_long_complex); a68_idf (A68_EXT, "longcomplexcos", m, genie_cos_long_complex); a68_idf (A68_EXT, "dccos", m, genie_cos_long_complex); a68_idf (A68_EXT, "longcomplextan", m, genie_tan_long_complex); a68_idf (A68_EXT, "dctan", m, genie_tan_long_complex); a68_idf (A68_EXT, "longcomplexarcsin", m, genie_asin_long_complex); a68_idf (A68_EXT, "dcasin", m, genie_asin_long_complex); a68_idf (A68_EXT, "longcomplexarccos", m, genie_acos_long_complex); a68_idf (A68_EXT, "dcacos", m, genie_acos_long_complex); a68_idf (A68_EXT, "longcomplexarctan", m, genie_atan_long_complex); a68_idf (A68_EXT, "dcatan", m, genie_atan_long_complex); m = a68_proc (MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX), NO_MOID); a68_idf (A68_EXT, "longlongcomplexsqrt", m, genie_sqrt_long_complex); a68_idf (A68_EXT, "qcsqrt", m, genie_sqrt_long_complex); a68_idf (A68_EXT, "longlongcomplexexp", m, genie_exp_long_complex); a68_idf (A68_EXT, "qcexp", m, genie_exp_long_complex); a68_idf (A68_EXT, "longlongcomplexln", m, genie_ln_long_complex); a68_idf (A68_EXT, "qcln", m, genie_ln_long_complex); a68_idf (A68_EXT, "longlongcomplexsin", m, genie_sin_long_complex); a68_idf (A68_EXT, "qcsin", m, genie_sin_long_complex); a68_idf (A68_EXT, "longlongcomplexcos", m, genie_cos_long_complex); a68_idf (A68_EXT, "qccos", m, genie_cos_long_complex); a68_idf (A68_EXT, "longlongcomplextan", m, genie_tan_long_complex); a68_idf (A68_EXT, "qctan", m, genie_tan_long_complex); a68_idf (A68_EXT, "longlongcomplexarcsin", m, genie_asin_long_complex); a68_idf (A68_EXT, "qcasin", m, genie_asin_long_complex); a68_idf (A68_EXT, "longlongcomplexarccos", m, genie_acos_long_complex); a68_idf (A68_EXT, "qcacos", m, genie_acos_long_complex); a68_idf (A68_EXT, "longlongcomplexarctan", m, genie_atan_long_complex); a68_idf (A68_EXT, "qcatan", m, genie_atan_long_complex); /* SOUND/RIFF procs */ m = a68_proc (MODE (SOUND), MODE (INT), MODE (INT), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "newsound", m, genie_new_sound); m = a68_proc (MODE (INT), MODE (SOUND), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "getsound", m, genie_get_sound); m = a68_proc (MODE (VOID), MODE (SOUND), MODE (INT), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "setsound", m, genie_set_sound); m = a68_proc (MODE (INT), MODE (SOUND), NO_MOID); a68_op (A68_EXT, "RESOLUTION", m, genie_sound_resolution); a68_op (A68_EXT, "CHANNELS", m, genie_sound_channels); a68_op (A68_EXT, "RATE", m, genie_sound_rate); a68_op (A68_EXT, "SAMPLES", m, genie_sound_samples); } /** @brief Set up standenv - transput. **/ static void stand_transput (void) { MOID_T *m; a68_idf (A68_STD, "errorchar", MODE (CHAR), genie_error_char); a68_idf (A68_STD, "expchar", MODE (CHAR), genie_exp_char); a68_idf (A68_STD, "flip", MODE (CHAR), genie_flip_char); a68_idf (A68_STD, "flop", MODE (CHAR), genie_flop_char); a68_idf (A68_EXT, "blankcharacter", MODE (CHAR), genie_blank_char); a68_idf (A68_STD, "blankchar", MODE (CHAR), genie_blank_char); a68_idf (A68_STD, "blank", MODE (CHAR), genie_blank_char); a68_idf (A68_EXT, "nullcharacter", MODE (CHAR), genie_null_char); a68_idf (A68_STD, "nullchar", MODE (CHAR), genie_null_char); a68_idf (A68_EXT, "newlinecharacter", MODE (CHAR), genie_newline_char); a68_idf (A68_EXT, "newlinechar", MODE (CHAR), genie_newline_char); a68_idf (A68_EXT, "formfeedcharacter", MODE (CHAR), genie_formfeed_char); a68_idf (A68_EXT, "formfeedchar", MODE (CHAR), genie_formfeed_char); a68_idf (A68_EXT, "tabcharacter", MODE (CHAR), genie_tab_char); a68_idf (A68_EXT, "tabchar", MODE (CHAR), genie_tab_char); m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), NO_MOID); a68_idf (A68_STD, "whole", m, genie_whole); m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_STD, "fixed", m, genie_fixed); m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_STD, "float", m, genie_float); m = a68_proc (MODE (STRING), MODE (NUMBER), MODE (INT), MODE (INT), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_STD, "real", m, genie_real); a68_idf (A68_STD, "standin", MODE (REF_FILE), genie_stand_in); a68_idf (A68_STD, "standout", MODE (REF_FILE), genie_stand_out); a68_idf (A68_STD, "standback", MODE (REF_FILE), genie_stand_back); a68_idf (A68_EXT, "standerror", MODE (REF_FILE), genie_stand_error); a68_idf (A68_STD, "standinchannel", MODE (CHANNEL), genie_stand_in_channel); a68_idf (A68_STD, "standoutchannel", MODE (CHANNEL), genie_stand_out_channel); a68_idf (A68_EXT, "standdrawchannel", MODE (CHANNEL), genie_stand_draw_channel); a68_idf (A68_STD, "standbackchannel", MODE (CHANNEL), genie_stand_back_channel); a68_idf (A68_EXT, "standerrorchannel", MODE (CHANNEL), genie_stand_error_channel); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (STRING), NO_MOID); a68_idf (A68_STD, "maketerm", m, genie_make_term); m = a68_proc (MODE (BOOL), MODE (CHAR), MODE (REF_INT), MODE (STRING), NO_MOID); a68_idf (A68_STD, "charinstring", m, genie_char_in_string); a68_idf (A68_EXT, "lastcharinstring", m, genie_last_char_in_string); m = a68_proc (MODE (BOOL), MODE (STRING), MODE (REF_INT), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "stringinstring", m, genie_string_in_string); m = a68_proc (MODE (STRING), MODE (REF_FILE), NO_MOID); a68_idf (A68_EXT, "idf", m, genie_idf); a68_idf (A68_EXT, "term", m, genie_term); m = a68_proc (MODE (STRING), NO_MOID); a68_idf (A68_EXT, "programidf", m, genie_program_idf); /* Event routines */ m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (PROC_REF_FILE_BOOL), NO_MOID); a68_idf (A68_STD, "onfileend", m, genie_on_file_end); a68_idf (A68_STD, "onpageend", m, genie_on_page_end); a68_idf (A68_STD, "onlineend", m, genie_on_line_end); a68_idf (A68_STD, "onlogicalfileend", m, genie_on_file_end); a68_idf (A68_STD, "onphysicalfileend", m, genie_on_file_end); a68_idf (A68_STD, "onformatend", m, genie_on_format_end); a68_idf (A68_STD, "onformaterror", m, genie_on_format_error); a68_idf (A68_STD, "onvalueerror", m, genie_on_value_error); a68_idf (A68_STD, "onopenerror", m, genie_on_open_error); a68_idf (A68_EXT, "ontransputerror", m, genie_on_transput_error); /* Enquiries on files */ a68_idf (A68_STD, "putpossible", MODE (PROC_REF_FILE_BOOL), genie_put_possible); a68_idf (A68_STD, "getpossible", MODE (PROC_REF_FILE_BOOL), genie_get_possible); a68_idf (A68_STD, "binpossible", MODE (PROC_REF_FILE_BOOL), genie_bin_possible); a68_idf (A68_STD, "setpossible", MODE (PROC_REF_FILE_BOOL), genie_set_possible); a68_idf (A68_STD, "resetpossible", MODE (PROC_REF_FILE_BOOL), genie_reset_possible); a68_idf (A68_EXT, "rewindpossible", MODE (PROC_REF_FILE_BOOL), genie_reset_possible); a68_idf (A68_STD, "reidfpossible", MODE (PROC_REF_FILE_BOOL), genie_reidf_possible); a68_idf (A68_EXT, "drawpossible", MODE (PROC_REF_FILE_BOOL), genie_draw_possible); a68_idf (A68_STD, "compressible", MODE (PROC_REF_FILE_BOOL), genie_compressible); a68_idf (A68_EXT, "endoffile", MODE (PROC_REF_FILE_BOOL), genie_eof); a68_idf (A68_EXT, "eof", MODE (PROC_REF_FILE_BOOL), genie_eof); a68_idf (A68_EXT, "endofline", MODE (PROC_REF_FILE_BOOL), genie_eoln); a68_idf (A68_EXT, "eoln", MODE (PROC_REF_FILE_BOOL), genie_eoln); /* Handling of files */ m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (STRING), MODE (CHANNEL), NO_MOID); a68_idf (A68_STD, "open", m, genie_open); a68_idf (A68_STD, "establish", m, genie_establish); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REF_STRING), NO_MOID); a68_idf (A68_STD, "associate", m, genie_associate); m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (CHANNEL), NO_MOID); a68_idf (A68_STD, "create", m, genie_create); a68_idf (A68_STD, "close", MODE (PROC_REF_FILE_VOID), genie_close); a68_idf (A68_STD, "lock", MODE (PROC_REF_FILE_VOID), genie_lock); a68_idf (A68_STD, "scratch", MODE (PROC_REF_FILE_VOID), genie_erase); a68_idf (A68_STD, "erase", MODE (PROC_REF_FILE_VOID), genie_erase); a68_idf (A68_STD, "reset", MODE (PROC_REF_FILE_VOID), genie_reset); a68_idf (A68_EXT, "rewind", MODE (PROC_REF_FILE_VOID), genie_reset); a68_idf (A68_STD, "scratch", MODE (PROC_REF_FILE_VOID), genie_erase); a68_idf (A68_STD, "newline", MODE (PROC_REF_FILE_VOID), genie_new_line); a68_idf (A68_STD, "newpage", MODE (PROC_REF_FILE_VOID), genie_new_page); a68_idf (A68_STD, "space", MODE (PROC_REF_FILE_VOID), genie_space); a68_idf (A68_STD, "backspace", MODE (PROC_REF_FILE_VOID), genie_backspace); m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (INT), NO_MOID); a68_idf (A68_STD, "set", m, genie_set); a68_idf (A68_STD, "seek", m, genie_set); m = a68_proc (MODE (VOID), MODE (ROW_SIMPLIN), NO_MOID); a68_idf (A68_STD, "read", m, genie_read); a68_idf (A68_STD, "readbin", m, genie_read_bin); a68_idf (A68_STD, "readf", m, genie_read_format); m = a68_proc (MODE (VOID), MODE (ROW_SIMPLOUT), NO_MOID); a68_idf (A68_STD, "print", m, genie_write); a68_idf (A68_STD, "write", m, genie_write); a68_idf (A68_STD, "printbin", m, genie_write_bin); a68_idf (A68_STD, "writebin", m, genie_write_bin); a68_idf (A68_STD, "printf", m, genie_write_format); a68_idf (A68_STD, "writef", m, genie_write_format); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (ROW_SIMPLIN), NO_MOID); a68_idf (A68_STD, "get", m, genie_read_file); a68_idf (A68_STD, "getf", m, genie_read_file_format); a68_idf (A68_STD, "getbin", m, genie_read_bin_file); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (ROW_SIMPLOUT), NO_MOID); a68_idf (A68_STD, "put", m, genie_write_file); a68_idf (A68_STD, "putf", m, genie_write_file_format); a68_idf (A68_STD, "putbin", m, genie_write_bin_file); /* ALGOL68C type procs */ #define A68C_DEFIO(name, pname, mode)\ m = a68_proc (MODE (mode), MODE (REF_FILE), NO_MOID);\ a68_idf (A68_EXT, "get" #name, m, genie_get_##pname);\ m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (mode), NO_MOID);\ a68_idf (A68_EXT, "put" #name, m, genie_put_##pname);\ m = a68_proc (MODE (mode), NO_MOID);\ a68_idf (A68_EXT, "read" #name, m, genie_read_##pname);\ m = a68_proc (MODE (VOID), MODE (mode), NO_MOID);\ a68_idf (A68_EXT, "print" #name, m, genie_print_##pname); A68C_DEFIO(int, int, INT) A68C_DEFIO(longint, long_int, LONG_INT) A68C_DEFIO(longlongint, longlong_int, LONGLONG_INT) A68C_DEFIO(real, real, REAL) A68C_DEFIO(longreal, long_real, LONG_REAL) A68C_DEFIO(double, long_real, LONG_REAL) A68C_DEFIO(longlongreal, longlong_real, LONGLONG_REAL) A68C_DEFIO(quad, longlong_real, LONGLONG_REAL) A68C_DEFIO(compl, complex, COMPLEX) A68C_DEFIO(longcompl, long_complex, LONG_COMPLEX) A68C_DEFIO(longlongcompl, longlong_complex, LONGLONG_COMPLEX) A68C_DEFIO(complex, complex, COMPLEX) A68C_DEFIO(longcomplex, long_complex, LONG_COMPLEX) A68C_DEFIO(longlongcomplex, longlong_complex, LONGLONG_COMPLEX) A68C_DEFIO(bits, bits, BITS) A68C_DEFIO(longbits, long_bits, LONG_BITS) A68C_DEFIO(longlongbits, longlong_bits, LONGLONG_BITS) A68C_DEFIO(bool, bool, BOOL); A68C_DEFIO(char, char, CHAR); A68C_DEFIO(string, string, STRING); #undef A68C_DEFIO a68_idf (A68_EXT, "readline", MODE (PROC_STRING), genie_read_line); /* Constants ex GSL */ a68_idf (A68_EXT, "cgsspeedoflight", MODE (REAL), genie_cgs_speed_of_light); a68_idf (A68_EXT, "cgsgravitationalconstant", MODE (REAL), genie_cgs_gravitational_constant); a68_idf (A68_EXT, "cgsplanckconstant", MODE (REAL), genie_cgs_planck_constant_h); a68_idf (A68_EXT, "cgsplanckconstantbar", MODE (REAL), genie_cgs_planck_constant_hbar); a68_idf (A68_EXT, "cgsastronomicalunit", MODE (REAL), genie_cgs_astronomical_unit); a68_idf (A68_EXT, "cgslightyear", MODE (REAL), genie_cgs_light_year); a68_idf (A68_EXT, "cgsparsec", MODE (REAL), genie_cgs_parsec); a68_idf (A68_EXT, "cgsgravaccel", MODE (REAL), genie_cgs_grav_accel); a68_idf (A68_EXT, "cgselectronvolt", MODE (REAL), genie_cgs_electron_volt); a68_idf (A68_EXT, "cgsmasselectron", MODE (REAL), genie_cgs_mass_electron); a68_idf (A68_EXT, "cgsmassmuon", MODE (REAL), genie_cgs_mass_muon); a68_idf (A68_EXT, "cgsmassproton", MODE (REAL), genie_cgs_mass_proton); a68_idf (A68_EXT, "cgsmassneutron", MODE (REAL), genie_cgs_mass_neutron); a68_idf (A68_EXT, "cgsrydberg", MODE (REAL), genie_cgs_rydberg); a68_idf (A68_EXT, "cgsboltzmann", MODE (REAL), genie_cgs_boltzmann); a68_idf (A68_EXT, "cgsbohrmagneton", MODE (REAL), genie_cgs_bohr_magneton); a68_idf (A68_EXT, "cgsnuclearmagneton", MODE (REAL), genie_cgs_nuclear_magneton); a68_idf (A68_EXT, "cgselectronmagneticmoment", MODE (REAL), genie_cgs_electron_magnetic_moment); a68_idf (A68_EXT, "cgsprotonmagneticmoment", MODE (REAL), genie_cgs_proton_magnetic_moment); a68_idf (A68_EXT, "cgsmolargas", MODE (REAL), genie_cgs_molar_gas); a68_idf (A68_EXT, "cgsstandardgasvolume", MODE (REAL), genie_cgs_standard_gas_volume); a68_idf (A68_EXT, "cgsminute", MODE (REAL), genie_cgs_minute); a68_idf (A68_EXT, "cgshour", MODE (REAL), genie_cgs_hour); a68_idf (A68_EXT, "cgsday", MODE (REAL), genie_cgs_day); a68_idf (A68_EXT, "cgsweek", MODE (REAL), genie_cgs_week); a68_idf (A68_EXT, "cgsinch", MODE (REAL), genie_cgs_inch); a68_idf (A68_EXT, "cgsfoot", MODE (REAL), genie_cgs_foot); a68_idf (A68_EXT, "cgsyard", MODE (REAL), genie_cgs_yard); a68_idf (A68_EXT, "cgsmile", MODE (REAL), genie_cgs_mile); a68_idf (A68_EXT, "cgsnauticalmile", MODE (REAL), genie_cgs_nautical_mile); a68_idf (A68_EXT, "cgsfathom", MODE (REAL), genie_cgs_fathom); a68_idf (A68_EXT, "cgsmil", MODE (REAL), genie_cgs_mil); a68_idf (A68_EXT, "cgspoint", MODE (REAL), genie_cgs_point); a68_idf (A68_EXT, "cgstexpoint", MODE (REAL), genie_cgs_texpoint); a68_idf (A68_EXT, "cgsmicron", MODE (REAL), genie_cgs_micron); a68_idf (A68_EXT, "cgsangstrom", MODE (REAL), genie_cgs_angstrom); a68_idf (A68_EXT, "cgshectare", MODE (REAL), genie_cgs_hectare); a68_idf (A68_EXT, "cgsacre", MODE (REAL), genie_cgs_acre); a68_idf (A68_EXT, "cgsbarn", MODE (REAL), genie_cgs_barn); a68_idf (A68_EXT, "cgsliter", MODE (REAL), genie_cgs_liter); a68_idf (A68_EXT, "cgsusgallon", MODE (REAL), genie_cgs_us_gallon); a68_idf (A68_EXT, "cgsquart", MODE (REAL), genie_cgs_quart); a68_idf (A68_EXT, "cgspint", MODE (REAL), genie_cgs_pint); a68_idf (A68_EXT, "cgscup", MODE (REAL), genie_cgs_cup); a68_idf (A68_EXT, "cgsfluidounce", MODE (REAL), genie_cgs_fluid_ounce); a68_idf (A68_EXT, "cgstablespoon", MODE (REAL), genie_cgs_tablespoon); a68_idf (A68_EXT, "cgsteaspoon", MODE (REAL), genie_cgs_teaspoon); a68_idf (A68_EXT, "cgscanadiangallon", MODE (REAL), genie_cgs_canadian_gallon); a68_idf (A68_EXT, "cgsukgallon", MODE (REAL), genie_cgs_uk_gallon); a68_idf (A68_EXT, "cgsmilesperhour", MODE (REAL), genie_cgs_miles_per_hour); a68_idf (A68_EXT, "cgskilometersperhour", MODE (REAL), genie_cgs_kilometers_per_hour); a68_idf (A68_EXT, "cgsknot", MODE (REAL), genie_cgs_knot); a68_idf (A68_EXT, "cgspoundmass", MODE (REAL), genie_cgs_pound_mass); a68_idf (A68_EXT, "cgsouncemass", MODE (REAL), genie_cgs_ounce_mass); a68_idf (A68_EXT, "cgston", MODE (REAL), genie_cgs_ton); a68_idf (A68_EXT, "cgsmetricton", MODE (REAL), genie_cgs_metric_ton); a68_idf (A68_EXT, "cgsukton", MODE (REAL), genie_cgs_uk_ton); a68_idf (A68_EXT, "cgstroyounce", MODE (REAL), genie_cgs_troy_ounce); a68_idf (A68_EXT, "cgscarat", MODE (REAL), genie_cgs_carat); a68_idf (A68_EXT, "cgsunifiedatomicmass", MODE (REAL), genie_cgs_unified_atomic_mass); a68_idf (A68_EXT, "cgsgramforce", MODE (REAL), genie_cgs_gram_force); a68_idf (A68_EXT, "cgspoundforce", MODE (REAL), genie_cgs_pound_force); a68_idf (A68_EXT, "cgskilopoundforce", MODE (REAL), genie_cgs_kilopound_force); a68_idf (A68_EXT, "cgspoundal", MODE (REAL), genie_cgs_poundal); a68_idf (A68_EXT, "cgscalorie", MODE (REAL), genie_cgs_calorie); a68_idf (A68_EXT, "cgsbtu", MODE (REAL), genie_cgs_btu); a68_idf (A68_EXT, "cgstherm", MODE (REAL), genie_cgs_therm); a68_idf (A68_EXT, "cgshorsepower", MODE (REAL), genie_cgs_horsepower); a68_idf (A68_EXT, "cgsbar", MODE (REAL), genie_cgs_bar); a68_idf (A68_EXT, "cgsstdatmosphere", MODE (REAL), genie_cgs_std_atmosphere); a68_idf (A68_EXT, "cgstorr", MODE (REAL), genie_cgs_torr); a68_idf (A68_EXT, "cgsmeterofmercury", MODE (REAL), genie_cgs_meter_of_mercury); a68_idf (A68_EXT, "cgsinchofmercury", MODE (REAL), genie_cgs_inch_of_mercury); a68_idf (A68_EXT, "cgsinchofwater", MODE (REAL), genie_cgs_inch_of_water); a68_idf (A68_EXT, "cgspsi", MODE (REAL), genie_cgs_psi); a68_idf (A68_EXT, "cgspoise", MODE (REAL), genie_cgs_poise); a68_idf (A68_EXT, "cgsstokes", MODE (REAL), genie_cgs_stokes); a68_idf (A68_EXT, "cgsfaraday", MODE (REAL), genie_cgs_faraday); a68_idf (A68_EXT, "cgselectroncharge", MODE (REAL), genie_cgs_electron_charge); a68_idf (A68_EXT, "cgsgauss", MODE (REAL), genie_cgs_gauss); a68_idf (A68_EXT, "cgsstilb", MODE (REAL), genie_cgs_stilb); a68_idf (A68_EXT, "cgslumen", MODE (REAL), genie_cgs_lumen); a68_idf (A68_EXT, "cgslux", MODE (REAL), genie_cgs_lux); a68_idf (A68_EXT, "cgsphot", MODE (REAL), genie_cgs_phot); a68_idf (A68_EXT, "cgsfootcandle", MODE (REAL), genie_cgs_footcandle); a68_idf (A68_EXT, "cgslambert", MODE (REAL), genie_cgs_lambert); a68_idf (A68_EXT, "cgsfootlambert", MODE (REAL), genie_cgs_footlambert); a68_idf (A68_EXT, "cgscurie", MODE (REAL), genie_cgs_curie); a68_idf (A68_EXT, "cgsroentgen", MODE (REAL), genie_cgs_roentgen); a68_idf (A68_EXT, "cgsrad", MODE (REAL), genie_cgs_rad); a68_idf (A68_EXT, "cgssolarmass", MODE (REAL), genie_cgs_solar_mass); a68_idf (A68_EXT, "cgsbohrradius", MODE (REAL), genie_cgs_bohr_radius); a68_idf (A68_EXT, "cgsnewton", MODE (REAL), genie_cgs_newton); a68_idf (A68_EXT, "cgsdyne", MODE (REAL), genie_cgs_dyne); a68_idf (A68_EXT, "cgsjoule", MODE (REAL), genie_cgs_joule); a68_idf (A68_EXT, "cgserg", MODE (REAL), genie_cgs_erg); a68_idf (A68_EXT, "mksaspeedoflight", MODE (REAL), genie_mks_speed_of_light); a68_idf (A68_EXT, "mksagravitationalconstant", MODE (REAL), genie_mks_gravitational_constant); a68_idf (A68_EXT, "mksaplanckconstant", MODE (REAL), genie_mks_planck_constant_h); a68_idf (A68_EXT, "mksaplanckconstantbar", MODE (REAL), genie_mks_planck_constant_hbar); a68_idf (A68_EXT, "mksavacuumpermeability", MODE (REAL), genie_mks_vacuum_permeability); a68_idf (A68_EXT, "mksaastronomicalunit", MODE (REAL), genie_mks_astronomical_unit); a68_idf (A68_EXT, "mksalightyear", MODE (REAL), genie_mks_light_year); a68_idf (A68_EXT, "mksaparsec", MODE (REAL), genie_mks_parsec); a68_idf (A68_EXT, "mksagravaccel", MODE (REAL), genie_mks_grav_accel); a68_idf (A68_EXT, "mksaelectronvolt", MODE (REAL), genie_mks_electron_volt); a68_idf (A68_EXT, "mksamasselectron", MODE (REAL), genie_mks_mass_electron); a68_idf (A68_EXT, "mksamassmuon", MODE (REAL), genie_mks_mass_muon); a68_idf (A68_EXT, "mksamassproton", MODE (REAL), genie_mks_mass_proton); a68_idf (A68_EXT, "mksamassneutron", MODE (REAL), genie_mks_mass_neutron); a68_idf (A68_EXT, "mksarydberg", MODE (REAL), genie_mks_rydberg); a68_idf (A68_EXT, "mksaboltzmann", MODE (REAL), genie_mks_boltzmann); a68_idf (A68_EXT, "mksabohrmagneton", MODE (REAL), genie_mks_bohr_magneton); a68_idf (A68_EXT, "mksanuclearmagneton", MODE (REAL), genie_mks_nuclear_magneton); a68_idf (A68_EXT, "mksaelectronmagneticmoment", MODE (REAL), genie_mks_electron_magnetic_moment); a68_idf (A68_EXT, "mksaprotonmagneticmoment", MODE (REAL), genie_mks_proton_magnetic_moment); a68_idf (A68_EXT, "mksamolargas", MODE (REAL), genie_mks_molar_gas); a68_idf (A68_EXT, "mksastandardgasvolume", MODE (REAL), genie_mks_standard_gas_volume); a68_idf (A68_EXT, "mksaminute", MODE (REAL), genie_mks_minute); a68_idf (A68_EXT, "mksahour", MODE (REAL), genie_mks_hour); a68_idf (A68_EXT, "mksaday", MODE (REAL), genie_mks_day); a68_idf (A68_EXT, "mksaweek", MODE (REAL), genie_mks_week); a68_idf (A68_EXT, "mksainch", MODE (REAL), genie_mks_inch); a68_idf (A68_EXT, "mksafoot", MODE (REAL), genie_mks_foot); a68_idf (A68_EXT, "mksayard", MODE (REAL), genie_mks_yard); a68_idf (A68_EXT, "mksamile", MODE (REAL), genie_mks_mile); a68_idf (A68_EXT, "mksanauticalmile", MODE (REAL), genie_mks_nautical_mile); a68_idf (A68_EXT, "mksafathom", MODE (REAL), genie_mks_fathom); a68_idf (A68_EXT, "mksamil", MODE (REAL), genie_mks_mil); a68_idf (A68_EXT, "mksapoint", MODE (REAL), genie_mks_point); a68_idf (A68_EXT, "mksatexpoint", MODE (REAL), genie_mks_texpoint); a68_idf (A68_EXT, "mksamicron", MODE (REAL), genie_mks_micron); a68_idf (A68_EXT, "mksaangstrom", MODE (REAL), genie_mks_angstrom); a68_idf (A68_EXT, "mksahectare", MODE (REAL), genie_mks_hectare); a68_idf (A68_EXT, "mksaacre", MODE (REAL), genie_mks_acre); a68_idf (A68_EXT, "mksabarn", MODE (REAL), genie_mks_barn); a68_idf (A68_EXT, "mksaliter", MODE (REAL), genie_mks_liter); a68_idf (A68_EXT, "mksausgallon", MODE (REAL), genie_mks_us_gallon); a68_idf (A68_EXT, "mksaquart", MODE (REAL), genie_mks_quart); a68_idf (A68_EXT, "mksapint", MODE (REAL), genie_mks_pint); a68_idf (A68_EXT, "mksacup", MODE (REAL), genie_mks_cup); a68_idf (A68_EXT, "mksafluidounce", MODE (REAL), genie_mks_fluid_ounce); a68_idf (A68_EXT, "mksatablespoon", MODE (REAL), genie_mks_tablespoon); a68_idf (A68_EXT, "mksateaspoon", MODE (REAL), genie_mks_teaspoon); a68_idf (A68_EXT, "mksacanadiangallon", MODE (REAL), genie_mks_canadian_gallon); a68_idf (A68_EXT, "mksaukgallon", MODE (REAL), genie_mks_uk_gallon); a68_idf (A68_EXT, "mksamilesperhour", MODE (REAL), genie_mks_miles_per_hour); a68_idf (A68_EXT, "mksakilometersperhour", MODE (REAL), genie_mks_kilometers_per_hour); a68_idf (A68_EXT, "mksaknot", MODE (REAL), genie_mks_knot); a68_idf (A68_EXT, "mksapoundmass", MODE (REAL), genie_mks_pound_mass); a68_idf (A68_EXT, "mksaouncemass", MODE (REAL), genie_mks_ounce_mass); a68_idf (A68_EXT, "mksaton", MODE (REAL), genie_mks_ton); a68_idf (A68_EXT, "mksametricton", MODE (REAL), genie_mks_metric_ton); a68_idf (A68_EXT, "mksaukton", MODE (REAL), genie_mks_uk_ton); a68_idf (A68_EXT, "mksatroyounce", MODE (REAL), genie_mks_troy_ounce); a68_idf (A68_EXT, "mksacarat", MODE (REAL), genie_mks_carat); a68_idf (A68_EXT, "mksaunifiedatomicmass", MODE (REAL), genie_mks_unified_atomic_mass); a68_idf (A68_EXT, "mksagramforce", MODE (REAL), genie_mks_gram_force); a68_idf (A68_EXT, "mksapoundforce", MODE (REAL), genie_mks_pound_force); a68_idf (A68_EXT, "mksakilopoundforce", MODE (REAL), genie_mks_kilopound_force); a68_idf (A68_EXT, "mksapoundal", MODE (REAL), genie_mks_poundal); a68_idf (A68_EXT, "mksacalorie", MODE (REAL), genie_mks_calorie); a68_idf (A68_EXT, "mksabtu", MODE (REAL), genie_mks_btu); a68_idf (A68_EXT, "mksatherm", MODE (REAL), genie_mks_therm); a68_idf (A68_EXT, "mksahorsepower", MODE (REAL), genie_mks_horsepower); a68_idf (A68_EXT, "mksabar", MODE (REAL), genie_mks_bar); a68_idf (A68_EXT, "mksastdatmosphere", MODE (REAL), genie_mks_std_atmosphere); a68_idf (A68_EXT, "mksatorr", MODE (REAL), genie_mks_torr); a68_idf (A68_EXT, "mksameterofmercury", MODE (REAL), genie_mks_meter_of_mercury); a68_idf (A68_EXT, "mksainchofmercury", MODE (REAL), genie_mks_inch_of_mercury); a68_idf (A68_EXT, "mksainchofwater", MODE (REAL), genie_mks_inch_of_water); a68_idf (A68_EXT, "mksapsi", MODE (REAL), genie_mks_psi); a68_idf (A68_EXT, "mksapoise", MODE (REAL), genie_mks_poise); a68_idf (A68_EXT, "mksastokes", MODE (REAL), genie_mks_stokes); a68_idf (A68_EXT, "mksafaraday", MODE (REAL), genie_mks_faraday); a68_idf (A68_EXT, "mksaelectroncharge", MODE (REAL), genie_mks_electron_charge); a68_idf (A68_EXT, "mksagauss", MODE (REAL), genie_mks_gauss); a68_idf (A68_EXT, "mksastilb", MODE (REAL), genie_mks_stilb); a68_idf (A68_EXT, "mksalumen", MODE (REAL), genie_mks_lumen); a68_idf (A68_EXT, "mksalux", MODE (REAL), genie_mks_lux); a68_idf (A68_EXT, "mksaphot", MODE (REAL), genie_mks_phot); a68_idf (A68_EXT, "mksafootcandle", MODE (REAL), genie_mks_footcandle); a68_idf (A68_EXT, "mksalambert", MODE (REAL), genie_mks_lambert); a68_idf (A68_EXT, "mksafootlambert", MODE (REAL), genie_mks_footlambert); a68_idf (A68_EXT, "mksacurie", MODE (REAL), genie_mks_curie); a68_idf (A68_EXT, "mksaroentgen", MODE (REAL), genie_mks_roentgen); a68_idf (A68_EXT, "mksarad", MODE (REAL), genie_mks_rad); a68_idf (A68_EXT, "mksasolarmass", MODE (REAL), genie_mks_solar_mass); a68_idf (A68_EXT, "mksabohrradius", MODE (REAL), genie_mks_bohr_radius); a68_idf (A68_EXT, "mksavacuumpermittivity", MODE (REAL), genie_mks_vacuum_permittivity); a68_idf (A68_EXT, "mksanewton", MODE (REAL), genie_mks_newton); a68_idf (A68_EXT, "mksadyne", MODE (REAL), genie_mks_dyne); a68_idf (A68_EXT, "mksajoule", MODE (REAL), genie_mks_joule); a68_idf (A68_EXT, "mksaerg", MODE (REAL), genie_mks_erg); a68_idf (A68_EXT, "numfinestructure", MODE (REAL), genie_num_fine_structure); a68_idf (A68_EXT, "numavogadro", MODE (REAL), genie_num_avogadro); a68_idf (A68_EXT, "numyotta", MODE (REAL), genie_num_yotta); a68_idf (A68_EXT, "numzetta", MODE (REAL), genie_num_zetta); a68_idf (A68_EXT, "numexa", MODE (REAL), genie_num_exa); a68_idf (A68_EXT, "numpeta", MODE (REAL), genie_num_peta); a68_idf (A68_EXT, "numtera", MODE (REAL), genie_num_tera); a68_idf (A68_EXT, "numgiga", MODE (REAL), genie_num_giga); a68_idf (A68_EXT, "nummega", MODE (REAL), genie_num_mega); a68_idf (A68_EXT, "numkilo", MODE (REAL), genie_num_kilo); a68_idf (A68_EXT, "nummilli", MODE (REAL), genie_num_milli); a68_idf (A68_EXT, "nummicro", MODE (REAL), genie_num_micro); a68_idf (A68_EXT, "numnano", MODE (REAL), genie_num_nano); a68_idf (A68_EXT, "numpico", MODE (REAL), genie_num_pico); a68_idf (A68_EXT, "numfemto", MODE (REAL), genie_num_femto); a68_idf (A68_EXT, "numatto", MODE (REAL), genie_num_atto); a68_idf (A68_EXT, "numzepto", MODE (REAL), genie_num_zepto); a68_idf (A68_EXT, "numyocto", MODE (REAL), genie_num_yocto); } /** @brief Set up standenv - extensions. **/ static void stand_extensions (void) { MOID_T *m = NO_MOID; (void) m; /* To fool cc in case we have none of the libraries */ #if defined HAVE_GNU_PLOTUTILS /* Drawing */ m = a68_proc (MODE (BOOL), MODE (REF_FILE), MODE (STRING), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "drawdevice", m, genie_make_device); a68_idf (A68_EXT, "makedevice", m, genie_make_device); m = a68_proc (MODE (REAL), MODE (REF_FILE), NO_MOID); a68_idf (A68_EXT, "drawaspect", m, genie_draw_aspect); m = a68_proc (MODE (VOID), MODE (REF_FILE), NO_MOID); a68_idf (A68_EXT, "drawclear", m, genie_draw_clear); a68_idf (A68_EXT, "drawerase", m, genie_draw_clear); a68_idf (A68_EXT, "drawflush", m, genie_draw_show); a68_idf (A68_EXT, "drawshow", m, genie_draw_show); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (INT), NO_MOID); a68_idf (A68_EXT, "drawfillstyle", m, genie_draw_fillstyle); m = a68_proc (MODE (STRING), MODE (INT), NO_MOID); a68_idf (A68_EXT, "drawgetcolourname", m, genie_draw_get_colour_name); a68_idf (A68_EXT, "drawgetcolorname", m, genie_draw_get_colour_name); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "drawcolor", m, genie_draw_colour); a68_idf (A68_EXT, "drawcolour", m, genie_draw_colour); a68_idf (A68_EXT, "drawbackgroundcolor", m, genie_draw_background_colour); a68_idf (A68_EXT, "drawbackgroundcolour", m, genie_draw_background_colour); a68_idf (A68_EXT, "drawcircle", m, genie_draw_circle); a68_idf (A68_EXT, "drawball", m, genie_draw_atom); a68_idf (A68_EXT, "drawstar", m, genie_draw_star); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REAL), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "drawpoint", m, genie_draw_point); a68_idf (A68_EXT, "drawline", m, genie_draw_line); a68_idf (A68_EXT, "drawmove", m, genie_draw_move); a68_idf (A68_EXT, "drawrect", m, genie_draw_rect); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (CHAR), MODE (CHAR), MODE (ROW_CHAR), NO_MOID); a68_idf (A68_EXT, "drawtext", m, genie_draw_text); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (ROW_CHAR), NO_MOID); a68_idf (A68_EXT, "drawlinestyle", m, genie_draw_linestyle); a68_idf (A68_EXT, "drawfontname", m, genie_draw_fontname); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "drawlinewidth", m, genie_draw_linewidth); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (INT), NO_MOID); a68_idf (A68_EXT, "drawfontsize", m, genie_draw_fontsize); a68_idf (A68_EXT, "drawtextangle", m, genie_draw_textangle); m = a68_proc (MODE (VOID), MODE (REF_FILE), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "drawcolorname", m, genie_draw_colour_name); a68_idf (A68_EXT, "drawcolourname", m, genie_draw_colour_name); a68_idf (A68_EXT, "drawbackgroundcolorname", m, genie_draw_background_colour_name); a68_idf (A68_EXT, "drawbackgroundcolourname", m, genie_draw_background_colour_name); #endif #if defined HAVE_GNU_GSL m = proc_real_real; a68_idf (A68_EXT, "erf", m, genie_erf_real); a68_idf (A68_EXT, "erfc", m, genie_erfc_real); a68_idf (A68_EXT, "gamma", m, genie_gamma_real); a68_idf (A68_EXT, "lngamma", m, genie_lngamma_real); a68_idf (A68_EXT, "factorial", m, genie_factorial_real); a68_idf (A68_EXT, "airyai", m, genie_airy_ai_real); a68_idf (A68_EXT, "airybi", m, genie_airy_bi_real); a68_idf (A68_EXT, "airyaiderivative", m, genie_airy_ai_deriv_real); a68_idf (A68_EXT, "airybiderivative", m, genie_airy_bi_deriv_real); a68_idf (A68_EXT, "ellipticintegralk", m, genie_elliptic_integral_k_real); a68_idf (A68_EXT, "ellipticintegrale", m, genie_elliptic_integral_e_real); m = proc_real_real_real; a68_idf (A68_EXT, "beta", m, genie_beta_real); a68_idf (A68_EXT, "besseljn", m, genie_bessel_jn_real); a68_idf (A68_EXT, "besselyn", m, genie_bessel_yn_real); a68_idf (A68_EXT, "besselin", m, genie_bessel_in_real); a68_idf (A68_EXT, "besselexpin", m, genie_bessel_exp_in_real); a68_idf (A68_EXT, "besselkn", m, genie_bessel_kn_real); a68_idf (A68_EXT, "besselexpkn", m, genie_bessel_exp_kn_real); a68_idf (A68_EXT, "besseljl", m, genie_bessel_jl_real); a68_idf (A68_EXT, "besselyl", m, genie_bessel_yl_real); a68_idf (A68_EXT, "besselexpil", m, genie_bessel_exp_il_real); a68_idf (A68_EXT, "besselexpkl", m, genie_bessel_exp_kl_real); a68_idf (A68_EXT, "besseljnu", m, genie_bessel_jnu_real); a68_idf (A68_EXT, "besselynu", m, genie_bessel_ynu_real); a68_idf (A68_EXT, "besselinu", m, genie_bessel_inu_real); a68_idf (A68_EXT, "besselexpinu", m, genie_bessel_exp_inu_real); a68_idf (A68_EXT, "besselknu", m, genie_bessel_knu_real); a68_idf (A68_EXT, "besselexpknu", m, genie_bessel_exp_knu_real); a68_idf (A68_EXT, "ellipticintegralrc", m, genie_elliptic_integral_rc_real); a68_idf (A68_EXT, "incompletegamma", m, genie_gamma_inc_real); m = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "incompletebeta", m, genie_beta_inc_real); a68_idf (A68_EXT, "ellipticintegralrf", m, genie_elliptic_integral_rf_real); a68_idf (A68_EXT, "ellipticintegralrd", m, genie_elliptic_integral_rd_real); m = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID); a68_idf (A68_EXT, "ellipticintegralrj", m, genie_elliptic_integral_rj_real); /* Vector and matrix monadic */ m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "+", m, genie_idle); a68_op (A68_EXT, "-", m, genie_vector_minus); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "+", m, genie_idle); a68_op (A68_EXT, "-", m, genie_matrix_minus); a68_op (A68_EXT, "T", m, genie_matrix_transpose); a68_op (A68_EXT, "INV", m, genie_matrix_inv); m = a68_proc (MODE (REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "DET", m, genie_matrix_det); a68_op (A68_EXT, "TRACE", m, genie_matrix_trace); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+", m, genie_idle); a68_op (A68_EXT, "-", m, genie_vector_complex_minus); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+", m, genie_idle); a68_op (A68_EXT, "-", m, genie_matrix_complex_minus); a68_op (A68_EXT, "T", m, genie_matrix_complex_transpose); a68_op (A68_EXT, "INV", m, genie_matrix_complex_inv); m = a68_proc (MODE (COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "DET", m, genie_matrix_complex_det); a68_op (A68_EXT, "TRACE", m, genie_matrix_complex_trace); /* Vector and matrix dyadic */ m = a68_proc (MODE (BOOL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "=", m, genie_vector_eq); a68_op (A68_EXT, "/=", m, genie_vector_ne); m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "+", m, genie_vector_add); a68_op (A68_EXT, "-", m, genie_vector_sub); m = a68_proc (MODE (REF_ROW_REAL), MODE (REF_ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "+:=", m, genie_vector_plusab); a68_op (A68_EXT, "PLUSAB", m, genie_vector_plusab); a68_op (A68_EXT, "-:=", m, genie_vector_minusab); a68_op (A68_EXT, "MINUSAB", m, genie_vector_minusab); m = a68_proc (MODE (BOOL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "=", m, genie_matrix_eq); a68_op (A68_EXT, "/-", m, genie_matrix_ne); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "+", m, genie_matrix_add); a68_op (A68_EXT, "-", m, genie_matrix_sub); m = a68_proc (MODE (REF_ROWROW_REAL), MODE (REF_ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "+:=", m, genie_matrix_plusab); a68_op (A68_EXT, "PLUSAB", m, genie_matrix_plusab); a68_op (A68_EXT, "-:=", m, genie_matrix_minusab); a68_op (A68_EXT, "MINUSAB", m, genie_matrix_minusab); m = a68_proc (MODE (BOOL), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "=", m, genie_vector_complex_eq); a68_op (A68_EXT, "/=", m, genie_vector_complex_ne); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+", m, genie_vector_complex_add); a68_op (A68_EXT, "-", m, genie_vector_complex_sub); m = a68_proc (MODE (REF_ROW_COMPLEX), MODE (REF_ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+:=", m, genie_vector_complex_plusab); a68_op (A68_EXT, "PLUSAB", m, genie_vector_complex_plusab); a68_op (A68_EXT, "-:=", m, genie_vector_complex_minusab); a68_op (A68_EXT, "MINUSAB", m, genie_vector_complex_minusab); m = a68_proc (MODE (BOOL), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "=", m, genie_matrix_complex_eq); a68_op (A68_EXT, "/=", m, genie_matrix_complex_ne); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+", m, genie_matrix_complex_add); a68_op (A68_EXT, "-", m, genie_matrix_complex_sub); m = a68_proc (MODE (REF_ROWROW_COMPLEX), MODE (REF_ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "+:=", m, genie_matrix_complex_plusab); a68_op (A68_EXT, "PLUSAB", m, genie_matrix_complex_plusab); a68_op (A68_EXT, "-:=", m, genie_matrix_complex_minusab); a68_op (A68_EXT, "MINUSAB", m, genie_matrix_complex_minusab); /* Vector and matrix scaling */ m = a68_proc (MODE (ROW_REAL), MODE (REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_real_scale_vector); m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), MODE (REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_scale_real); a68_op (A68_EXT, "/", m, genie_vector_div_real); m = a68_proc (MODE (ROWROW_REAL), MODE (REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_real_scale_matrix); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_scale_real); a68_op (A68_EXT, "/", m, genie_matrix_div_real); m = a68_proc (MODE (ROW_COMPLEX), MODE (COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_complex_scale_vector_complex); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_complex_scale_complex); a68_op (A68_EXT, "/", m, genie_vector_complex_div_complex); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_complex_scale_matrix_complex); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_complex_scale_complex); a68_op (A68_EXT, "/", m, genie_matrix_complex_div_complex); m = a68_proc (MODE (REF_ROW_REAL), MODE (REF_ROW_REAL), MODE (REAL), NO_MOID); a68_op (A68_EXT, "*:=", m, genie_vector_scale_real_ab); a68_op (A68_EXT, "/:=", m, genie_vector_div_real_ab); m = a68_proc (MODE (REF_ROWROW_REAL), MODE (REF_ROWROW_REAL), MODE (REAL), NO_MOID); a68_op (A68_EXT, "*:=", m, genie_matrix_scale_real_ab); a68_op (A68_EXT, "/:=", m, genie_matrix_div_real_ab); m = a68_proc (MODE (REF_ROW_COMPLEX), MODE (REF_ROW_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_EXT, "*:=", m, genie_vector_complex_scale_complex_ab); a68_op (A68_EXT, "/:=", m, genie_vector_complex_div_complex_ab); m = a68_proc (MODE (REF_ROWROW_COMPLEX), MODE (REF_ROWROW_COMPLEX), MODE (COMPLEX), NO_MOID); a68_op (A68_EXT, "*:=", m, genie_matrix_complex_scale_complex_ab); a68_op (A68_EXT, "/:=", m, genie_matrix_complex_div_complex_ab); m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_times_matrix); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_complex_times_matrix); /* Matrix times vector or matrix */ m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_times_vector); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_times_matrix); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_complex_times_vector); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_matrix_complex_times_matrix); /* Vector and matrix miscellaneous */ m = a68_proc (MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "vectorecho", m, genie_vector_echo); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_idf (A68_EXT, "matrixecho", m, genie_matrix_echo); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_idf (A68_EXT, "complvectorecho", m, genie_vector_complex_echo); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), NO_MOID); a68_idf (A68_EXT, "complmatrixecho", m, genie_matrix_complex_echo); /**/ m = a68_proc (MODE (REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_dot); m = a68_proc (MODE (COMPLEX), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "*", m, genie_vector_complex_dot); m = a68_proc (MODE (REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "NORM", m, genie_vector_norm); m = a68_proc (MODE (REAL), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "NORM", m, genie_vector_complex_norm); m = a68_proc (MODE (ROWROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_op (A68_EXT, "DYAD", m, genie_vector_dyad); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_op (A68_EXT, "DYAD", m, genie_vector_complex_dyad); a68_prio ("DYAD", 3); /* LU decomposition */ m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REF_ROW_INT), MODE (REF_INT), NO_MOID); a68_idf (A68_EXT, "ludecomp", m, genie_matrix_lu); m = a68_proc (MODE (REAL), MODE (ROWROW_REAL), MODE (INT), NO_MOID); a68_idf (A68_EXT, "ludet", m, genie_matrix_lu_det); m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROW_INT), NO_MOID); a68_idf (A68_EXT, "luinv", m, genie_matrix_lu_inv); m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROW_INT), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "lusolve", m, genie_matrix_lu_solve); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (REF_ROW_INT), MODE (REF_INT), NO_MOID); a68_idf (A68_EXT, "complexludecomp", m, genie_matrix_complex_lu); m = a68_proc (MODE (COMPLEX), MODE (ROWROW_COMPLEX), MODE (INT), NO_MOID); a68_idf (A68_EXT, "complexludet", m, genie_matrix_complex_lu_det); m = a68_proc (MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROW_INT), NO_MOID); a68_idf (A68_EXT, "complexluinv", m, genie_matrix_complex_lu_inv); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), MODE (ROW_INT), MODE (ROW_COMPLEX), NO_MOID); a68_idf (A68_EXT, "complexlusolve", m, genie_matrix_complex_lu_solve); /* SVD decomposition */ m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REF_ROWROW_REAL), MODE (REF_ROW_REAL), NO_MOID); a68_idf (A68_EXT, "svdecomp", m, genie_matrix_svd); a68_idf (A68_EXT, "svddecomp", m, genie_matrix_svd); m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "svdsolve", m, genie_matrix_svd_solve); /* QR decomposition */ m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), MODE (REF_ROW_REAL), NO_MOID); a68_idf (A68_EXT, "qrdecomp", m, genie_matrix_qr); m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "qrsolve", m, genie_matrix_qr_solve); a68_idf (A68_EXT, "qrlssolve", m, genie_matrix_qr_ls_solve); /* Cholesky decomposition */ m = a68_proc (MODE (ROWROW_REAL), MODE (ROWROW_REAL), NO_MOID); a68_idf (A68_EXT, "choleskydecomp", m, genie_matrix_ch); m = a68_proc (MODE (ROW_REAL), MODE (ROWROW_REAL), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "choleskysolve", m, genie_matrix_ch_solve); /* FFT */ m = a68_proc (MODE (ROW_INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "primefactors", m, genie_prime_factors); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_COMPLEX), NO_MOID); a68_idf (A68_EXT, "fftcomplexforward", m, genie_fft_complex_forward); a68_idf (A68_EXT, "fftcomplexbackward", m, genie_fft_complex_backward); a68_idf (A68_EXT, "fftcomplexinverse", m, genie_fft_complex_inverse); m = a68_proc (MODE (ROW_COMPLEX), MODE (ROW_REAL), NO_MOID); a68_idf (A68_EXT, "fftforward", m, genie_fft_forward); m = a68_proc (MODE (ROW_REAL), MODE (ROW_COMPLEX), NO_MOID); a68_idf (A68_EXT, "fftbackward", m, genie_fft_backward); a68_idf (A68_EXT, "fftinverse", m, genie_fft_inverse); #endif /* UNIX things */ m = proc_int; a68_idf (A68_EXT, "rows", m, genie_rows); a68_idf (A68_EXT, "columns", m, genie_columns); a68_idf (A68_EXT, "argc", m, genie_argc); a68_idf (A68_EXT, "errno", m, genie_errno); a68_idf (A68_EXT, "fork", m, genie_fork); m = a68_proc (MODE (STRING), NO_MOID); a68_idf (A68_EXT, "getpwd", m, genie_pwd); m = a68_proc (MODE (INT), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "setpwd", m, genie_cd); m = a68_proc (MODE (BOOL), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "fileisdirectory", m, genie_file_is_directory); a68_idf (A68_EXT, "fileisblockdevice", m, genie_file_is_block_device); a68_idf (A68_EXT, "fileischardevice", m, genie_file_is_char_device); a68_idf (A68_EXT, "fileisregular", m, genie_file_is_regular); #if defined __S_IFIFO a68_idf (A68_EXT, "fileisfifo", m, genie_file_is_fifo); #endif #if defined __S_IFLNK a68_idf (A68_EXT, "fileislink", m, genie_file_is_link); #endif m = a68_proc (MODE (BITS), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "filemode", m, genie_file_mode); m = a68_proc (MODE (STRING), MODE (INT), NO_MOID); a68_idf (A68_EXT, "argv", m, genie_argv); m = proc_void; a68_idf (A68_EXT, "reseterrno", m, genie_reset_errno); m = a68_proc (MODE (STRING), MODE (INT), NO_MOID); a68_idf (A68_EXT, "strerror", m, genie_strerror); m = a68_proc (MODE (INT), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID); a68_idf (A68_EXT, "execve", m, genie_execve); m = a68_proc (MODE (PIPE), NO_MOID); a68_idf (A68_EXT, "createpipe", m, genie_create_pipe); m = a68_proc (MODE (INT), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID); a68_idf (A68_EXT, "execvechild", m, genie_execve_child); m = a68_proc (MODE (PIPE), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), NO_MOID); a68_idf (A68_EXT, "execvechildpipe", m, genie_execve_child_pipe); m = a68_proc (MODE (INT), MODE (STRING), MODE (ROW_STRING), MODE (ROW_STRING), MODE (REF_STRING), NO_MOID); a68_idf (A68_EXT, "execveoutput", m, genie_execve_output); m = a68_proc (MODE (STRING), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "getenv", m, genie_getenv); m = a68_proc (MODE (VOID), MODE (INT), NO_MOID); a68_idf (A68_EXT, "waitpid", m, genie_waitpid); m = a68_proc (MODE (ROW_INT), NO_MOID); a68_idf (A68_EXT, "utctime", m, genie_utctime); a68_idf (A68_EXT, "localtime", m, genie_localtime); #if defined HAVE_DIRENT_H m = a68_proc (MODE (ROW_STRING), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "getdirectory", m, genie_directory); #endif #if defined HAVE_HTTP m = a68_proc (MODE (INT), MODE (REF_STRING), MODE (STRING), MODE (STRING), MODE (INT), NO_MOID); a68_idf (A68_EXT, "httpcontent", m, genie_http_content); a68_idf (A68_EXT, "tcprequest", m, genie_tcp_request); #endif #if defined HAVE_REGEX_H m = a68_proc (MODE (INT), MODE (STRING), MODE (STRING), MODE (REF_INT), MODE (REF_INT), NO_MOID); a68_idf (A68_EXT, "grepinstring", m, genie_grep_in_string); a68_idf (A68_EXT, "grepinsubstring", m, genie_grep_in_substring); m = a68_proc (MODE (INT), MODE (STRING), MODE (STRING), MODE (REF_STRING), NO_MOID); a68_idf (A68_EXT, "subinstring", m, genie_sub_in_string); #endif #if defined HAVE_CURSES m = proc_void; a68_idf (A68_EXT, "cursesstart", m, genie_curses_start); a68_idf (A68_EXT, "cursesend", m, genie_curses_end); a68_idf (A68_EXT, "cursesclear", m, genie_curses_clear); a68_idf (A68_EXT, "cursesrefresh", m, genie_curses_refresh); a68_idf (A68_EXT, "cursesgreen", m, genie_curses_green); a68_idf (A68_EXT, "cursescyan", m, genie_curses_cyan); a68_idf (A68_EXT, "cursesred", m, genie_curses_red); a68_idf (A68_EXT, "cursesyellow", m, genie_curses_yellow); a68_idf (A68_EXT, "cursesmagenta", m, genie_curses_magenta); a68_idf (A68_EXT, "cursesblue", m, genie_curses_blue); a68_idf (A68_EXT, "curseswhite", m, genie_curses_white); a68_idf (A68_EXT, "cursesgreeninverse", m, genie_curses_green_inverse); a68_idf (A68_EXT, "cursescyaninverse", m, genie_curses_cyan_inverse); a68_idf (A68_EXT, "cursesredinverse", m, genie_curses_red_inverse); a68_idf (A68_EXT, "cursesyellowinverse", m, genie_curses_yellow_inverse); a68_idf (A68_EXT, "cursesmagentainverse", m, genie_curses_magenta_inverse); a68_idf (A68_EXT, "cursesblueinverse", m, genie_curses_blue_inverse); a68_idf (A68_EXT, "curseswhiteinverse", m, genie_curses_white_inverse); m = proc_char; a68_idf (A68_EXT, "cursesgetchar", m, genie_curses_getchar); m = a68_proc (MODE (VOID), MODE (CHAR), NO_MOID); a68_idf (A68_EXT, "cursesputchar", m, genie_curses_putchar); m = a68_proc (MODE (VOID), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "cursesmove", m, genie_curses_move); m = proc_int; a68_idf (A68_EXT, "curseslines", m, genie_curses_lines); a68_idf (A68_EXT, "cursescolumns", m, genie_curses_columns); m = a68_proc (MODE (BOOL), MODE (CHAR), NO_MOID); a68_idf (A68_EXT, "cursesdelchar", m, genie_curses_del_char); #endif #if HAVE_POSTGRESQL m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (STRING), MODE (REF_STRING), NO_MOID); a68_idf (A68_EXT, "pqconnectdb", m, genie_pq_connectdb); m = a68_proc (MODE (INT), MODE (REF_FILE), NO_MOID); a68_idf (A68_EXT, "pqfinish", m, genie_pq_finish); a68_idf (A68_EXT, "pqreset", m, genie_pq_reset); m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (STRING), NO_MOID); a68_idf (A68_EXT, "pqparameterstatus", m, genie_pq_parameterstatus); a68_idf (A68_EXT, "pqexec", m, genie_pq_exec); a68_idf (A68_EXT, "pqfnumber", m, genie_pq_fnumber); m = a68_proc (MODE (INT), MODE (REF_FILE), NO_MOID); a68_idf (A68_EXT, "pqntuples", m, genie_pq_ntuples); a68_idf (A68_EXT, "pqnfields", m, genie_pq_nfields); a68_idf (A68_EXT, "pqcmdstatus", m, genie_pq_cmdstatus); a68_idf (A68_EXT, "pqcmdtuples", m, genie_pq_cmdtuples); a68_idf (A68_EXT, "pqerrormessage", m, genie_pq_errormessage); a68_idf (A68_EXT, "pqresulterrormessage", m, genie_pq_resulterrormessage); a68_idf (A68_EXT, "pqdb", m, genie_pq_db); a68_idf (A68_EXT, "pquser", m, genie_pq_user); a68_idf (A68_EXT, "pqpass", m, genie_pq_pass); a68_idf (A68_EXT, "pqhost", m, genie_pq_host); a68_idf (A68_EXT, "pqport", m, genie_pq_port); a68_idf (A68_EXT, "pqtty", m, genie_pq_tty); a68_idf (A68_EXT, "pqoptions", m, genie_pq_options); a68_idf (A68_EXT, "pqprotocolversion", m, genie_pq_protocolversion); a68_idf (A68_EXT, "pqserverversion", m, genie_pq_serverversion); a68_idf (A68_EXT, "pqsocket", m, genie_pq_socket); a68_idf (A68_EXT, "pqbackendpid", m, genie_pq_backendpid); m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (INT), NO_MOID); a68_idf (A68_EXT, "pqfname", m, genie_pq_fname); a68_idf (A68_EXT, "pqfformat", m, genie_pq_fformat); m = a68_proc (MODE (INT), MODE (REF_FILE), MODE (INT), MODE (INT), NO_MOID); a68_idf (A68_EXT, "pqgetvalue", m, genie_pq_getvalue); a68_idf (A68_EXT, "pqgetisnull", m, genie_pq_getisnull); #endif } /** @brief Build the standard environ symbol table. **/ void make_standard_environ (void) { stand_moids (); proc_int = a68_proc (MODE (INT), NO_MOID); proc_real = a68_proc (MODE (REAL), NO_MOID); proc_real_real = MODE (PROC_REAL_REAL); proc_real_real_real = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID); proc_real_real_real_real = a68_proc (MODE (REAL), MODE (REAL), MODE (REAL), MODE (REAL), NO_MOID); proc_complex_complex = a68_proc (MODE (COMPLEX), MODE (COMPLEX), NO_MOID); proc_bool = a68_proc (MODE (BOOL), NO_MOID); proc_char = a68_proc (MODE (CHAR), NO_MOID); proc_void = a68_proc (MODE (VOID), NO_MOID); stand_prelude (); stand_transput (); stand_extensions (); } /** Standard prelude implementation, except transput. */ /* This file contains Algol68G's standard environ. Transput routines are not here. Some of the LONG operations are generic for LONG and LONG LONG. This file contains calculus related routines from the C library and GNU scientific library. When GNU scientific library is not installed then the routines in this file will give a runtime error when called. You can also choose to not have them defined in "prelude.c". */ double inverf (double); double inverfc (double); double cputime_0; #define A68_MONAD(n, MODE, OP)\ void n (NODE_T * p) {\ MODE *i;\ POP_OPERAND_ADDRESS (p, i, MODE);\ VALUE (i) = OP (VALUE (i));\ } /** @brief PROC (PROC VOID) VOID on gc event @param p Node in syntax tree. **/ void genie_on_gc_event (NODE_T * p) { POP_PROCEDURE (p, &on_gc_event); } /** @brief Generic procedure for OP AND BECOMES (+:=, -:=, ...). @param p Node in syntax tree. @param ref Mode of destination. @param f Pointer to function that performs operation. **/ void genie_f_and_becomes (NODE_T * p, MOID_T * ref, GPROC * f) { MOID_T *mode = SUB (ref); int size = SIZE (mode); BYTE_T *src = STACK_OFFSET (-size), *addr; A68_REF *dst = (A68_REF *) STACK_OFFSET (-size - A68_REF_SIZE); CHECK_REF (p, *dst, ref); addr = ADDRESS (dst); PUSH (p, addr, size); genie_check_initialisation (p, STACK_OFFSET (-size), mode); PUSH (p, src, size); (*f) (p); POP (p, addr, size); DECREMENT_STACK_POINTER (p, size); } /* Environment enquiries */ A68_ENV_INT (genie_int_lengths, 3) A68_ENV_INT (genie_int_shorths, 1) A68_ENV_INT (genie_real_lengths, 3) A68_ENV_INT (genie_real_shorths, 1) A68_ENV_INT (genie_complex_lengths, 3) A68_ENV_INT (genie_complex_shorths, 1) A68_ENV_INT (genie_bits_lengths, 3) A68_ENV_INT (genie_bits_shorths, 1) A68_ENV_INT (genie_bytes_lengths, 2) A68_ENV_INT (genie_bytes_shorths, 1) A68_ENV_INT (genie_int_width, INT_WIDTH) A68_ENV_INT (genie_long_int_width, LONG_INT_WIDTH) A68_ENV_INT (genie_longlong_int_width, LONGLONG_INT_WIDTH) A68_ENV_INT (genie_real_width, REAL_WIDTH) A68_ENV_INT (genie_long_real_width, LONG_REAL_WIDTH) A68_ENV_INT (genie_longlong_real_width, LONGLONG_REAL_WIDTH) A68_ENV_INT (genie_exp_width, EXP_WIDTH) A68_ENV_INT (genie_long_exp_width, LONG_EXP_WIDTH) A68_ENV_INT (genie_longlong_exp_width, LONGLONG_EXP_WIDTH) A68_ENV_INT (genie_bits_width, BITS_WIDTH) A68_ENV_INT (genie_long_bits_width, get_mp_bits_width (MODE (LONG_BITS))) A68_ENV_INT (genie_longlong_bits_width, get_mp_bits_width (MODE (LONGLONG_BITS))) A68_ENV_INT (genie_bytes_width, BYTES_WIDTH) A68_ENV_INT (genie_long_bytes_width, LONG_BYTES_WIDTH) A68_ENV_INT (genie_max_abs_char, UCHAR_MAX) A68_ENV_INT (genie_max_int, A68_MAX_INT) A68_ENV_REAL (genie_max_real, DBL_MAX) A68_ENV_REAL (genie_min_real, DBL_MIN) A68_ENV_REAL (genie_small_real, DBL_EPSILON) A68_ENV_REAL (genie_pi, A68_PI) A68_ENV_REAL (genie_cputime, seconds () - cputime_0) A68_ENV_INT (genie_stack_pointer, stack_pointer) A68_ENV_INT (genie_system_stack_size, stack_size) /** @brief INT system stack pointer @param p Node in syntax tree. **/ void genie_system_stack_pointer (NODE_T * p) { BYTE_T stack_offset; PUSH_PRIMITIVE (p, (int) (system_stack_offset - &stack_offset), A68_INT); } /** @brief LONG INT max long int @param p Node in syntax tree. **/ void genie_long_max_int (NODE_T * p) { int digits = DIGITS (MODE (LONG_INT)); MP_T *z; int k, j = 1 + digits; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (digits - 1); for (k = 2; k <= j; k++) { z[k] = (MP_T) (MP_RADIX - 1); } } /** @brief LONG LONG INT max long long int @param p Node in syntax tree. **/ void genie_longlong_max_int (NODE_T * p) { int digits = DIGITS (MODE (LONGLONG_INT)); MP_T *z; int k, j = 1 + digits; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (digits - 1); for (k = 2; k <= j; k++) { z[k] = (MP_T) (MP_RADIX - 1); } } /** @brief LONG REAL max long real @param p Node in syntax tree. **/ void genie_long_max_real (NODE_T * p) { int j, digits = DIGITS (MODE (LONG_REAL)); MP_T *z; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (MAX_MP_EXPONENT - 1); for (j = 2; j <= 1 + digits; j++) { z[j] = (MP_T) (MP_RADIX - 1); } } /** @brief LONG LONG REAL max long long real @param p Node in syntax tree. **/ void genie_longlong_max_real (NODE_T * p) { int j, digits = DIGITS (MODE (LONGLONG_REAL)); MP_T *z; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) (MAX_MP_EXPONENT - 1); for (j = 2; j <= 1 + digits; j++) { z[j] = (MP_T) (MP_RADIX - 1); } } /** @brief LONG REAL min long real @param p Node in syntax tree. **/ void genie_long_min_real (NODE_T * p) { int digits = DIGITS (MODE (LONG_REAL)); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) -(MAX_MP_EXPONENT); MP_DIGIT (z, 1) = (MP_T) 1; } /** @brief LONG LONG REAL min long long real @param p Node in syntax tree. **/ void genie_longlong_min_real (NODE_T * p) { int digits = DIGITS (MODE (LONGLONG_REAL)); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) -(MAX_MP_EXPONENT); MP_DIGIT (z, 1) = (MP_T) 1; } /** @brief LONG REAL small long real @param p Node in syntax tree. **/ void genie_long_small_real (NODE_T * p) { int j, digits = DIGITS (MODE (LONG_REAL)); MP_T *z; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) -(digits - 1); MP_DIGIT (z, 1) = (MP_T) 1; for (j = 3; j <= 1 + digits; j++) { z[j] = (MP_T) 0; } } /** @brief LONG LONG REAL small long long real @param p Node in syntax tree. **/ void genie_longlong_small_real (NODE_T * p) { int j, digits = DIGITS (MODE (LONGLONG_REAL)); MP_T *z; STACK_MP (z, p, digits); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) -(digits - 1); MP_DIGIT (z, 1) = (MP_T) 1; for (j = 3; j <= 1 + digits; j++) { z[j] = (MP_T) 0; } } /** @brief BITS max bits @param p Node in syntax tree. **/ void genie_max_bits (NODE_T * p) { PUSH_PRIMITIVE (p, A68_MAX_BITS, A68_BITS); } /** @brief LONG BITS long max bits @param p Node in syntax tree. **/ void genie_long_max_bits (NODE_T * p) { int digits = DIGITS (MODE (LONG_BITS)); int width = get_mp_bits_width (MODE (LONG_BITS)); ADDR_T pop_sp; MP_T *z, *one; STACK_MP (z, p, digits); pop_sp = stack_pointer; STACK_MP (one, p, digits); (void) set_mp_short (z, (MP_T) 2, 0, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits); (void) pow_mp_int (p, z, z, width, digits); (void) sub_mp (p, z, z, one, digits); stack_pointer = pop_sp; } /** @brief LONG LONG BITS long long max bits @param p Node in syntax tree. **/ void genie_longlong_max_bits (NODE_T * p) { int digits = DIGITS (MODE (LONGLONG_BITS)); int width = get_mp_bits_width (MODE (LONGLONG_BITS)); ADDR_T pop_sp; MP_T *z, *one; STACK_MP (z, p, digits); pop_sp = stack_pointer; STACK_MP (one, p, digits); (void) set_mp_short (z, (MP_T) 2, 0, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits); (void) pow_mp_int (p, z, z, width, digits); (void) sub_mp (p, z, z, one, digits); stack_pointer = pop_sp; } /** @brief LONG REAL long pi @param p Node in syntax tree. **/ void genie_pi_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)); MP_T *z; STACK_MP (z, p, digits); (void) mp_pi (p, z, MP_PI, digits); MP_STATUS (z) = (MP_T) INIT_MASK; } /* BOOL operations */ /* OP NOT = (BOOL) BOOL */ A68_MONAD (genie_not_bool, A68_BOOL, (BOOL_T) !) /** @brief OP ABS = (BOOL) INT @param p Node in syntax tree. **/ void genie_abs_bool (NODE_T * p) { A68_BOOL j; POP_OBJECT (p, &j, A68_BOOL); PUSH_PRIMITIVE (p, (VALUE (&j) ? 1 : 0), A68_INT); } #define A68_BOOL_DYAD(n, OP)\ void n (NODE_T * p) {\ A68_BOOL *i, *j;\ POP_OPERAND_ADDRESSES (p, i, j, A68_BOOL);\ VALUE (i) = (BOOL_T) (VALUE (i) OP VALUE (j));\ } A68_BOOL_DYAD (genie_and_bool, &) A68_BOOL_DYAD (genie_or_bool, |) A68_BOOL_DYAD (genie_xor_bool, ^) A68_BOOL_DYAD (genie_eq_bool, ==) A68_BOOL_DYAD (genie_ne_bool, !=) /* INT operations */ /* OP - = (INT) INT */ A68_MONAD (genie_minus_int, A68_INT, -) /** @brief OP ABS = (INT) INT @param p Node in syntax tree. **/ void genie_abs_int (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = ABS (VALUE (j)); } /** @brief OP SIGN = (INT) INT @param p Node in syntax tree. **/ void genie_sign_int (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = SIGN (VALUE (j)); } /** @brief OP ODD = (INT) INT @param p Node in syntax tree. **/ void genie_odd_int (NODE_T * p) { A68_INT j; POP_OBJECT (p, &j, A68_INT); PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&j) >= 0 ? VALUE (&j) : -VALUE (&j)) % 2 == 1), A68_BOOL); } /** @brief OP + = (INT, INT) INT @param p Node in syntax tree. **/ void genie_add_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); CHECK_INT_ADDITION (p, VALUE (i), VALUE (j)); VALUE (i) += VALUE (j); } /** @brief OP - = (INT, INT) INT @param p Node in syntax tree. **/ void genie_sub_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); CHECK_INT_SUBTRACTION (p, VALUE (i), VALUE (j)); VALUE (i) -= VALUE (j); } /** @brief OP * = (INT, INT) INT @param p Node in syntax tree. **/ void genie_mul_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); CHECK_INT_MULTIPLICATION (p, VALUE (i), VALUE (j)); VALUE (i) *= VALUE (j); } /** @brief OP OVER = (INT, INT) INT @param p Node in syntax tree. **/ void genie_over_int (NODE_T * p) { A68_INT *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT)); VALUE (i) /= VALUE (j); } /** @brief OP MOD = (INT, INT) INT @param p Node in syntax tree. **/ void genie_mod_int (NODE_T * p) { A68_INT *i, *j; int k; POP_OPERAND_ADDRESSES (p, i, j, A68_INT); PRELUDE_ERROR (VALUE (j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT)); k = VALUE (i) % VALUE (j); if (k < 0) { k += (VALUE (j) >= 0 ? VALUE (j) : -VALUE (j)); } VALUE (i) = k; } /** @brief OP / = (INT, INT) REAL @param p Node in syntax tree. **/ void genie_div_int (NODE_T * p) { A68_INT i, j; POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT)); PUSH_PRIMITIVE (p, (double) (VALUE (&i)) / (double) (VALUE (&j)), A68_REAL); } /** @brief OP ** = (INT, INT) INT @param p Node in syntax tree. **/ void genie_pow_int (NODE_T * p) { A68_INT i, j; int expo, mult, prod; POP_OBJECT (p, &j, A68_INT); PRELUDE_ERROR (VALUE (&j) < 0, p, ERROR_EXPONENT_INVALID, MODE (INT)); POP_OBJECT (p, &i, A68_INT); prod = 1; mult = VALUE (&i); expo = 1; while ((unsigned) expo <= (unsigned) (VALUE (&j))) { if (VALUE (&j) & expo) { CHECK_INT_MULTIPLICATION (p, prod, mult); prod *= mult; } expo <<= 1; if (expo <= VALUE (&j)) { CHECK_INT_MULTIPLICATION (p, mult, mult); mult *= mult; } } PUSH_PRIMITIVE (p, prod, A68_INT); } /* OP (INT, INT) BOOL */ #define A68_CMP_INT(n, OP)\ void n (NODE_T * p) {\ A68_INT i, j;\ POP_OBJECT (p, &j, A68_INT);\ POP_OBJECT (p, &i, A68_INT);\ PUSH_PRIMITIVE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\ } A68_CMP_INT (genie_eq_int, ==) A68_CMP_INT (genie_ne_int, !=) A68_CMP_INT (genie_lt_int, <) A68_CMP_INT (genie_gt_int, >) A68_CMP_INT (genie_le_int, <=) A68_CMP_INT (genie_ge_int, >=) /** @brief OP +:= = (REF INT, INT) REF INT @param p Node in syntax tree. **/ void genie_plusab_int (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_INT), genie_add_int); } /** @brief OP -:= = (REF INT, INT) REF INT @param p Node in syntax tree. **/ void genie_minusab_int (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_INT), genie_sub_int); } /** @brief OP *:= = (REF INT, INT) REF INT @param p Node in syntax tree. **/ void genie_timesab_int (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_INT), genie_mul_int); } /** @brief OP %:= = (REF INT, INT) REF INT @param p Node in syntax tree. **/ void genie_overab_int (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_INT), genie_over_int); } /** @brief OP %*:= = (REF INT, INT) REF INT @param p Node in syntax tree. **/ void genie_modab_int (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_INT), genie_mod_int); } /** @brief OP LENG = (INT) LONG INT @param p Node in syntax tree. **/ void genie_lengthen_int_to_long_mp (NODE_T * p) { int digits = DIGITS (MODE (LONG_INT)); MP_T *z; A68_INT k; POP_OBJECT (p, &k, A68_INT); STACK_MP (z, p, digits); (void) int_to_mp (p, z, VALUE (&k), digits); MP_STATUS (z) = (MP_T) INIT_MASK; } /** @brief OP LENG = (BITS) LONG BITS @param p Node in syntax tree. **/ void genie_lengthen_unsigned_to_long_mp (NODE_T * p) { int digits = DIGITS (MODE (LONG_INT)); MP_T *z; A68_BITS k; POP_OBJECT (p, &k, A68_BITS); STACK_MP (z, p, digits); (void) unsigned_to_mp (p, z, (unsigned) VALUE (&k), digits); MP_STATUS (z) = (MP_T) INIT_MASK; } /** @brief OP SHORTEN = (LONG INT) INT @param p Node in syntax tree. **/ void genie_shorten_long_mp_to_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *z; DECREMENT_STACK_POINTER (p, size); z = (MP_T *) STACK_TOP; MP_STATUS (z) = (MP_T) INIT_MASK; PUSH_PRIMITIVE (p, mp_to_int (p, z, digits), A68_INT); } /** @brief OP ODD = (LONG INT) BOOL @param p Node in syntax tree. **/ void genie_odd_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *z = (MP_T *) STACK_OFFSET (-size); DECREMENT_STACK_POINTER (p, size); if (MP_EXPONENT (z) <= (MP_T) (digits - 1)) { PUSH_PRIMITIVE (p, (BOOL_T) ((int) (z[(int) (2 + MP_EXPONENT (z))]) % 2 != 0), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } } /** @brief Test whether z is a valid LONG INT. @param p Node in syntax tree. @param z Mp number. @param m Mode associated with z. **/ void test_long_int_range (NODE_T * p, MP_T * z, MOID_T * m) { PRELUDE_ERROR (!check_mp_int (z, m), p, ERROR_OUT_OF_BOUNDS, m); } /** @brief OP + = (LONG INT, LONG INT) LONG INT @param p Node in syntax tree. **/ void genie_add_long_int (NODE_T * p) { MOID_T *m = RHS_MODE (p); int digits = DIGITS (m), size = SIZE (m); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) add_mp (p, x, x, y, digits); test_long_int_range (p, x, m); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /** @brief OP - = (LONG INT, LONG INT) LONG INT @param p Node in syntax tree. **/ void genie_sub_long_int (NODE_T * p) { MOID_T *m = RHS_MODE (p); int digits = DIGITS (m), size = SIZE (m); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) sub_mp (p, x, x, y, digits); test_long_int_range (p, x, m); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /** @brief OP * = (LONG INT, LONG INT) LONG INT @param p Node in syntax tree. **/ void genie_mul_long_int (NODE_T * p) { MOID_T *m = RHS_MODE (p); int digits = DIGITS (m), size = SIZE (m); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) mul_mp (p, x, x, y, digits); test_long_int_range (p, x, m); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /** @brief OP ** = (LONG MODE, INT) LONG INT @param p Node in syntax tree. **/ void genie_pow_long_mp_int_int (NODE_T * p) { MOID_T *m = LHS_MODE (p); int digits = DIGITS (m), size = SIZE (m); A68_INT k; MP_T *x; POP_OBJECT (p, &k, A68_INT); x = (MP_T *) STACK_OFFSET (-size); (void) pow_mp_int (p, x, x, VALUE (&k), digits); test_long_int_range (p, x, m); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief OP +:= = (REF LONG INT, LONG INT) REF LONG INT @param p Node in syntax tree. **/ void genie_plusab_long_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_add_long_int); } /** @brief OP -:= = (REF LONG INT, LONG INT) REF LONG INT @param p Node in syntax tree. **/ void genie_minusab_long_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_sub_long_int); } /** @brief OP *:= = (REF LONG INT, LONG INT) REF LONG INT @param p Node in syntax tree. **/ void genie_timesab_long_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mul_long_int); } /* REAL operations. REAL math is in gsl.c */ /* OP - = (REAL) REAL */ A68_MONAD (genie_minus_real, A68_REAL, -) /** @brief OP ABS = (REAL) REAL @param p Node in syntax tree. **/ void genie_abs_real (NODE_T * p) { A68_REAL *x; POP_OPERAND_ADDRESS (p, x, A68_REAL); VALUE (x) = ABS (VALUE (x)); } /** @brief OP ROUND = (REAL) INT @param p Node in syntax tree. **/ void genie_round_real (NODE_T * p) { A68_REAL x; POP_OBJECT (p, &x, A68_REAL); PRELUDE_ERROR (VALUE (&x) < -(double) A68_MAX_INT || VALUE (&x) > (double) A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); PUSH_PRIMITIVE (p, a68g_round (VALUE (&x)), A68_INT); } /** @brief OP ENTIER = (REAL) INT @param p Node in syntax tree. **/ void genie_entier_real (NODE_T * p) { A68_REAL x; POP_OBJECT (p, &x, A68_REAL); PRELUDE_ERROR (VALUE (&x) < -(double) A68_MAX_INT || VALUE (&x) > (double)A68_MAX_INT, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); PUSH_PRIMITIVE (p, (int) floor (VALUE (&x)), A68_INT); } /** @brief OP SIGN = (REAL) INT @param p Node in syntax tree. **/ void genie_sign_real (NODE_T * p) { A68_REAL x; POP_OBJECT (p, &x, A68_REAL); PUSH_PRIMITIVE (p, SIGN (VALUE (&x)), A68_INT); } /** @brief OP + = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_add_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); VALUE (x) += VALUE (y); CHECK_REAL_REPRESENTATION (p, VALUE (x)); } /** @brief OP - = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_sub_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); VALUE (x) -= VALUE (y); CHECK_REAL_REPRESENTATION (p, VALUE (x)); } /** @brief OP * = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_mul_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); VALUE (x) *= VALUE (y); CHECK_REAL_REPRESENTATION (p, VALUE (x)); } /** @brief OP / = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_div_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); PRELUDE_ERROR (VALUE (y) == 0.0, p, ERROR_DIVISION_BY_ZERO, MODE (REAL)); VALUE (x) /= VALUE (y); } /** @brief OP ** = (REAL, INT) REAL @param p Node in syntax tree. **/ void genie_pow_real_int (NODE_T * p) { A68_INT j; A68_REAL x; int expo; double mult, prod; BOOL_T negative; POP_OBJECT (p, &j, A68_INT); negative = (BOOL_T) (VALUE (&j) < 0); VALUE (&j) = (VALUE (&j) >= 0 ? VALUE (&j) : -VALUE (&j)); POP_OBJECT (p, &x, A68_REAL); prod = 1; mult = VALUE (&x); expo = 1; while ((unsigned) expo <= (unsigned) (VALUE (&j))) { if (VALUE (&j) & expo) { CHECK_REAL_MULTIPLICATION (p, prod, mult); prod *= mult; } expo <<= 1; if (expo <= VALUE (&j)) { CHECK_REAL_MULTIPLICATION (p, mult, mult); mult *= mult; } } CHECK_REAL_REPRESENTATION (p, prod); if (negative) { prod = 1.0 / prod; } PUSH_PRIMITIVE (p, prod, A68_REAL); } /** @brief OP ** = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_pow_real (NODE_T * p) { A68_REAL x, y; double z = 0; POP_OBJECT (p, &y, A68_REAL); POP_OBJECT (p, &x, A68_REAL); RESET_ERRNO; PRELUDE_ERROR (VALUE (&x) < 0.0, p, ERROR_INVALID_ARGUMENT, MODE (REAL)); if (VALUE (&x) == 0.0) { if (VALUE (&y) < 0) { errno = ERANGE; MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } else { z = (VALUE (&y) == 0.0 ? 1.0 : 0.0); } } else { z = exp (VALUE (&y) * log (VALUE (&x))); MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } PUSH_PRIMITIVE (p, z, A68_REAL); } /* OP (REAL, REAL) BOOL */ #define A68_CMP_REAL(n, OP)\ void n (NODE_T * p) {\ A68_REAL i, j;\ POP_OBJECT (p, &j, A68_REAL);\ POP_OBJECT (p, &i, A68_REAL);\ PUSH_PRIMITIVE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\ } A68_CMP_REAL (genie_eq_real, ==) A68_CMP_REAL (genie_ne_real, !=) A68_CMP_REAL (genie_lt_real, <) A68_CMP_REAL (genie_gt_real, >) A68_CMP_REAL (genie_le_real, <=) A68_CMP_REAL (genie_ge_real, >=) /** @brief OP +:= = (REF REAL, REAL) REF REAL @param p Node in syntax tree. **/ void genie_plusab_real (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_REAL), genie_add_real); } /** @brief OP -:= = (REF REAL, REAL) REF REAL @param p Node in syntax tree. **/ void genie_minusab_real (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_REAL), genie_sub_real); } /** @brief OP *:= = (REF REAL, REAL) REF REAL @param p Node in syntax tree. **/ void genie_timesab_real (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_REAL), genie_mul_real); } /** @brief OP /:= = (REF REAL, REAL) REF REAL @param p Node in syntax tree. **/ void genie_divab_real (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_REAL), genie_div_real); } /** @brief OP LENG = (REAL) LONG REAL @param p Node in syntax tree. **/ void genie_lengthen_real_to_long_mp (NODE_T * p) { int digits = DIGITS (MODE (LONG_REAL)); MP_T *z; A68_REAL x; POP_OBJECT (p, &x, A68_REAL); STACK_MP (z, p, digits); (void) real_to_mp (p, z, VALUE (&x), digits); MP_STATUS (z) = (MP_T) INIT_MASK; } /** @brief OP SHORTEN = (LONG REAL) REAL @param p Node in syntax tree. **/ void genie_shorten_long_mp_to_real (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *z; DECREMENT_STACK_POINTER (p, size); z = (MP_T *) STACK_TOP; MP_STATUS (z) = (MP_T) INIT_MASK; PUSH_PRIMITIVE (p, mp_to_real (p, z, digits), A68_REAL); } /** @brief OP ROUND = (LONG REAL) LONG INT @param p Node in syntax tree. **/ void genie_round_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); ADDR_T pop_sp = stack_pointer; MP_T *z = (MP_T *) STACK_OFFSET (-size); (void) round_mp (p, z, z, digits); stack_pointer = pop_sp; } /** @brief OP ENTIER = (LONG REAL) LONG INT @param p Node in syntax tree. **/ void genie_entier_long_mp (NODE_T * p) { int digits = DIGITS (LHS_MODE (p)), size = SIZE (LHS_MODE (p)); ADDR_T pop_sp = stack_pointer; MP_T *z = (MP_T *) STACK_OFFSET (-size); (void) entier_mp (p, z, z, digits); stack_pointer = pop_sp; } /** @brief PROC long sqrt = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_sqrt_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (sqrt_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long curt = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_curt_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (curt_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long exp = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_exp_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); ADDR_T pop_sp = stack_pointer; MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) exp_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; stack_pointer = pop_sp; } /** @brief PROC long ln = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_ln_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); ADDR_T pop_sp = stack_pointer; MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (ln_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; stack_pointer = pop_sp; } /** @brief PROC long log = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_log_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); ADDR_T pop_sp = stack_pointer; MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (log_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; stack_pointer = pop_sp; } /** @brief PROC long sinh = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_sinh_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) sinh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long cosh = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_cosh_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) cosh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long tanh = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_tanh_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) tanh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long arcsinh = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_arcsinh_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) asinh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long arccosh = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_arccosh_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) acosh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long arctanh = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_arctanh_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) atanh_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long sin = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_sin_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) sin_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long cos = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_cos_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) cos_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long tan = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_tan_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (tan_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long arcsin = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_asin_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (asin_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long arccos = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_acos_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (acos_mp (p, x, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long arctan = (LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_atan_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *x = (MP_T *) STACK_OFFSET (-size); (void) atan_mp (p, x, x, digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief PROC long arctan2 = (LONG REAL, LONG REAL) LONG REAL @param p Node in syntax tree. **/ void genie_atan2_long_mp (NODE_T * p) { int digits = DIGITS (MOID (p)), size = SIZE (MOID (p)); MP_T *y = (MP_T *) STACK_OFFSET (-size); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); stack_pointer -= size; PRELUDE_ERROR (atan2_mp (p, x, y, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); MP_STATUS (x) = (MP_T) INIT_MASK; } /* Arithmetic operations */ /** @brief OP LENG = (LONG MODE) LONG LONG MODE @param p Node in syntax tree. **/ void genie_lengthen_long_mp_to_longlong_mp (NODE_T * p) { MP_T *z; DECREMENT_STACK_POINTER (p, (int) size_long_mp ()); STACK_MP (z, p, longlong_mp_digits ()); (void) lengthen_mp (p, z, longlong_mp_digits (), z, long_mp_digits ()); MP_STATUS (z) = (MP_T) INIT_MASK; } /** @brief OP SHORTEN = (LONG LONG MODE) LONG MODE @param p Node in syntax tree. **/ void genie_shorten_longlong_mp_to_long_mp (NODE_T * p) { MP_T *z; MOID_T *m = SUB_MOID (p); DECREMENT_STACK_POINTER (p, (int) size_longlong_mp ()); STACK_MP (z, p, long_mp_digits ()); if (m == MODE (LONG_INT)) { PRELUDE_ERROR (MP_EXPONENT (z) > LONG_MP_DIGITS - 1, p, ERROR_OUT_OF_BOUNDS, m); } (void) shorten_mp (p, z, long_mp_digits (), z, longlong_mp_digits ()); MP_STATUS (z) = (MP_T) INIT_MASK; } /** @brief OP - = (LONG MODE) LONG MODE @param p Node in syntax tree. **/ void genie_minus_long_mp (NODE_T * p) { int size = SIZE (LHS_MODE (p)); MP_T *z = (MP_T *) STACK_OFFSET (-size); MP_STATUS (z) = (MP_T) INIT_MASK; MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } /** @brief OP ABS = (LONG MODE) LONG MODE @param p Node in syntax tree. **/ void genie_abs_long_mp (NODE_T * p) { int size = SIZE (LHS_MODE (p)); MP_T *z = (MP_T *) STACK_OFFSET (-size); MP_STATUS (z) = (MP_T) INIT_MASK; MP_DIGIT (z, 1) = ABS (MP_DIGIT (z, 1)); } /** @brief OP SIGN = (LONG MODE) INT @param p Node in syntax tree. **/ void genie_sign_long_mp (NODE_T * p) { int size = SIZE (LHS_MODE (p)); MP_T *z = (MP_T *) STACK_OFFSET (-size); DECREMENT_STACK_POINTER (p, size); PUSH_PRIMITIVE (p, SIGN (MP_DIGIT (z, 1)), A68_INT); } /** @brief OP + = (LONG MODE, LONG MODE) LONG MODE @param p Node in syntax tree. **/ void genie_add_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) add_mp (p, x, x, y, digits); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /** @brief OP - = (LONG MODE, LONG MODE) LONG MODE @param p Node in syntax tree. **/ void genie_sub_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) sub_mp (p, x, x, y, digits); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /** @brief OP * = (LONG MODE, LONG MODE) LONG MODE @param p Node in syntax tree. **/ void genie_mul_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); (void) mul_mp (p, x, x, y, digits); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /** @brief OP / = (LONG MODE, LONG MODE) LONG MODE @param p Node in syntax tree. **/ void genie_div_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (div_mp (p, x, x, y, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, MODE (LONG_REAL)); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /** @brief OP % = (LONG MODE, LONG MODE) LONG MODE @param p Node in syntax tree. **/ void genie_over_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (over_mp (p, x, x, y, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, MODE (LONG_INT)); MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /** @brief OP %* = (LONG MODE, LONG MODE) LONG MODE @param p Node in syntax tree. **/ void genie_mod_long_mp (NODE_T * p) { MOID_T *mode = RHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); PRELUDE_ERROR (mod_mp (p, x, x, y, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, MODE (LONG_INT)); if (MP_DIGIT (x, 1) < 0) { MP_DIGIT (y, 1) = ABS (MP_DIGIT (y, 1)); (void) add_mp (p, x, x, y, digits); } MP_STATUS (x) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /** @brief OP +:= = (REF LONG MODE, LONG MODE) REF LONG MODE @param p Node in syntax tree. **/ void genie_plusab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_add_long_mp); } /** @brief OP -:= = (REF LONG MODE, LONG MODE) REF LONG MODE @param p Node in syntax tree. **/ void genie_minusab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_sub_long_mp); } /** @brief OP *:= = (REF LONG MODE, LONG MODE) REF LONG MODE @param p Node in syntax tree. **/ void genie_timesab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mul_long_mp); } /** @brief OP /:= = (REF LONG MODE, LONG MODE) REF LONG MODE @param p Node in syntax tree. **/ void genie_divab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_div_long_mp); } /** @brief OP %:= = (REF LONG MODE, LONG MODE) REF LONG MODE @param p Node in syntax tree. **/ void genie_overab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_over_long_mp); } /** @brief OP %*:= = (REF LONG MODE, LONG MODE) REF LONG MODE @param p Node in syntax tree. **/ void genie_modab_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mod_long_mp); } /* OP (LONG MODE, LONG MODE) BOOL */ #define A68_CMP_LONG(n, OP)\ void n (NODE_T * p) {\ MOID_T *mode = LHS_MODE (p);\ A68_BOOL z;\ int digits = DIGITS (mode), size = SIZE (mode);\ MP_T *x = (MP_T *) STACK_OFFSET (-2 * size);\ MP_T *y = (MP_T *) STACK_OFFSET (-size);\ OP (p, &z, x, y, digits);\ DECREMENT_STACK_POINTER (p, 2 * size);\ PUSH_PRIMITIVE (p, VALUE (&z), A68_BOOL);\ } A68_CMP_LONG (genie_eq_long_mp, eq_mp) A68_CMP_LONG (genie_ne_long_mp, ne_mp) A68_CMP_LONG (genie_lt_long_mp, lt_mp) A68_CMP_LONG (genie_gt_long_mp, gt_mp) A68_CMP_LONG (genie_le_long_mp, le_mp) A68_CMP_LONG (genie_ge_long_mp, ge_mp) /** @brief OP ** = (LONG MODE, INT) LONG MODE @param p Node in syntax tree. **/ void genie_pow_long_mp_int (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); A68_INT k; MP_T *x; POP_OBJECT (p, &k, A68_INT); x = (MP_T *) STACK_OFFSET (-size); (void) pow_mp_int (p, x, x, VALUE (&k), digits); MP_STATUS (x) = (MP_T) INIT_MASK; } /** @brief OP ** = (LONG MODE, LONG MODE) LONG MODE @param p Node in syntax tree. **/ void genie_pow_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); ADDR_T pop_sp = stack_pointer; MP_T *x = (MP_T *) STACK_OFFSET (-2 * size); MP_T *y = (MP_T *) STACK_OFFSET (-size); MP_T *z; STACK_MP (z, p, digits); if (IS_ZERO_MP (x)) { if (MP_DIGIT (y, 1) < (MP_T) 0) { PRELUDE_ERROR (A68_TRUE, p, ERROR_INVALID_ARGUMENT, MOID (p)); } else if (IS_ZERO_MP (y)) { (void) set_mp_short (x, (MP_T) 1, 0, digits); } } else { PRELUDE_ERROR (ln_mp (p, z, x, digits) == NO_MP, p, ERROR_INVALID_ARGUMENT, MOID (p)); (void) mul_mp (p, z, y, z, digits); (void) exp_mp (p, x, z, digits); } stack_pointer = pop_sp - size; MP_STATUS (x) = (MP_T) INIT_MASK; } /* Character operations */ /* OP (CHAR, CHAR) BOOL */ #define A68_CMP_CHAR(n, OP)\ void n (NODE_T * p) {\ A68_CHAR i, j;\ POP_OBJECT (p, &j, A68_CHAR);\ POP_OBJECT (p, &i, A68_CHAR);\ PUSH_PRIMITIVE (p, (BOOL_T) (TO_UCHAR (VALUE (&i)) OP TO_UCHAR (VALUE (&j))), A68_BOOL);\ } A68_CMP_CHAR (genie_eq_char, ==) A68_CMP_CHAR (genie_ne_char, !=) A68_CMP_CHAR (genie_lt_char, <) A68_CMP_CHAR (genie_gt_char, >) A68_CMP_CHAR (genie_le_char, <=) A68_CMP_CHAR (genie_ge_char, >=) /** @brief OP ABS = (CHAR) INT @param p Node in syntax tree. **/ void genie_abs_char (NODE_T * p) { A68_CHAR i; POP_OBJECT (p, &i, A68_CHAR); PUSH_PRIMITIVE (p, TO_UCHAR (VALUE (&i)), A68_INT); } /** @brief OP REPR = (INT) CHAR @param p Node in syntax tree. **/ void genie_repr_char (NODE_T * p) { A68_INT k; POP_OBJECT (p, &k, A68_INT); PRELUDE_ERROR (VALUE (&k) < 0 || VALUE (&k) > (int) UCHAR_MAX, p, ERROR_OUT_OF_BOUNDS, MODE (CHAR)); PUSH_PRIMITIVE (p, (char) (VALUE (&k)), A68_CHAR); } /* OP (CHAR) BOOL */ #define A68_CHAR_BOOL(n, OP)\ void n (NODE_T * p) {\ A68_CHAR ch;\ POP_OBJECT (p, &ch, A68_CHAR);\ PUSH_PRIMITIVE (p, (BOOL_T) (OP (VALUE (&ch)) == 0 ? A68_FALSE : A68_TRUE), A68_BOOL);\ } A68_CHAR_BOOL (genie_is_alnum, IS_ALNUM) A68_CHAR_BOOL (genie_is_alpha, IS_ALPHA) A68_CHAR_BOOL (genie_is_cntrl, IS_CNTRL) A68_CHAR_BOOL (genie_is_digit, IS_DIGIT) A68_CHAR_BOOL (genie_is_graph, IS_GRAPH) A68_CHAR_BOOL (genie_is_lower, IS_LOWER) A68_CHAR_BOOL (genie_is_print, IS_PRINT) A68_CHAR_BOOL (genie_is_punct, IS_PUNCT) A68_CHAR_BOOL (genie_is_space, IS_SPACE) A68_CHAR_BOOL (genie_is_upper, IS_UPPER) A68_CHAR_BOOL (genie_is_xdigit, IS_XDIGIT) #define A68_CHAR_CHAR(n, OP)\ void n (NODE_T * p) {\ A68_CHAR *ch;\ POP_OPERAND_ADDRESS (p, ch, A68_CHAR);\ VALUE (ch) = (char) (OP (TO_UCHAR (VALUE (ch))));\ } A68_CHAR_CHAR (genie_to_lower, TO_LOWER) A68_CHAR_CHAR (genie_to_upper, TO_UPPER) /** @brief OP + = (CHAR, CHAR) STRING @param p Node in syntax tree. **/ void genie_add_char (NODE_T * p) { A68_CHAR a, b; A68_REF c, d; A68_ARRAY *a_3; A68_TUPLE *t_3; BYTE_T *b_3; /* right part */ POP_OBJECT (p, &b, A68_CHAR); CHECK_INIT (p, INITIALISED (&b), MODE (CHAR)); /* left part */ POP_OBJECT (p, &a, A68_CHAR); CHECK_INIT (p, INITIALISED (&a), MODE (CHAR)); /* sum */ c = heap_generator (p, MODE (STRING), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); d = heap_generator (p, MODE (STRING), 2 * SIZE (MODE (CHAR))); GET_DESCRIPTOR (a_3, t_3, &c); DIM (a_3) = 1; MOID (a_3) = MODE (CHAR); ELEM_SIZE (a_3) = SIZE (MODE (CHAR)); SLICE_OFFSET (a_3) = 0; FIELD_OFFSET (a_3) = 0; ARRAY (a_3) = d; LWB (t_3) = 1; UPB (t_3) = 2; SHIFT (t_3) = LWB (t_3); SPAN (t_3) = 1; /* add chars */ b_3 = DEREF (BYTE_T, &ARRAY (a_3)); MOVE ((BYTE_T *) & b_3[0], (BYTE_T *) & a, SIZE (MODE (CHAR))); MOVE ((BYTE_T *) & b_3[SIZE (MODE (CHAR))], (BYTE_T *) & b, SIZE (MODE (CHAR))); PUSH_REF (p, c); } /** @brief OP ELEM = (INT, STRING) CHAR # ALGOL68C # @param p Node in syntax tree. **/ void genie_elem_string (NODE_T * p) { A68_REF z; A68_ARRAY *a; A68_TUPLE *t; A68_INT k; BYTE_T *base; A68_CHAR *ch; POP_REF (p, &z); CHECK_REF (p, z, MODE (STRING)); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (a, t, &z); PRELUDE_ERROR (VALUE (&k) < LWB (t), p, ERROR_INDEX_OUT_OF_BOUNDS, NO_TEXT); PRELUDE_ERROR (VALUE (&k) > UPB (t), p, ERROR_INDEX_OUT_OF_BOUNDS, NO_TEXT); base = DEREF (BYTE_T, &(ARRAY (a))); ch = (A68_CHAR *) & (base[INDEX_1_DIM (a, t, VALUE (&k))]); PUSH_PRIMITIVE (p, VALUE (ch), A68_CHAR); } /** @brief OP + = (STRING, STRING) STRING @param p Node in syntax tree. **/ void genie_add_string (NODE_T * p) { A68_REF a, b, c, d; A68_ARRAY *a_1, *a_2, *a_3; A68_TUPLE *t_1, *t_2, *t_3; int l_1, l_2, k, m; BYTE_T *b_1, *b_2, *b_3; /* right part */ POP_REF (p, &b); CHECK_INIT (p, INITIALISED (&b), MODE (STRING)); GET_DESCRIPTOR (a_2, t_2, &b); l_2 = ROW_SIZE (t_2); /* left part */ POP_REF (p, &a); CHECK_REF (p, a, MODE (STRING)); GET_DESCRIPTOR (a_1, t_1, &a); l_1 = ROW_SIZE (t_1); /* sum */ c = heap_generator (p, MODE (STRING), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); d = heap_generator (p, MODE (STRING), (l_1 + l_2) * SIZE (MODE (CHAR))); /* Calculate again since garbage collector might have moved data */ GET_DESCRIPTOR (a_1, t_1, &a); GET_DESCRIPTOR (a_2, t_2, &b); GET_DESCRIPTOR (a_3, t_3, &c); DIM (a_3) = 1; MOID (a_3) = MODE (CHAR); ELEM_SIZE (a_3) = SIZE (MODE (CHAR)); SLICE_OFFSET (a_3) = 0; FIELD_OFFSET (a_3) = 0; ARRAY (a_3) = d; LWB (t_3) = 1; UPB (t_3) = l_1 + l_2; SHIFT (t_3) = LWB (t_3); SPAN (t_3) = 1; /* add strings */ b_3 = DEREF (BYTE_T, &ARRAY (a_3)); m = 0; if (ROW_SIZE (t_1) > 0) { b_1 = DEREF (BYTE_T, &ARRAY (a_1)); for (k = LWB (t_1); k <= UPB (t_1); k++) { MOVE ((BYTE_T *) & b_3[m], (BYTE_T *) & b_1[INDEX_1_DIM (a_1, t_1, k)], SIZE (MODE (CHAR))); m += SIZE (MODE (CHAR)); } } if (ROW_SIZE (t_2) > 0) { b_2 = DEREF (BYTE_T, &ARRAY (a_2)); for (k = LWB (t_2); k <= UPB (t_2); k++) { MOVE ((BYTE_T *) & b_3[m], (BYTE_T *) & b_2[INDEX_1_DIM (a_2, t_2, k)], SIZE (MODE (CHAR))); m += SIZE (MODE (CHAR)); } } PUSH_REF (p, c); } /** @brief OP * = (INT, STRING) STRING @param p Node in syntax tree. **/ void genie_times_int_string (NODE_T * p) { A68_INT k; A68_REF a; POP_REF (p, &a); POP_OBJECT (p, &k, A68_INT); PRELUDE_ERROR (VALUE (&k) < 0, p, ERROR_INVALID_ARGUMENT, MODE (INT)); PUSH_REF (p, empty_string (p)); while (VALUE (&k)--) { PUSH_REF (p, a); genie_add_string (p); } } /** @brief OP * = (STRING, INT) STRING @param p Node in syntax tree. **/ void genie_times_string_int (NODE_T * p) { A68_INT k; A68_REF a; POP_OBJECT (p, &k, A68_INT); POP_REF (p, &a); PUSH_PRIMITIVE (p, VALUE (&k), A68_INT); PUSH_REF (p, a); genie_times_int_string (p); } /** @brief OP * = (INT, CHAR) STRING @param p Node in syntax tree. **/ void genie_times_int_char (NODE_T * p) { A68_INT str_size; A68_CHAR a; A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; BYTE_T *base; int k; /* Pop operands */ POP_OBJECT (p, &a, A68_CHAR); POP_OBJECT (p, &str_size, A68_INT); PRELUDE_ERROR (VALUE (&str_size) < 0, p, ERROR_INVALID_ARGUMENT, MODE (INT)); /* Make new_one string */ z = heap_generator (p, MODE (ROW_CHAR), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_CHAR), (int) (VALUE (&str_size)) * SIZE (MODE (CHAR))); DIM (&arr) = 1; MOID (&arr) = MODE (CHAR); ELEM_SIZE (&arr) = SIZE (MODE (CHAR)); SLICE_OFFSET (&arr) = 0; FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = VALUE (&str_size); SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &z); /* Copy */ base = ADDRESS (&row); for (k = 0; k < VALUE (&str_size); k++) { A68_CHAR ch; STATUS (&ch) = INIT_MASK; VALUE (&ch) = VALUE (&a); *(A68_CHAR *) & base[k * SIZE (MODE (CHAR))] = ch; } PUSH_REF (p, z); } /** @brief OP * = (CHAR, INT) STRING @param p Node in syntax tree. **/ void genie_times_char_int (NODE_T * p) { A68_INT k; A68_CHAR a; POP_OBJECT (p, &k, A68_INT); POP_OBJECT (p, &a, A68_CHAR); PUSH_PRIMITIVE (p, VALUE (&k), A68_INT); PUSH_PRIMITIVE (p, VALUE (&a), A68_CHAR); genie_times_int_char (p); } /** @brief OP +:= = (REF STRING, STRING) REF STRING @param p Node in syntax tree. **/ void genie_plusab_string (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_STRING), genie_add_string); } /** @brief OP +=: = (STRING, REF STRING) REF STRING @param p Node in syntax tree. **/ void genie_plusto_string (NODE_T * p) { A68_REF refa, a, b; POP_REF (p, &refa); CHECK_REF (p, refa, MODE (REF_STRING)); a = * DEREF (A68_REF, &refa); CHECK_INIT (p, INITIALISED (&a), MODE (STRING)); POP_REF (p, &b); PUSH_REF (p, b); PUSH_REF (p, a); genie_add_string (p); POP_REF (p, DEREF (A68_REF, &refa)); PUSH_REF (p, refa); } /** @brief OP *:= = (REF STRING, INT) REF STRING @param p Node in syntax tree. **/ void genie_timesab_string (NODE_T * p) { A68_INT k; A68_REF refa, a; int i; /* INT */ POP_OBJECT (p, &k, A68_INT); PRELUDE_ERROR (VALUE (&k) < 0, p, ERROR_INVALID_ARGUMENT, MODE (INT)); /* REF STRING */ POP_REF (p, &refa); CHECK_REF (p, refa, MODE (REF_STRING)); a = * DEREF (A68_REF, &refa); CHECK_INIT (p, INITIALISED (&a), MODE (STRING)); /* Multiplication as repeated addition */ PUSH_REF (p, empty_string (p)); for (i = 1; i <= VALUE (&k); i++) { PUSH_REF (p, a); genie_add_string (p); } /* The stack contains a STRING, promote to REF STRING */ POP_REF (p, DEREF (A68_REF, &refa)); PUSH_REF (p, refa); } /** @brief Difference between two STRINGs in the stack. @param p Node in syntax tree. @return -1 if a < b, 0 if a = b or -1 if a > b **/ static int string_difference (NODE_T * p) { A68_REF row1, row2; A68_ARRAY *a_1, *a_2; A68_TUPLE *t_1, *t_2; BYTE_T *b_1, *b_2; int size, s_1, s_2, k, diff; /* Pop operands */ POP_REF (p, &row2); CHECK_INIT (p, INITIALISED (&row2), MODE (STRING)); GET_DESCRIPTOR (a_2, t_2, &row2); s_2 = ROW_SIZE (t_2); POP_REF (p, &row1); CHECK_INIT (p, INITIALISED (&row1), MODE (STRING)); GET_DESCRIPTOR (a_1, t_1, &row1); s_1 = ROW_SIZE (t_1); /* Get difference */ size = (s_1 > s_2 ? s_1 : s_2); diff = 0; b_1 = (s_1 > 0 ? DEREF (BYTE_T, &ARRAY (a_1)) : NO_BYTE); b_2 = (s_2 > 0 ? DEREF (BYTE_T, &ARRAY (a_2)) : NO_BYTE); for (k = 0; k < size && diff == 0; k++) { int a, b; if (s_1 > 0 && k < s_1) { A68_CHAR *ch = (A68_CHAR *) & b_1[INDEX_1_DIM (a_1, t_1, LWB (t_1) + k)]; a = (int) VALUE (ch); } else { a = 0; } if (s_2 > 0 && k < s_2) { A68_CHAR *ch = (A68_CHAR *) & b_2[INDEX_1_DIM (a_2, t_2, LWB (t_2) + k)]; b = (int) VALUE (ch); } else { b = 0; } diff += (TO_UCHAR (a) - TO_UCHAR (b)); } return (diff); } /* OP (STRING, STRING) BOOL */ #define A68_CMP_STRING(n, OP)\ void n (NODE_T * p) {\ int k = string_difference (p);\ PUSH_PRIMITIVE (p, (BOOL_T) (k OP 0), A68_BOOL);\ } A68_CMP_STRING (genie_eq_string, ==) A68_CMP_STRING (genie_ne_string, !=) A68_CMP_STRING (genie_lt_string, <) A68_CMP_STRING (genie_gt_string, >) A68_CMP_STRING (genie_le_string, <=) A68_CMP_STRING (genie_ge_string, >=) /* RNG functions are in gsl.c.*/ /** @brief PROC first random = (INT) VOID @param p Node in syntax tree. **/ void genie_first_random (NODE_T * p) { A68_INT i; POP_OBJECT (p, &i, A68_INT); init_rng ((unsigned long) VALUE (&i)); } /** @brief PROC next random = REAL @param p Node in syntax tree. **/ void genie_next_random (NODE_T * p) { PUSH_PRIMITIVE (p, rng_53_bit (), A68_REAL); } /** @brief PROC rnd = REAL @param p Node in syntax tree. **/ void genie_next_rnd (NODE_T * p) { PUSH_PRIMITIVE (p, 2 * rng_53_bit () - 1, A68_REAL); } /** @brief PROC next long random = LONG REAL @param p Node in syntax tree. **/ void genie_long_next_random (NODE_T * p) { int digits = DIGITS (MOID (p)); MP_T *z; int k = 2 + digits; STACK_MP (z, p, digits); while (--k > 1) { z[k] = (MP_T) (int) (rng_53_bit () * MP_RADIX); } MP_EXPONENT (z) = (MP_T) (-1); MP_STATUS (z) = (MP_T) INIT_MASK; } /* BYTES operations */ /** @brief OP ELEM = (INT, BYTES) CHAR @param p Node in syntax tree. **/ void genie_elem_bytes (NODE_T * p) { A68_BYTES j; A68_INT i; POP_OBJECT (p, &j, A68_BYTES); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); if (VALUE (&i) > (int) strlen (VALUE (&j))) { genie_null_char (p); } else { PUSH_PRIMITIVE (p, VALUE (&j)[VALUE (&i) - 1], A68_CHAR); } } /** @brief PROC bytes pack = (STRING) BYTES @param p Node in syntax tree. **/ void genie_bytespack (NODE_T * p) { A68_REF z; A68_BYTES b; POP_REF (p, &z); CHECK_REF (p, z, MODE (STRING)); PRELUDE_ERROR (a68_string_size (p, z) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (STRING)); STATUS (&b) = INIT_MASK; ASSERT (a_to_c_string (p, VALUE (&b), z) != NO_TEXT); PUSH_BYTES (p, VALUE (&b)); } /** @brief PROC bytes pack = (STRING) BYTES @param p Node in syntax tree. **/ void genie_add_bytes (NODE_T * p) { A68_BYTES *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BYTES); PRELUDE_ERROR (((int) strlen (VALUE (i)) + (int) strlen (VALUE (j))) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (BYTES)); bufcat (VALUE (i), VALUE (j), BYTES_WIDTH); } /** @brief OP +:= = (REF BYTES, BYTES) REF BYTES @param p Node in syntax tree. **/ void genie_plusab_bytes (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_BYTES), genie_add_bytes); } /** @brief OP +=: = (BYTES, REF BYTES) REF BYTES @param p Node in syntax tree. **/ void genie_plusto_bytes (NODE_T * p) { A68_BYTES i, *address, j; A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MODE (REF_BYTES)); address = DEREF (A68_BYTES, &z); CHECK_INIT (p, INITIALISED (address), MODE (BYTES)); POP_OBJECT (p, &i, A68_BYTES); PRELUDE_ERROR (((int) strlen (VALUE (address)) + (int) strlen (VALUE (&i))) > BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (BYTES)); bufcpy (VALUE (&j), VALUE (&i), BYTES_WIDTH); bufcat (VALUE (&j), VALUE (address), BYTES_WIDTH); bufcpy (VALUE (address), VALUE (&j), BYTES_WIDTH); PUSH_REF (p, z); } /** @brief Difference between BYTE strings. @param p Node in syntax tree. @return Difference between objects. **/ static int compare_bytes (NODE_T * p) { A68_BYTES x, y; POP_OBJECT (p, &y, A68_BYTES); POP_OBJECT (p, &x, A68_BYTES); return (strcmp (VALUE (&x), VALUE (&y))); } /* OP (BYTES, BYTES) BOOL */ #define A68_CMP_BYTES(n, OP)\ void n (NODE_T * p) {\ int k = compare_bytes (p);\ PUSH_PRIMITIVE (p, (BOOL_T) (k OP 0), A68_BOOL);\ } A68_CMP_BYTES (genie_eq_bytes, ==) A68_CMP_BYTES (genie_ne_bytes, !=) A68_CMP_BYTES (genie_lt_bytes, <) A68_CMP_BYTES (genie_gt_bytes, >) A68_CMP_BYTES (genie_le_bytes, <=) A68_CMP_BYTES (genie_ge_bytes, >=) /** @brief OP LENG = (BYTES) LONG BYTES @param p Node in syntax tree. **/ void genie_leng_bytes (NODE_T * p) { A68_BYTES a; POP_OBJECT (p, &a, A68_BYTES); PUSH_LONG_BYTES (p, VALUE (&a)); } /** @brief OP SHORTEN = (LONG BYTES) BYTES @param p Node in syntax tree. **/ void genie_shorten_bytes (NODE_T * p) { A68_LONG_BYTES a; POP_OBJECT (p, &a, A68_LONG_BYTES); PRELUDE_ERROR (strlen (VALUE (&a)) >= BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (BYTES)); PUSH_BYTES (p, VALUE (&a)); } /** @brief OP ELEM = (INT, LONG BYTES) CHAR @param p Node in syntax tree. **/ void genie_elem_long_bytes (NODE_T * p) { A68_LONG_BYTES j; A68_INT i; POP_OBJECT (p, &j, A68_LONG_BYTES); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); if (VALUE (&i) > (int) strlen (VALUE (&j))) { genie_null_char (p); } else { PUSH_PRIMITIVE (p, VALUE (&j)[VALUE (&i) - 1], A68_CHAR); } } /** @brief PROC long bytes pack = (STRING) LONG BYTES @param p Node in syntax tree. **/ void genie_long_bytespack (NODE_T * p) { A68_REF z; A68_LONG_BYTES b; POP_REF (p, &z); CHECK_REF (p, z, MODE (STRING)); PRELUDE_ERROR (a68_string_size (p, z) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (STRING)); STATUS (&b) = INIT_MASK; ASSERT (a_to_c_string (p, VALUE (&b), z) != NO_TEXT); PUSH_LONG_BYTES (p, VALUE (&b)); } /** @brief OP + = (LONG BYTES, LONG BYTES) LONG BYTES @param p Node in syntax tree. **/ void genie_add_long_bytes (NODE_T * p) { A68_LONG_BYTES *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_LONG_BYTES); PRELUDE_ERROR (((int) strlen (VALUE (i)) + (int) strlen (VALUE (j))) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (LONG_BYTES)); bufcat (VALUE (i), VALUE (j), LONG_BYTES_WIDTH); } /** @brief OP +:= = (REF LONG BYTES, LONG BYTES) REF LONG BYTES @param p Node in syntax tree. **/ void genie_plusab_long_bytes (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_LONG_BYTES), genie_add_long_bytes); } /** @brief OP +=: = (LONG BYTES, REF LONG BYTES) REF LONG BYTES @param p Node in syntax tree. **/ void genie_plusto_long_bytes (NODE_T * p) { A68_LONG_BYTES i, *address, j; A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MODE (REF_LONG_BYTES)); address = DEREF (A68_LONG_BYTES, &z); CHECK_INIT (p, INITIALISED (address), MODE (LONG_BYTES)); POP_OBJECT (p, &i, A68_LONG_BYTES); PRELUDE_ERROR (((int) strlen (VALUE (address)) + (int) strlen (VALUE (&i))) > LONG_BYTES_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (LONG_BYTES)); bufcpy (VALUE (&j), VALUE (&i), LONG_BYTES_WIDTH); bufcat (VALUE (&j), VALUE (address), LONG_BYTES_WIDTH); bufcpy (VALUE (address), VALUE (&j), LONG_BYTES_WIDTH); PUSH_REF (p, z); } /** @brief Difference between LONG BYTE strings. @param p Node in syntax tree. @return Difference between objects. **/ static int compare_long_bytes (NODE_T * p) { A68_LONG_BYTES x, y; POP_OBJECT (p, &y, A68_LONG_BYTES); POP_OBJECT (p, &x, A68_LONG_BYTES); return (strcmp (VALUE (&x), VALUE (&y))); } /* OP (LONG BYTES, LONG BYTES) BOOL */ #define A68_CMP_LONG_BYTES(n, OP)\ void n (NODE_T * p) {\ int k = compare_long_bytes (p);\ PUSH_PRIMITIVE (p, (BOOL_T) (k OP 0), A68_BOOL);\ } A68_CMP_LONG_BYTES (genie_eq_long_bytes, ==) A68_CMP_LONG_BYTES (genie_ne_long_bytes, !=) A68_CMP_LONG_BYTES (genie_lt_long_bytes, <) A68_CMP_LONG_BYTES (genie_gt_long_bytes, >) A68_CMP_LONG_BYTES (genie_le_long_bytes, <=) A68_CMP_LONG_BYTES (genie_ge_long_bytes, >=) /* BITS operations */ /* OP NOT = (BITS) BITS */ A68_MONAD (genie_not_bits, A68_BITS, ~) /** @brief OP AND = (BITS, BITS) BITS @param p Node in syntax tree. **/ void genie_and_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); VALUE (i) = VALUE (i) & VALUE (j); } /** @brief OP OR = (BITS, BITS) BITS @param p Node in syntax tree. **/ void genie_or_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); VALUE (i) = VALUE (i) | VALUE (j); } /** @brief OP XOR = (BITS, BITS) BITS @param p Node in syntax tree. **/ void genie_xor_bits (NODE_T * p) { A68_BITS *i, *j; POP_OPERAND_ADDRESSES (p, i, j, A68_BITS); VALUE (i) = VALUE (i) ^ VALUE (j); } /* OP = = (BITS, BITS) BOOL */ #define A68_CMP_BITS(n, OP)\ void n (NODE_T * p) {\ A68_BITS i, j;\ POP_OBJECT (p, &j, A68_BITS);\ POP_OBJECT (p, &i, A68_BITS);\ PUSH_PRIMITIVE (p, (BOOL_T) (VALUE (&i) OP VALUE (&j)), A68_BOOL);\ } A68_CMP_BITS (genie_eq_bits, ==) A68_CMP_BITS (genie_ne_bits, !=) /** @brief OP <= = (BITS, BITS) BOOL @param p Node in syntax tree. **/ void genie_le_bits (NODE_T * p) { A68_BITS i, j; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_BITS); PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&j)), A68_BOOL); } /** @brief OP >= = (BITS, BITS) BOOL @param p Node in syntax tree. **/ void genie_ge_bits (NODE_T * p) { A68_BITS i, j; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_BITS); PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&i) | VALUE (&j)) == VALUE (&i)), A68_BOOL); } /** @brief OP SHL = (BITS, INT) BITS @param p Node in syntax tree. **/ void genie_shl_bits (NODE_T * p) { A68_BITS i; A68_INT j; POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &i, A68_BITS); if (VALUE (&j) >= 0) { PUSH_PRIMITIVE (p, VALUE (&i) << VALUE (&j), A68_BITS); } else { PUSH_PRIMITIVE (p, VALUE (&i) >> -VALUE (&j), A68_BITS); } } /** @brief OP SHR = (BITS, INT) BITS @param p Node in syntax tree. **/ void genie_shr_bits (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = -VALUE (j); genie_shl_bits (p); /* Conform RR */ } /** @brief OP ELEM = (INT, BITS) BOOL @param p Node in syntax tree. **/ void genie_elem_bits (NODE_T * p) { A68_BITS j; A68_INT i; int n; unsigned mask = 0x1; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&j) & mask) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } /** @brief OP SET = (INT, BITS) BITS @param p Node in syntax tree. **/ void genie_set_bits (NODE_T * p) { A68_BITS j; A68_INT i; int n; unsigned mask = 0x1; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } PUSH_PRIMITIVE (p, VALUE (&j) | mask, A68_BITS); } /** @brief OP CLEAR = (INT, BITS) BITS @param p Node in syntax tree. **/ void genie_clear_bits (NODE_T * p) { A68_BITS j; A68_INT i; int n; unsigned mask = 0x1; POP_OBJECT (p, &j, A68_BITS); POP_OBJECT (p, &i, A68_INT); PRELUDE_ERROR (VALUE (&i) < 1 || VALUE (&i) > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); for (n = 0; n < (BITS_WIDTH - VALUE (&i)); n++) { mask = mask << 1; } PUSH_PRIMITIVE (p, VALUE (&j) & ~mask, A68_BITS); } /** @brief OP ABS = (BITS) INT @param p Node in syntax tree. **/ void genie_abs_bits (NODE_T * p) { A68_BITS i; POP_OBJECT (p, &i, A68_BITS); PUSH_PRIMITIVE (p, (int) (VALUE (&i)), A68_INT); } /** @brief OP BIN = (INT) BITS @param p Node in syntax tree. **/ void genie_bin_int (NODE_T * p) { A68_INT i; POP_OBJECT (p, &i, A68_INT); /* RR does not convert negative numbers. */ if (VALUE (&i) < 0) { errno = EDOM; diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MODE (BITS)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, (unsigned) (VALUE (&i)), A68_BITS); } /** @brief OP BIN = (LONG INT) LONG BITS @param p Node in syntax tree. **/ void genie_bin_long_mp (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int size = SIZE (mode); ADDR_T pop_sp = stack_pointer; MP_T *u = (MP_T *) STACK_OFFSET (-size); /* We convert just for the operand check */ (void) stack_mp_bits (p, u, mode); MP_STATUS (u) = (MP_T) INIT_MASK; stack_pointer = pop_sp; } /** @brief OP NOT = (LONG BITS) LONG BITS @param p Node in syntax tree. **/ void genie_not_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int size = SIZE (mode); ADDR_T pop_sp = stack_pointer; int k, words = get_mp_bits_words (mode); MP_T *u = (MP_T *) STACK_OFFSET (-size); unsigned *row = stack_mp_bits (p, u, mode); for (k = 0; k < words; k++) { row[k] = ~row[k]; } (void) pack_mp_bits (p, u, row, mode); stack_pointer = pop_sp; } /** @brief OP SHORTEN = (LONG BITS) BITS @param p Node in syntax tree. **/ void genie_shorten_long_mp_to_bits (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *z = (MP_T *) STACK_OFFSET (-size); DECREMENT_STACK_POINTER (p, size); PUSH_PRIMITIVE (p, mp_to_unsigned (p, z, digits), A68_BITS); } /** @brief Get bit from LONG BITS. @param p Node in syntax tree. @param k Element number. @param z Mp number. @param m Mode associated with z. @return See brief description. **/ unsigned elem_long_bits (NODE_T * p, ADDR_T k, MP_T * z, MOID_T * m) { int n; ADDR_T pop_sp = stack_pointer; unsigned *words = stack_mp_bits (p, z, m), mask = 0x1; k += (MP_BITS_BITS - get_mp_bits_width (m) % MP_BITS_BITS - 1); for (n = 0; n < MP_BITS_BITS - k % MP_BITS_BITS - 1; n++) { mask = mask << 1; } stack_pointer = pop_sp; return ((words[k / MP_BITS_BITS]) & mask); } /** @brief OP ELEM = (INT, LONG BITS) BOOL @param p Node in syntax tree. **/ void genie_elem_long_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned w; int bits = get_mp_bits_width (MODE (LONG_BITS)), size = SIZE (MODE (LONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT)))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = elem_long_bits (p, VALUE (i), z, MODE (LONG_BITS)); DECREMENT_STACK_POINTER (p, size + SIZE (MODE (INT))); PUSH_PRIMITIVE (p, (BOOL_T) (w != 0), A68_BOOL); } /** @brief OP ELEM = (INT, LONG LONG BITS) BOOL @param p Node in syntax tree. **/ void genie_elem_longlong_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned w; int bits = get_mp_bits_width (MODE (LONGLONG_BITS)), size = SIZE (MODE (LONGLONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT)))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = elem_long_bits (p, VALUE (i), z, MODE (LONGLONG_BITS)); DECREMENT_STACK_POINTER (p, size + SIZE (MODE (INT))); PUSH_PRIMITIVE (p, (BOOL_T) (w != 0), A68_BOOL); } /** @brief Set bit in LONG BITS. @param p Node in syntax tree. @param k Bit index. @param z Mp number. @param m Mode associated with z. @param bit Bit to set. **/ static unsigned *set_long_bits (NODE_T * p, int k, MP_T * z, MOID_T * m, unsigned bit) { int n; unsigned *words = stack_mp_bits (p, z, m), mask = 0x1; k += (MP_BITS_BITS - get_mp_bits_width (m) % MP_BITS_BITS - 1); for (n = 0; n < MP_BITS_BITS - k % MP_BITS_BITS - 1; n++) { mask = mask << 1; } if (bit == 0x1) { words[k / MP_BITS_BITS] = (words[k / MP_BITS_BITS]) | mask; } else { words[k / MP_BITS_BITS] = (words[k / MP_BITS_BITS]) & (~mask); } return (words); } /** @brief OP SET = (INT, LONG BITS) VOID @param p Node in syntax tree. **/ void genie_set_long_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned *w; ADDR_T pop_sp = stack_pointer; int bits = get_mp_bits_width (MODE (LONG_BITS)), size = SIZE (MODE (LONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT)))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = set_long_bits (p, VALUE (i), z, MODE (LONG_BITS), 0x1); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (MODE (INT))), w, MODE (LONG_BITS)); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, SIZE (MODE (INT))); } /** @brief OP SET = (INT, LONG LONG BITS) BOOL @param p Node in syntax tree. **/ void genie_set_longlong_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned *w; ADDR_T pop_sp = stack_pointer; int bits = get_mp_bits_width (MODE (LONGLONG_BITS)), size = SIZE (MODE (LONGLONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT)))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = set_long_bits (p, VALUE (i), z, MODE (LONGLONG_BITS), 0x1); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (MODE (INT))), w, MODE (LONGLONG_BITS)); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, SIZE (MODE (INT))); } /** @brief OP CLEAR = (INT, LONG BITS) BOOL @param p Node in syntax tree. **/ void genie_clear_long_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned *w; ADDR_T pop_sp = stack_pointer; int bits = get_mp_bits_width (MODE (LONG_BITS)), size = SIZE (MODE (LONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT)))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = set_long_bits (p, VALUE (i), z, MODE (LONG_BITS), 0x0); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (MODE (INT))), w, MODE (LONG_BITS)); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, SIZE (MODE (INT))); } /** @brief OP CLEAR = (INT, LONG LONG BITS) BOOL @param p Node in syntax tree. **/ void genie_clear_longlong_bits (NODE_T * p) { A68_INT *i; MP_T *z; unsigned *w; ADDR_T pop_sp = stack_pointer; int bits = get_mp_bits_width (MODE (LONGLONG_BITS)), size = SIZE (MODE (LONGLONG_BITS)); z = (MP_T *) STACK_OFFSET (-size); i = (A68_INT *) STACK_OFFSET (-(size + SIZE (MODE (INT)))); PRELUDE_ERROR (VALUE (i) < 1 || VALUE (i) > bits, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); w = set_long_bits (p, VALUE (i), z, MODE (LONGLONG_BITS), 0x0); (void) pack_mp_bits (p, (MP_T *) STACK_ADDRESS (pop_sp - size - SIZE (MODE (INT))), w, MODE (LONGLONG_BITS)); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, SIZE (MODE (INT))); } /** @brief PROC bits pack = ([] BOOL) BITS @param p Node in syntax tree. **/ void genie_bits_pack (NODE_T * p) { A68_REF z; A68_BITS b; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base; int size, k; unsigned bit; POP_REF (p, &z); CHECK_REF (p, z, MODE (ROW_BOOL)); GET_DESCRIPTOR (arr, tup, &z); size = ROW_SIZE (tup); PRELUDE_ERROR (size < 0 || size > BITS_WIDTH, p, ERROR_OUT_OF_BOUNDS, MODE (ROW_BOOL)); VALUE (&b) = 0x0; if (ROW_SIZE (tup) > 0) { base = DEREF (BYTE_T, &ARRAY (arr)); bit = 0x1; for (k = UPB (tup); k >= LWB (tup); k--) { int addr = INDEX_1_DIM (arr, tup, k); A68_BOOL *boo = (A68_BOOL *) & (base[addr]); CHECK_INIT (p, INITIALISED (boo), MODE (BOOL)); if (VALUE (boo)) { VALUE (&b) |= bit; } bit <<= 1; } } STATUS (&b) = INIT_MASK; PUSH_OBJECT (p, b, A68_BITS); } /** @brief PROC long bits pack = ([] BOOL) LONG BITS @param p Node in syntax tree. **/ void genie_long_bits_pack (NODE_T * p) { MOID_T *mode = MOID (p); A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base; int size, k, bits, digits; ADDR_T pop_sp; MP_T *sum, *fact; POP_REF (p, &z); CHECK_REF (p, z, MODE (ROW_BOOL)); GET_DESCRIPTOR (arr, tup, &z); size = ROW_SIZE (tup); bits = get_mp_bits_width (mode); digits = DIGITS (mode); PRELUDE_ERROR (size < 0 || size > bits, p, ERROR_OUT_OF_BOUNDS, MODE (ROW_BOOL)); /* Convert so that LWB goes to MSB, so ELEM gives same order as [] BOOL */ STACK_MP (sum, p, digits); SET_MP_ZERO (sum, digits); pop_sp = stack_pointer; STACK_MP (fact, p, digits); (void) set_mp_short (fact, (MP_T) 1, 0, digits); if (ROW_SIZE (tup) > 0) { base = DEREF (BYTE_T, &ARRAY (arr)); for (k = UPB (tup); k >= LWB (tup); k--) { int addr = INDEX_1_DIM (arr, tup, k); A68_BOOL *boo = (A68_BOOL *) & (base[addr]); CHECK_INIT (p, INITIALISED (boo), MODE (BOOL)); if (VALUE (boo)) { (void) add_mp (p, sum, sum, fact, digits); } (void) mul_mp_digit (p, fact, fact, (MP_T) 2, digits); } } stack_pointer = pop_sp; MP_STATUS (sum) = (MP_T) INIT_MASK; } /** @brief OP SHL = (LONG BITS, INT) LONG BITS @param p Node in syntax tree. **/ void genie_shl_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int i, k, size = SIZE (mode), words = get_mp_bits_words (mode); MP_T *u; unsigned *row_u; ADDR_T pop_sp; A68_INT j; /* Pop number of bits */ POP_OBJECT (p, &j, A68_INT); u = (MP_T *) STACK_OFFSET (-size); pop_sp = stack_pointer; row_u = stack_mp_bits (p, u, mode); if (VALUE (&j) >= 0) { for (i = 0; i < VALUE (&j); i++) { BOOL_T carry = A68_FALSE; for (k = words - 1; k >= 0; k--) { row_u[k] <<= 1; if (carry) { row_u[k] |= 0x1; } carry = (BOOL_T) ((row_u[k] & MP_BITS_RADIX) != 0); row_u[k] &= ~((unsigned) MP_BITS_RADIX); } } } else { for (i = 0; i < -VALUE (&j); i++) { BOOL_T carry = A68_FALSE; for (k = 0; k < words; k++) { if (carry) { row_u[k] |= MP_BITS_RADIX; } carry = (BOOL_T) ((row_u[k] & 0x1) != 0); row_u[k] >>= 1; } } } (void) pack_mp_bits (p, u, row_u, mode); stack_pointer = pop_sp; } /** @brief OP SHR = (LONG BITS, INT) LONG BITS @param p Node in syntax tree. **/ void genie_shr_long_mp (NODE_T * p) { A68_INT *j; POP_OPERAND_ADDRESS (p, j, A68_INT); VALUE (j) = -VALUE (j); (void) genie_shl_long_mp (p); /* Conform RR */ } /** @brief OP <= = (LONG BITS, LONG BITS) BOOL @param p Node in syntax tree. **/ void genie_le_long_bits (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int k, size = SIZE (mode), words = get_mp_bits_words (mode); ADDR_T pop_sp = stack_pointer; BOOL_T result = A68_TRUE; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode); for (k = 0; (k < words) && result; k++) { result = (BOOL_T) (result & ((row_u[k] | row_v[k]) == row_v[k])); } stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); PUSH_PRIMITIVE (p, (BOOL_T) (result ? A68_TRUE : A68_FALSE), A68_BOOL); } /** @brief OP >= = (LONG BITS, LONG BITS) BOOL @param p Node in syntax tree. **/ void genie_ge_long_bits (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int k, size = SIZE (mode), words = get_mp_bits_words (mode); ADDR_T pop_sp = stack_pointer; BOOL_T result = A68_TRUE; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode); for (k = 0; (k < words) && result; k++) { result = (BOOL_T) (result & ((row_u[k] | row_v[k]) == row_u[k])); } stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); PUSH_PRIMITIVE (p, (BOOL_T) (result ? A68_TRUE : A68_FALSE), A68_BOOL); } /** @brief OP AND = (LONG BITS, LONG BITS) LONG BITS @param p Node in syntax tree. **/ void genie_and_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int k, size = SIZE (mode), words = get_mp_bits_words (mode); ADDR_T pop_sp = stack_pointer; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode); for (k = 0; k < words; k++) { row_u[k] &= row_v[k]; } (void) pack_mp_bits (p, u, row_u, mode); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, size); } /** @brief OP OR = (LONG BITS, LONG BITS) LONG BITS @param p Node in syntax tree. **/ void genie_or_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int k, size = SIZE (mode), words = get_mp_bits_words (mode); ADDR_T pop_sp = stack_pointer; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode); for (k = 0; k < words; k++) { row_u[k] |= row_v[k]; } (void) pack_mp_bits (p, u, row_u, mode); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, size); } /** @brief OP XOR = (LONG BITS, LONG BITS) LONG BITS @param p Node in syntax tree. **/ void genie_xor_long_mp (NODE_T * p) { MOID_T *mode = LHS_MODE (p); int k, size = SIZE (mode), words = get_mp_bits_words (mode); ADDR_T pop_sp = stack_pointer; MP_T *u = (MP_T *) STACK_OFFSET (-2 * size), *v = (MP_T *) STACK_OFFSET (-size); unsigned *row_u = stack_mp_bits (p, u, mode), *row_v = stack_mp_bits (p, v, mode); for (k = 0; k < words; k++) { row_u[k] ^= row_v[k]; } (void) pack_mp_bits (p, u, row_u, mode); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, size); } A68_ENV_REAL (genie_cgs_acre, GSL_CONST_CGSM_ACRE) A68_ENV_REAL (genie_cgs_angstrom, GSL_CONST_CGSM_ANGSTROM) A68_ENV_REAL (genie_cgs_astronomical_unit, GSL_CONST_CGSM_ASTRONOMICAL_UNIT) A68_ENV_REAL (genie_cgs_bar, GSL_CONST_CGSM_BAR) A68_ENV_REAL (genie_cgs_barn, GSL_CONST_CGSM_BARN) A68_ENV_REAL (genie_cgs_bohr_magneton, GSL_CONST_CGSM_BOHR_MAGNETON) A68_ENV_REAL (genie_cgs_bohr_radius, GSL_CONST_CGSM_BOHR_RADIUS) A68_ENV_REAL (genie_cgs_boltzmann, GSL_CONST_CGSM_BOLTZMANN) A68_ENV_REAL (genie_cgs_btu, GSL_CONST_CGSM_BTU) A68_ENV_REAL (genie_cgs_calorie, GSL_CONST_CGSM_CALORIE) A68_ENV_REAL (genie_cgs_canadian_gallon, GSL_CONST_CGSM_CANADIAN_GALLON) A68_ENV_REAL (genie_cgs_carat, GSL_CONST_CGSM_CARAT) A68_ENV_REAL (genie_cgs_cup, GSL_CONST_CGSM_CUP) A68_ENV_REAL (genie_cgs_curie, GSL_CONST_CGSM_CURIE) A68_ENV_REAL (genie_cgs_day, GSL_CONST_CGSM_DAY) A68_ENV_REAL (genie_cgs_dyne, GSL_CONST_CGSM_DYNE) A68_ENV_REAL (genie_cgs_electron_charge, GSL_CONST_CGSM_ELECTRON_CHARGE) A68_ENV_REAL (genie_cgs_electron_magnetic_moment, GSL_CONST_CGSM_ELECTRON_MAGNETIC_MOMENT) A68_ENV_REAL (genie_cgs_electron_volt, GSL_CONST_CGSM_ELECTRON_VOLT) A68_ENV_REAL (genie_cgs_erg, GSL_CONST_CGSM_ERG) A68_ENV_REAL (genie_cgs_faraday, GSL_CONST_CGSM_FARADAY) A68_ENV_REAL (genie_cgs_fathom, GSL_CONST_CGSM_FATHOM) A68_ENV_REAL (genie_cgs_fluid_ounce, GSL_CONST_CGSM_FLUID_OUNCE) A68_ENV_REAL (genie_cgs_foot, GSL_CONST_CGSM_FOOT) A68_ENV_REAL (genie_cgs_footcandle, GSL_CONST_CGSM_FOOTCANDLE) A68_ENV_REAL (genie_cgs_footlambert, GSL_CONST_CGSM_FOOTLAMBERT) A68_ENV_REAL (genie_cgs_gauss, GSL_CONST_CGSM_GAUSS) A68_ENV_REAL (genie_cgs_gram_force, GSL_CONST_CGSM_GRAM_FORCE) A68_ENV_REAL (genie_cgs_grav_accel, GSL_CONST_CGSM_GRAV_ACCEL) A68_ENV_REAL (genie_cgs_gravitational_constant, GSL_CONST_CGSM_GRAVITATIONAL_CONSTANT) A68_ENV_REAL (genie_cgs_hectare, GSL_CONST_CGSM_HECTARE) A68_ENV_REAL (genie_cgs_horsepower, GSL_CONST_CGSM_HORSEPOWER) A68_ENV_REAL (genie_cgs_hour, GSL_CONST_CGSM_HOUR) A68_ENV_REAL (genie_cgs_inch, GSL_CONST_CGSM_INCH) A68_ENV_REAL (genie_cgs_inch_of_mercury, GSL_CONST_CGSM_INCH_OF_MERCURY) A68_ENV_REAL (genie_cgs_inch_of_water, GSL_CONST_CGSM_INCH_OF_WATER) A68_ENV_REAL (genie_cgs_joule, GSL_CONST_CGSM_JOULE) A68_ENV_REAL (genie_cgs_kilometers_per_hour, GSL_CONST_CGSM_KILOMETERS_PER_HOUR) A68_ENV_REAL (genie_cgs_kilopound_force, GSL_CONST_CGSM_KILOPOUND_FORCE) A68_ENV_REAL (genie_cgs_knot, GSL_CONST_CGSM_KNOT) A68_ENV_REAL (genie_cgs_lambert, GSL_CONST_CGSM_LAMBERT) A68_ENV_REAL (genie_cgs_light_year, GSL_CONST_CGSM_LIGHT_YEAR) A68_ENV_REAL (genie_cgs_liter, GSL_CONST_CGSM_LITER) A68_ENV_REAL (genie_cgs_lumen, GSL_CONST_CGSM_LUMEN) A68_ENV_REAL (genie_cgs_lux, GSL_CONST_CGSM_LUX) A68_ENV_REAL (genie_cgs_mass_electron, GSL_CONST_CGSM_MASS_ELECTRON) A68_ENV_REAL (genie_cgs_mass_muon, GSL_CONST_CGSM_MASS_MUON) A68_ENV_REAL (genie_cgs_mass_neutron, GSL_CONST_CGSM_MASS_NEUTRON) A68_ENV_REAL (genie_cgs_mass_proton, GSL_CONST_CGSM_MASS_PROTON) A68_ENV_REAL (genie_cgs_meter_of_mercury, GSL_CONST_CGSM_METER_OF_MERCURY) A68_ENV_REAL (genie_cgs_metric_ton, GSL_CONST_CGSM_METRIC_TON) A68_ENV_REAL (genie_cgs_micron, GSL_CONST_CGSM_MICRON) A68_ENV_REAL (genie_cgs_mil, GSL_CONST_CGSM_MIL) A68_ENV_REAL (genie_cgs_mile, GSL_CONST_CGSM_MILE) A68_ENV_REAL (genie_cgs_miles_per_hour, GSL_CONST_CGSM_MILES_PER_HOUR) A68_ENV_REAL (genie_cgs_minute, GSL_CONST_CGSM_MINUTE) A68_ENV_REAL (genie_cgs_molar_gas, GSL_CONST_CGSM_MOLAR_GAS) A68_ENV_REAL (genie_cgs_nautical_mile, GSL_CONST_CGSM_NAUTICAL_MILE) A68_ENV_REAL (genie_cgs_newton, GSL_CONST_CGSM_NEWTON) A68_ENV_REAL (genie_cgs_nuclear_magneton, GSL_CONST_CGSM_NUCLEAR_MAGNETON) A68_ENV_REAL (genie_cgs_ounce_mass, GSL_CONST_CGSM_OUNCE_MASS) A68_ENV_REAL (genie_cgs_parsec, GSL_CONST_CGSM_PARSEC) A68_ENV_REAL (genie_cgs_phot, GSL_CONST_CGSM_PHOT) A68_ENV_REAL (genie_cgs_pint, GSL_CONST_CGSM_PINT) A68_ENV_REAL (genie_cgs_planck_constant_h, 6.6260693e-27) A68_ENV_REAL (genie_cgs_planck_constant_hbar, 6.6260693e-27 / (2 * A68_PI)) A68_ENV_REAL (genie_cgs_point, GSL_CONST_CGSM_POINT) A68_ENV_REAL (genie_cgs_poise, GSL_CONST_CGSM_POISE) A68_ENV_REAL (genie_cgs_pound_force, GSL_CONST_CGSM_POUND_FORCE) A68_ENV_REAL (genie_cgs_pound_mass, GSL_CONST_CGSM_POUND_MASS) A68_ENV_REAL (genie_cgs_poundal, GSL_CONST_CGSM_POUNDAL) A68_ENV_REAL (genie_cgs_proton_magnetic_moment, GSL_CONST_CGSM_PROTON_MAGNETIC_MOMENT) A68_ENV_REAL (genie_cgs_psi, GSL_CONST_CGSM_PSI) A68_ENV_REAL (genie_cgs_quart, GSL_CONST_CGSM_QUART) A68_ENV_REAL (genie_cgs_rad, GSL_CONST_CGSM_RAD) A68_ENV_REAL (genie_cgs_roentgen, GSL_CONST_CGSM_ROENTGEN) A68_ENV_REAL (genie_cgs_rydberg, GSL_CONST_CGSM_RYDBERG) A68_ENV_REAL (genie_cgs_solar_mass, GSL_CONST_CGSM_SOLAR_MASS) A68_ENV_REAL (genie_cgs_speed_of_light, GSL_CONST_CGSM_SPEED_OF_LIGHT) A68_ENV_REAL (genie_cgs_standard_gas_volume, GSL_CONST_CGSM_STANDARD_GAS_VOLUME) A68_ENV_REAL (genie_cgs_std_atmosphere, GSL_CONST_CGSM_STD_ATMOSPHERE) A68_ENV_REAL (genie_cgs_stilb, GSL_CONST_CGSM_STILB) A68_ENV_REAL (genie_cgs_stokes, GSL_CONST_CGSM_STOKES) A68_ENV_REAL (genie_cgs_tablespoon, GSL_CONST_CGSM_TABLESPOON) A68_ENV_REAL (genie_cgs_teaspoon, GSL_CONST_CGSM_TEASPOON) A68_ENV_REAL (genie_cgs_texpoint, GSL_CONST_CGSM_TEXPOINT) A68_ENV_REAL (genie_cgs_therm, GSL_CONST_CGSM_THERM) A68_ENV_REAL (genie_cgs_ton, GSL_CONST_CGSM_TON) A68_ENV_REAL (genie_cgs_torr, GSL_CONST_CGSM_TORR) A68_ENV_REAL (genie_cgs_troy_ounce, GSL_CONST_CGSM_TROY_OUNCE) A68_ENV_REAL (genie_cgs_uk_gallon, GSL_CONST_CGSM_UK_GALLON) A68_ENV_REAL (genie_cgs_uk_ton, GSL_CONST_CGSM_UK_TON) A68_ENV_REAL (genie_cgs_unified_atomic_mass, GSL_CONST_CGSM_UNIFIED_ATOMIC_MASS) A68_ENV_REAL (genie_cgs_us_gallon, GSL_CONST_CGSM_US_GALLON) A68_ENV_REAL (genie_cgs_week, GSL_CONST_CGSM_WEEK) A68_ENV_REAL (genie_cgs_yard, GSL_CONST_CGSM_YARD) A68_ENV_REAL (genie_mks_acre, GSL_CONST_MKS_ACRE) A68_ENV_REAL (genie_mks_angstrom, GSL_CONST_MKS_ANGSTROM) A68_ENV_REAL (genie_mks_astronomical_unit, GSL_CONST_MKS_ASTRONOMICAL_UNIT) A68_ENV_REAL (genie_mks_bar, GSL_CONST_MKS_BAR) A68_ENV_REAL (genie_mks_barn, GSL_CONST_MKS_BARN) A68_ENV_REAL (genie_mks_bohr_magneton, GSL_CONST_MKS_BOHR_MAGNETON) A68_ENV_REAL (genie_mks_bohr_radius, GSL_CONST_MKS_BOHR_RADIUS) A68_ENV_REAL (genie_mks_boltzmann, GSL_CONST_MKS_BOLTZMANN) A68_ENV_REAL (genie_mks_btu, GSL_CONST_MKS_BTU) A68_ENV_REAL (genie_mks_calorie, GSL_CONST_MKS_CALORIE) A68_ENV_REAL (genie_mks_canadian_gallon, GSL_CONST_MKS_CANADIAN_GALLON) A68_ENV_REAL (genie_mks_carat, GSL_CONST_MKS_CARAT) A68_ENV_REAL (genie_mks_cup, GSL_CONST_MKS_CUP) A68_ENV_REAL (genie_mks_curie, GSL_CONST_MKS_CURIE) A68_ENV_REAL (genie_mks_day, GSL_CONST_MKS_DAY) A68_ENV_REAL (genie_mks_dyne, GSL_CONST_MKS_DYNE) A68_ENV_REAL (genie_mks_electron_charge, GSL_CONST_MKS_ELECTRON_CHARGE) A68_ENV_REAL (genie_mks_electron_magnetic_moment, GSL_CONST_MKS_ELECTRON_MAGNETIC_MOMENT) A68_ENV_REAL (genie_mks_electron_volt, GSL_CONST_MKS_ELECTRON_VOLT) A68_ENV_REAL (genie_mks_erg, GSL_CONST_MKS_ERG) A68_ENV_REAL (genie_mks_faraday, GSL_CONST_MKS_FARADAY) A68_ENV_REAL (genie_mks_fathom, GSL_CONST_MKS_FATHOM) A68_ENV_REAL (genie_mks_fluid_ounce, GSL_CONST_MKS_FLUID_OUNCE) A68_ENV_REAL (genie_mks_foot, GSL_CONST_MKS_FOOT) A68_ENV_REAL (genie_mks_footcandle, GSL_CONST_MKS_FOOTCANDLE) A68_ENV_REAL (genie_mks_footlambert, GSL_CONST_MKS_FOOTLAMBERT) A68_ENV_REAL (genie_mks_gauss, GSL_CONST_MKS_GAUSS) A68_ENV_REAL (genie_mks_gram_force, GSL_CONST_MKS_GRAM_FORCE) A68_ENV_REAL (genie_mks_grav_accel, GSL_CONST_MKS_GRAV_ACCEL) A68_ENV_REAL (genie_mks_gravitational_constant, GSL_CONST_MKS_GRAVITATIONAL_CONSTANT) A68_ENV_REAL (genie_mks_hectare, GSL_CONST_MKS_HECTARE) A68_ENV_REAL (genie_mks_horsepower, GSL_CONST_MKS_HORSEPOWER) A68_ENV_REAL (genie_mks_hour, GSL_CONST_MKS_HOUR) A68_ENV_REAL (genie_mks_inch, GSL_CONST_MKS_INCH) A68_ENV_REAL (genie_mks_inch_of_mercury, GSL_CONST_MKS_INCH_OF_MERCURY) A68_ENV_REAL (genie_mks_inch_of_water, GSL_CONST_MKS_INCH_OF_WATER) A68_ENV_REAL (genie_mks_joule, GSL_CONST_MKS_JOULE) A68_ENV_REAL (genie_mks_kilometers_per_hour, GSL_CONST_MKS_KILOMETERS_PER_HOUR) A68_ENV_REAL (genie_mks_kilopound_force, GSL_CONST_MKS_KILOPOUND_FORCE) A68_ENV_REAL (genie_mks_knot, GSL_CONST_MKS_KNOT) A68_ENV_REAL (genie_mks_lambert, GSL_CONST_MKS_LAMBERT) A68_ENV_REAL (genie_mks_light_year, GSL_CONST_MKS_LIGHT_YEAR) A68_ENV_REAL (genie_mks_liter, GSL_CONST_MKS_LITER) A68_ENV_REAL (genie_mks_lumen, GSL_CONST_MKS_LUMEN) A68_ENV_REAL (genie_mks_lux, GSL_CONST_MKS_LUX) A68_ENV_REAL (genie_mks_mass_electron, GSL_CONST_MKS_MASS_ELECTRON) A68_ENV_REAL (genie_mks_mass_muon, GSL_CONST_MKS_MASS_MUON) A68_ENV_REAL (genie_mks_mass_neutron, GSL_CONST_MKS_MASS_NEUTRON) A68_ENV_REAL (genie_mks_mass_proton, GSL_CONST_MKS_MASS_PROTON) A68_ENV_REAL (genie_mks_meter_of_mercury, GSL_CONST_MKS_METER_OF_MERCURY) A68_ENV_REAL (genie_mks_metric_ton, GSL_CONST_MKS_METRIC_TON) A68_ENV_REAL (genie_mks_micron, GSL_CONST_MKS_MICRON) A68_ENV_REAL (genie_mks_mil, GSL_CONST_MKS_MIL) A68_ENV_REAL (genie_mks_mile, GSL_CONST_MKS_MILE) A68_ENV_REAL (genie_mks_miles_per_hour, GSL_CONST_MKS_MILES_PER_HOUR) A68_ENV_REAL (genie_mks_minute, GSL_CONST_MKS_MINUTE) A68_ENV_REAL (genie_mks_molar_gas, GSL_CONST_MKS_MOLAR_GAS) A68_ENV_REAL (genie_mks_nautical_mile, GSL_CONST_MKS_NAUTICAL_MILE) A68_ENV_REAL (genie_mks_newton, GSL_CONST_MKS_NEWTON) A68_ENV_REAL (genie_mks_nuclear_magneton, GSL_CONST_MKS_NUCLEAR_MAGNETON) A68_ENV_REAL (genie_mks_ounce_mass, GSL_CONST_MKS_OUNCE_MASS) A68_ENV_REAL (genie_mks_parsec, GSL_CONST_MKS_PARSEC) A68_ENV_REAL (genie_mks_phot, GSL_CONST_MKS_PHOT) A68_ENV_REAL (genie_mks_pint, GSL_CONST_MKS_PINT) A68_ENV_REAL (genie_mks_planck_constant_h, 6.6260693e-34) A68_ENV_REAL (genie_mks_planck_constant_hbar, 6.6260693e-34 / (2 * A68_PI)) A68_ENV_REAL (genie_mks_point, GSL_CONST_MKS_POINT) A68_ENV_REAL (genie_mks_poise, GSL_CONST_MKS_POISE) A68_ENV_REAL (genie_mks_pound_force, GSL_CONST_MKS_POUND_FORCE) A68_ENV_REAL (genie_mks_pound_mass, GSL_CONST_MKS_POUND_MASS) A68_ENV_REAL (genie_mks_poundal, GSL_CONST_MKS_POUNDAL) A68_ENV_REAL (genie_mks_proton_magnetic_moment, GSL_CONST_MKS_PROTON_MAGNETIC_MOMENT) A68_ENV_REAL (genie_mks_psi, GSL_CONST_MKS_PSI) A68_ENV_REAL (genie_mks_quart, GSL_CONST_MKS_QUART) A68_ENV_REAL (genie_mks_rad, GSL_CONST_MKS_RAD) A68_ENV_REAL (genie_mks_roentgen, GSL_CONST_MKS_ROENTGEN) A68_ENV_REAL (genie_mks_rydberg, GSL_CONST_MKS_RYDBERG) A68_ENV_REAL (genie_mks_solar_mass, GSL_CONST_MKS_SOLAR_MASS) A68_ENV_REAL (genie_mks_speed_of_light, GSL_CONST_MKS_SPEED_OF_LIGHT) A68_ENV_REAL (genie_mks_standard_gas_volume, GSL_CONST_MKS_STANDARD_GAS_VOLUME) A68_ENV_REAL (genie_mks_std_atmosphere, GSL_CONST_MKS_STD_ATMOSPHERE) A68_ENV_REAL (genie_mks_stilb, GSL_CONST_MKS_STILB) A68_ENV_REAL (genie_mks_stokes, GSL_CONST_MKS_STOKES) A68_ENV_REAL (genie_mks_tablespoon, GSL_CONST_MKS_TABLESPOON) A68_ENV_REAL (genie_mks_teaspoon, GSL_CONST_MKS_TEASPOON) A68_ENV_REAL (genie_mks_texpoint, GSL_CONST_MKS_TEXPOINT) A68_ENV_REAL (genie_mks_therm, GSL_CONST_MKS_THERM) A68_ENV_REAL (genie_mks_ton, GSL_CONST_MKS_TON) A68_ENV_REAL (genie_mks_torr, GSL_CONST_MKS_TORR) A68_ENV_REAL (genie_mks_troy_ounce, GSL_CONST_MKS_TROY_OUNCE) A68_ENV_REAL (genie_mks_uk_gallon, GSL_CONST_MKS_UK_GALLON) A68_ENV_REAL (genie_mks_uk_ton, GSL_CONST_MKS_UK_TON) A68_ENV_REAL (genie_mks_unified_atomic_mass, GSL_CONST_MKS_UNIFIED_ATOMIC_MASS) A68_ENV_REAL (genie_mks_us_gallon, GSL_CONST_MKS_US_GALLON) A68_ENV_REAL (genie_mks_vacuum_permeability, GSL_CONST_MKS_VACUUM_PERMEABILITY) A68_ENV_REAL (genie_mks_vacuum_permittivity, GSL_CONST_MKS_VACUUM_PERMITTIVITY) A68_ENV_REAL (genie_mks_week, GSL_CONST_MKS_WEEK) A68_ENV_REAL (genie_mks_yard, GSL_CONST_MKS_YARD) A68_ENV_REAL (genie_num_atto, GSL_CONST_NUM_ATTO) A68_ENV_REAL (genie_num_avogadro, GSL_CONST_NUM_AVOGADRO) A68_ENV_REAL (genie_num_exa, GSL_CONST_NUM_EXA) A68_ENV_REAL (genie_num_femto, GSL_CONST_NUM_FEMTO) A68_ENV_REAL (genie_num_fine_structure, GSL_CONST_NUM_FINE_STRUCTURE) A68_ENV_REAL (genie_num_giga, GSL_CONST_NUM_GIGA) A68_ENV_REAL (genie_num_kilo, GSL_CONST_NUM_KILO) A68_ENV_REAL (genie_num_mega, GSL_CONST_NUM_MEGA) A68_ENV_REAL (genie_num_micro, GSL_CONST_NUM_MICRO) A68_ENV_REAL (genie_num_milli, GSL_CONST_NUM_MILLI) A68_ENV_REAL (genie_num_nano, GSL_CONST_NUM_NANO) A68_ENV_REAL (genie_num_peta, GSL_CONST_NUM_PETA) A68_ENV_REAL (genie_num_pico, GSL_CONST_NUM_PICO) A68_ENV_REAL (genie_num_tera, GSL_CONST_NUM_TERA) A68_ENV_REAL (genie_num_yocto, GSL_CONST_NUM_YOCTO) A68_ENV_REAL (genie_num_yotta, GSL_CONST_NUM_YOTTA) A68_ENV_REAL (genie_num_zepto, GSL_CONST_NUM_ZEPTO) A68_ENV_REAL (genie_num_zetta, GSL_CONST_NUM_ZETTA) /* Macros */ #define C_FUNCTION(p, f)\ A68_REAL *x;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ RESET_ERRNO;\ VALUE (x) = f (VALUE (x));\ MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); #define OWN_FUNCTION(p, f)\ A68_REAL *x;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ RESET_ERRNO;\ VALUE (x) = f (p, VALUE (x));\ MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); #define GSL_FUNCTION(p, f)\ A68_REAL *x;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ RESET_ERRNO;\ VALUE (x) = f (VALUE (x));\ MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); #define GSL_COMPLEX_FUNCTION(f)\ gsl_complex x, z;\ A68_REAL *rex, *imx;\ imx = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));\ rex = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));\ GSL_SET_COMPLEX (&x, VALUE (rex), VALUE (imx));\ (void) gsl_set_error_handler_off ();\ RESET_ERRNO;\ z = f (x);\ MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT);\ VALUE (imx) = GSL_IMAG(z);\ VALUE (rex) = GSL_REAL(z) #define GSL_1_FUNCTION(p, f)\ A68_REAL *x;\ gsl_sf_result y;\ int status;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), &y);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&y) #define GSL_2_FUNCTION(p, f)\ A68_REAL *x, *y;\ gsl_sf_result r;\ int status;\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), VALUE (y), &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) #define GSL_2_INT_FUNCTION(p, f)\ A68_REAL *x, *y;\ gsl_sf_result r;\ int status;\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f ((int) VALUE (x), VALUE (y), &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) #define GSL_3_FUNCTION(p, f)\ A68_REAL *x, *y, *z;\ gsl_sf_result r;\ int status;\ POP_ADDRESS (p, z, A68_REAL);\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), VALUE (y), VALUE (z), &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) #define GSL_1D_FUNCTION(p, f)\ A68_REAL *x;\ gsl_sf_result y;\ int status;\ POP_OPERAND_ADDRESS (p, x, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), GSL_PREC_DOUBLE, &y);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&y) #define GSL_2D_FUNCTION(p, f)\ A68_REAL *x, *y;\ gsl_sf_result r;\ int status;\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), VALUE (y), GSL_PREC_DOUBLE, &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) #define GSL_3D_FUNCTION(p, f)\ A68_REAL *x, *y, *z;\ gsl_sf_result r;\ int status;\ POP_ADDRESS (p, z, A68_REAL);\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), VALUE (y), VALUE (z), GSL_PREC_DOUBLE, &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) #define GSL_4D_FUNCTION(p, f)\ A68_REAL *x, *y, *z, *rho;\ gsl_sf_result r;\ int status;\ POP_ADDRESS (p, rho, A68_REAL);\ POP_ADDRESS (p, z, A68_REAL);\ POP_OPERAND_ADDRESSES (p, x, y, A68_REAL);\ (void) gsl_set_error_handler_off ();\ status = f (VALUE (x), VALUE (y), VALUE (z), VALUE (rho), GSL_PREC_DOUBLE, &r);\ MATH_RTE (p, status != 0, MODE (REAL), (char *) gsl_strerror (status));\ VALUE (x) = VAL (&r) /** @brief The cube root of x. @param x X. @return See brief description. **/ double curt (double x) { #define CBRT2 1.2599210498948731647672; #define CBRT4 1.5874010519681994747517; int expo, sign; double z, x0; static double y[11] = { 7.937005259840997e-01, 8.193212706006459e-01, 8.434326653017493e-01, 8.662391053409029e-01, 8.879040017426008e-01, 9.085602964160699e-01, 9.283177667225558e-01, 9.472682371859097e-01, 9.654893846056298e-01, 9.830475724915586e-01, 1.0 }; if (x == 0.0 || x == 1.0) { return (x); } if (x > 0.0) { sign = 1; } else { sign = -1; x = -x; } x = frexp (x, &expo); /* Cube root in [0.5, 1] by Newton's method */ z = x; x = y[(int) (20 * x - 10)]; x0 = 0; while (ABS (x - x0) > DBL_EPSILON) { x0 = x; x = (z / (x * x) + x + x) / 3; } /* Get exponent */ if (expo >= 0) { int j = expo % 3; if (j == 1) { x *= CBRT2; } else if (j == 2) { x *= CBRT4; } expo /= 3; } else { int j = (-expo) % 3; if (j == 1) { x /= CBRT2; } else if (j == 2) { x /= CBRT4; } expo = -(-expo) / 3; } x = ldexp (x, expo); return (sign >= 0 ? x : -x); } /** @brief Inverse complementary error function. @param y Y. @return See brief description. **/ double inverfc (double y) { if (y < 0.0 || y > 2.0) { errno = EDOM; return (0.0); } else if (y == 0.0) { return (DBL_MAX); } else if (y == 1.0) { return (0.0); } else if (y == 2.0) { return (-DBL_MAX); } else { /* Next is adapted code from a package that contains following statement: Copyright (c) 1996 Takuya Ooura. You may use, copy, modify this code for any purpose and without fee */ double s, t, u, v, x, z; if (y <= 1.0) { z = y; } else { z = 2.0 - y; } v = 0.916461398268964 - log (z); u = sqrt (v); s = (log (u) + 0.488826640273108) / v; t = 1.0 / (u + 0.231729200323405); x = u * (1.0 - s * (s * 0.124610454613712 + 0.5)) - ((((-0.0728846765585675 * t + 0.269999308670029) * t + 0.150689047360223) * t + 0.116065025341614) * t + 0.499999303439796) * t; t = 3.97886080735226 / (x + 3.97886080735226); u = t - 0.5; s = (((((((((0.00112648096188977922 * u + 1.05739299623423047e-4) * u - 0.00351287146129100025) * u - 7.71708358954120939e-4) * u + 0.00685649426074558612) * u + 0.00339721910367775861) * u - 0.011274916933250487) * u - 0.0118598117047771104) * u + 0.0142961988697898018) * u + 0.0346494207789099922) * u + 0.00220995927012179067; s = ((((((((((((s * u - 0.0743424357241784861) * u - 0.105872177941595488) * u + 0.0147297938331485121) * u + 0.316847638520135944) * u + 0.713657635868730364) * u + 1.05375024970847138) * u + 1.21448730779995237) * u + 1.16374581931560831) * u + 0.956464974744799006) * u + 0.686265948274097816) * u + 0.434397492331430115) * u + 0.244044510593190935) * t - z * exp (x * x - 0.120782237635245222); x += s * (x * s + 1.0); return (y <= 1.0 ? x : -x); } } /** @brief Inverse error function. @param y Y. @return See brief description. **/ double inverf (double y) { return (inverfc (1 - y)); } /** @brief PROC sqrt = (REAL) REAL @param p Node in syntax tree. **/ void genie_sqrt_real (NODE_T * p) { C_FUNCTION (p, sqrt); } /** @brief PROC curt = (REAL) REAL @param p Node in syntax tree. **/ void genie_curt_real (NODE_T * p) { C_FUNCTION (p, curt); } /** @brief PROC exp = (REAL) REAL @param p Node in syntax tree. **/ void genie_exp_real (NODE_T * p) { C_FUNCTION (p, a68g_exp); } /** @brief PROC ln = (REAL) REAL @param p Node in syntax tree. **/ void genie_ln_real (NODE_T * p) { C_FUNCTION (p, log); } /** @brief PROC log = (REAL) REAL @param p Node in syntax tree. **/ void genie_log_real (NODE_T * p) { C_FUNCTION (p, log10); } /** @brief PROC sin = (REAL) REAL @param p Node in syntax tree. **/ void genie_sin_real (NODE_T * p) { C_FUNCTION (p, sin); } /** @brief PROC arcsin = (REAL) REAL @param p Node in syntax tree. **/ void genie_arcsin_real (NODE_T * p) { C_FUNCTION (p, asin); } /** @brief PROC cos = (REAL) REAL @param p Node in syntax tree. **/ void genie_cos_real (NODE_T * p) { C_FUNCTION (p, cos); } /** @brief PROC arccos = (REAL) REAL @param p Node in syntax tree. **/ void genie_arccos_real (NODE_T * p) { C_FUNCTION (p, acos); } /** @brief PROC tan = (REAL) REAL @param p Node in syntax tree. **/ void genie_tan_real (NODE_T * p) { C_FUNCTION (p, tan); } /** @brief PROC arctan = (REAL) REAL @param p Node in syntax tree. **/ void genie_arctan_real (NODE_T * p) { C_FUNCTION (p, atan); } /** @brief PROC arctan2 = (REAL) REAL @param p Node in syntax tree. **/ void genie_atan2_real (NODE_T * p) { A68_REAL *x, *y; POP_OPERAND_ADDRESSES (p, x, y, A68_REAL); RESET_ERRNO; PRELUDE_ERROR (VALUE (x) == 0.0 && VALUE (y) == 0.0, p, ERROR_INVALID_ARGUMENT, MODE (LONG_REAL)); VALUE (x) = a68g_atan2 (VALUE (y), VALUE (x)); PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT); } /** @brief PROC sinh = (REAL) REAL @param p Node in syntax tree. **/ void genie_sinh_real (NODE_T * p) { C_FUNCTION (p, sinh); } /** @brief PROC cosh = (REAL) REAL @param p Node in syntax tree. **/ void genie_cosh_real (NODE_T * p) { C_FUNCTION (p, cosh); } /** @brief PROC tanh = (REAL) REAL @param p Node in syntax tree. **/ void genie_tanh_real (NODE_T * p) { C_FUNCTION (p, tanh); } /** @brief PROC arcsinh = (REAL) REAL @param p Node in syntax tree. **/ void genie_arcsinh_real (NODE_T * p) { C_FUNCTION (p, a68g_asinh); } /** @brief PROC arccosh = (REAL) REAL @param p Node in syntax tree. **/ void genie_arccosh_real (NODE_T * p) { C_FUNCTION (p, a68g_acosh); } /** @brief PROC arctanh = (REAL) REAL @param p Node in syntax tree. **/ void genie_arctanh_real (NODE_T * p) { C_FUNCTION (p, a68g_atanh); } /** @brief PROC inverse erf = (REAL) REAL @param p Node in syntax tree. **/ void genie_inverf_real (NODE_T * p) { C_FUNCTION (p, inverf); } /** @brief PROC inverse erfc = (REAL) REAL @param p Node in syntax tree. **/ void genie_inverfc_real (NODE_T * p) { C_FUNCTION (p, inverfc); } /** @brief PROC lj e 12 6 = (REAL, REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_lj_e_12_6 (NODE_T * p) { A68_REAL *e, *s, *r; double u, u2, u6; POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL); u = (VALUE (s) / VALUE (r)); u2 = u * u; u6 = u2 * u2 * u2; VALUE (e) = 4.0 * VALUE (e) * u6 * (u6 - 1.0); } /** @brief PROC lj f 12 6 = (REAL, REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_lj_f_12_6 (NODE_T * p) { A68_REAL *e, *s, *r; double u, u2, u6; POP_3_OPERAND_ADDRESSES (p, e, s, r, A68_REAL); u = (VALUE (s) / VALUE (r)); u2 = u * u; u6 = u2 * u2 * u2; VALUE (e) = 24.0 * VALUE (e) * u * u6 * (1.0 - 2.0 * u6); } #if defined HAVE_GNU_GSL /* "Special" functions - but what is so "special" about them? */ /** @brief PROC erf = (REAL) REAL @param p Node in syntax tree. **/ void genie_erf_real (NODE_T * p) { GSL_1_FUNCTION (p, gsl_sf_erf_e); } /** @brief PROC erfc = (REAL) REAL @param p Node in syntax tree. **/ void genie_erfc_real (NODE_T * p) { GSL_1_FUNCTION (p, gsl_sf_erfc_e); } /** @brief PROC gamma = (REAL) REAL @param p Node in syntax tree. **/ void genie_gamma_real (NODE_T * p) { GSL_1_FUNCTION (p, gsl_sf_gamma_e); } /** @brief PROC gamma incomplete = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_gamma_inc_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_gamma_inc_P_e); } /** @brief PROC lngamma = (REAL) REAL @param p Node in syntax tree. **/ void genie_lngamma_real (NODE_T * p) { GSL_1_FUNCTION (p, gsl_sf_lngamma_e); } /** @brief PROC factorial = (REAL) REAL @param p Node in syntax tree. **/ void genie_factorial_real (NODE_T * p) { /* gsl_sf_fact reduces argument to int, hence we do gamma (x + 1) */ A68_REAL *z = (A68_REAL *) STACK_OFFSET (-SIZE (MODE (REAL))); VALUE (z) += 1.0; { GSL_1_FUNCTION (p, gsl_sf_gamma_e); } } /** @brief PROC beta = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_beta_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_beta_e); } /** @brief PROC beta incomplete = (REAL, REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_beta_inc_real (NODE_T * p) { GSL_3_FUNCTION (p, gsl_sf_beta_inc_e); } /** @brief PROC airy ai = (REAL) REAL @param p Node in syntax tree. **/ void genie_airy_ai_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_airy_Ai_e); } /** @brief PROC airy bi = (REAL) REAL @param p Node in syntax tree. **/ void genie_airy_bi_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_airy_Bi_e); } /** @brief PROC airy ai derivative = (REAL) REAL @param p Node in syntax tree. **/ void genie_airy_ai_deriv_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_airy_Ai_deriv_e); } /** @brief PROC airy bi derivative = (REAL) REAL @param p Node in syntax tree. **/ void genie_airy_bi_deriv_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_airy_Bi_deriv_e); } /** @brief PROC bessel jn = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_jn_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Jn_e); } /** @brief PROC bessel yn = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_yn_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Yn_e); } /** @brief PROC bessel in = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_in_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_In_e); } /** @brief PROC bessel exp in = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_exp_in_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_In_scaled_e); } /** @brief PROC bessel kn = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_kn_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Kn_e); } /** @brief PROC bessel exp kn = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_exp_kn_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_Kn_scaled_e); } /** @brief PROC bessel jl = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_jl_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_jl_e); } /** @brief PROC bessel yl = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_yl_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_yl_e); } /** @brief PROC bessel exp il = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_exp_il_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_il_scaled_e); } /** @brief PROC bessel exp kl = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_exp_kl_real (NODE_T * p) { GSL_2_INT_FUNCTION (p, gsl_sf_bessel_kl_scaled_e); } /** @brief PROC bessel jnu = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_jnu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Jnu_e); } /** @brief PROC bessel ynu = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_ynu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Ynu_e); } /** @brief PROC bessel inu = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_inu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Inu_e); } /** @brief PROC bessel exp inu = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_exp_inu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Inu_scaled_e); } /** @brief PROC bessel knu = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_knu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Knu_e); } /** @brief PROC bessel exp knu = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_bessel_exp_knu_real (NODE_T * p) { GSL_2_FUNCTION (p, gsl_sf_bessel_Knu_scaled_e); } /** @brief PROC elliptic integral k = (REAL) REAL @param p Node in syntax tree. **/ void genie_elliptic_integral_k_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_ellint_Kcomp_e); } /** @brief PROC elliptic integral e = (REAL) REAL @param p Node in syntax tree. **/ void genie_elliptic_integral_e_real (NODE_T * p) { GSL_1D_FUNCTION (p, gsl_sf_ellint_Ecomp_e); } /** @brief PROC elliptic integral rf = (REAL, REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_elliptic_integral_rf_real (NODE_T * p) { GSL_3D_FUNCTION (p, gsl_sf_ellint_RF_e); } /** @brief PROC elliptic integral rd = (REAL, REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_elliptic_integral_rd_real (NODE_T * p) { GSL_3D_FUNCTION (p, gsl_sf_ellint_RD_e); } /** @brief PROC elliptic integral rj = (REAL, REAL, REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_elliptic_integral_rj_real (NODE_T * p) { GSL_4D_FUNCTION (p, gsl_sf_ellint_RJ_e); } /** @brief PROC elliptic integral rc = (REAL, REAL) REAL @param p Node in syntax tree. **/ void genie_elliptic_integral_rc_real (NODE_T * p) { GSL_2D_FUNCTION (p, gsl_sf_ellint_RC_e); } #endif /* Next part is a "stand-alone" version of GNU Scientific Library (GSL) random number generator "taus113", based on GSL file "rng/taus113.c" that has the notice: Copyright (C) 2002 Atakan Gurkan Based on the file taus.c which has the notice Copyright (C) 1996, 1997, 1998, 1999, 2000 James Theiler, Brian Gough. This is a maximally equidistributed combined, collision free Tausworthe generator, with a period ~2^113 (~10^34). The sequence is x_n = (z1_n ^ z2_n ^ z3_n ^ z4_n) b = (((z1_n << 6) ^ z1_n) >> 13) z1_{n+1} = (((z1_n & 4294967294) << 18) ^ b) b = (((z2_n << 2) ^ z2_n) >> 27) z2_{n+1} = (((z2_n & 4294967288) << 2) ^ b) b = (((z3_n << 13) ^ z3_n) >> 21) z3_{n+1} = (((z3_n & 4294967280) << 7) ^ b) b = (((z4_n << 3) ^ z4_n) >> 12) z4_{n+1} = (((z4_n & 4294967168) << 13) ^ b) computed modulo 2^32. In the formulas above '^' means exclusive-or (C-notation), not exponentiation. The algorithm is for 32-bit integers, hence a bitmask is used to clear all but least significant 32 bits, after left shifts, to make the code work on architectures where integers are 64-bit. The generator is initialized with zi = (69069 * z{i+1}) MOD 2^32 where z0 is the seed provided During initialization a check is done to make sure that the initial seeds have a required number of their most significant bits set. After this, the state is passed through the RNG 10 times to ensure the state satisfies a recurrence relation. References: P. L'Ecuyer, "Tables of Maximally-Equidistributed Combined LFSR Generators", Mathematics of Computation, 68, 225 (1999), 261--269. http://www.iro.umontreal.ca/~lecuyer/myftp/papers/tausme2.ps P. L'Ecuyer, "Maximally Equidistributed Combined Tausworthe Generators", Mathematics of Computation, 65, 213 (1996), 203--213. http://www.iro.umontreal.ca/~lecuyer/myftp/papers/tausme.ps the online version of the latter contains corrections to the print version. */ #define LCG(n) ((69069UL * n) & 0xffffffffUL) #define TAUSWORTHE_MASK 0xffffffffUL #define Z1(p) ((p)->z1) #define Z2(p) ((p)->z2) #define Z3(p) ((p)->z3) #define Z4(p) ((p)->z4) typedef struct { unsigned long int z1, z2, z3, z4; } taus113_state_t; static taus113_state_t rng_state; static unsigned long int taus113_get (taus113_state_t * state); static void taus113_set (taus113_state_t * state, unsigned long int s); /** @brief Taus113_get. @param state State. @return See brief description. **/ static unsigned long taus113_get (taus113_state_t * state) { unsigned long b1, b2, b3, b4; b1 = ((((Z1 (state) << 6UL) & TAUSWORTHE_MASK) ^ Z1 (state)) >> 13UL); Z1 (state) = ((((Z1 (state) & 4294967294UL) << 18UL) & TAUSWORTHE_MASK) ^ b1); b2 = ((((Z2 (state) << 2UL) & TAUSWORTHE_MASK) ^ Z2 (state)) >> 27UL); Z2 (state) = ((((Z2 (state) & 4294967288UL) << 2UL) & TAUSWORTHE_MASK) ^ b2); b3 = ((((Z3 (state) << 13UL) & TAUSWORTHE_MASK) ^ Z3 (state)) >> 21UL); Z3 (state) = ((((Z3 (state) & 4294967280UL) << 7UL) & TAUSWORTHE_MASK) ^ b3); b4 = ((((Z4 (state) << 3UL) & TAUSWORTHE_MASK) ^ Z4 (state)) >> 12UL); Z4 (state) = ((((Z4 (state) & 4294967168UL) << 13UL) & TAUSWORTHE_MASK) ^ b4); return (Z1 (state) ^ Z2 (state) ^ Z3 (state) ^ Z4 (state)); } /** @brief Taus113_set. @param state State. @param s S. **/ static void taus113_set (taus113_state_t * state, unsigned long int s) { if (!s) { /* default seed is 1 */ s = 1UL; } Z1 (state) = LCG (s); if (Z1 (state) < 2UL) { Z1 (state) += 2UL; } Z2 (state) = LCG (Z1 (state)); if (Z2 (state) < 8UL) { Z2 (state) += 8UL; } Z3 (state) = LCG (Z2 (state)); if (Z3 (state) < 16UL) { Z3 (state) += 16UL; } Z4 (state) = LCG (Z3 (state)); if (Z4 (state) < 128UL) { Z4 (state) += 128UL; } /* Calling RNG ten times to satify recurrence condition */ (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); (void) taus113_get (state); } /** @brief Initialise rng. @param u Initialiser. **/ void init_rng (unsigned long u) { taus113_set (&rng_state, u); } /** @brief Rng 53 bit. @return See brief description. **/ double rng_53_bit (void) { double a = (double) (taus113_get (&rng_state) >> 5); double b = (double) (taus113_get (&rng_state) >> 6); return (a * /* 2^26 */ 67108864.0 + b) / /* 2^53 */ 9007199254740992.0; } /* Rules for analytic calculations using GNU Emacs Calc: (used to find the values for the test program) [ LCG(n) := n * 69069 mod (2^32) ] [ b1(x) := rsh(xor(lsh(x, 6), x), 13), q1(x) := xor(lsh(and(x, 4294967294), 18), b1(x)), b2(x) := rsh(xor(lsh(x, 2), x), 27), q2(x) := xor(lsh(and(x, 4294967288), 2), b2(x)), b3(x) := rsh(xor(lsh(x, 13), x), 21), q3(x) := xor(lsh(and(x, 4294967280), 7), b3(x)), b4(x) := rsh(xor(lsh(x, 3), x), 12), q4(x) := xor(lsh(and(x, 4294967168), 13), b4(x)) ] [ S([z1,z2,z3,z4]) := [q1(z1), q2(z2), q3(z3), q4(z4)] ] */ /* This file also contains Algol68G's standard environ for complex numbers. Some of the LONG operations are generic for LONG and LONG LONG. Some routines are based on * GNU Scientific Library * Abramowitz and Stegun. */ #if defined HAVE_GNU_GSL #define GSL_COMPLEX_FUNCTION(f)\ gsl_complex x, z;\ A68_REAL *rex, *imx;\ imx = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL))));\ rex = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL))));\ GSL_SET_COMPLEX (&x, VALUE (rex), VALUE (imx));\ (void) gsl_set_error_handler_off ();\ RESET_ERRNO;\ z = f (x);\ MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT);\ VALUE (imx) = GSL_IMAG(z);\ VALUE (rex) = GSL_REAL(z) #endif /** @brief OP +* = (REAL, REAL) COMPLEX @param p Node in syntax tree. **/ void genie_icomplex (NODE_T * p) { (void) p; } /** @brief OP +* = (INT, INT) COMPLEX @param p Node in syntax tree. **/ void genie_iint_complex (NODE_T * p) { A68_INT re, im; POP_OBJECT (p, &im, A68_INT); POP_OBJECT (p, &re, A68_INT); PUSH_PRIMITIVE (p, (double) VALUE (&re), A68_REAL); PUSH_PRIMITIVE (p, (double) VALUE (&im), A68_REAL); } /** @brief OP RE = (COMPLEX) REAL @param p Node in syntax tree. **/ void genie_re_complex (NODE_T * p) { DECREMENT_STACK_POINTER (p, SIZE (MODE (REAL))); } /** @brief OP IM = (COMPLEX) REAL @param p Node in syntax tree. **/ void genie_im_complex (NODE_T * p) { A68_REAL im; POP_OBJECT (p, &im, A68_REAL); *(A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))) = im; } /** @brief OP - = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_minus_complex (NODE_T * p) { A68_REAL *re_x, *im_x; im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); VALUE (im_x) = -VALUE (im_x); VALUE (re_x) = -VALUE (re_x); (void) p; } /** @brief ABS = (COMPLEX) REAL @param p Node in syntax tree. **/ void genie_abs_complex (NODE_T * p) { A68_REAL re_x, im_x; POP_COMPLEX (p, &re_x, &im_x); PUSH_PRIMITIVE (p, a68g_hypot (VALUE (&re_x), VALUE (&im_x)), A68_REAL); } /** @brief OP ARG = (COMPLEX) REAL @param p Node in syntax tree. **/ void genie_arg_complex (NODE_T * p) { A68_REAL re_x, im_x; POP_COMPLEX (p, &re_x, &im_x); PRELUDE_ERROR (VALUE (&re_x) == 0.0 && VALUE (&im_x) == 0.0, p, ERROR_INVALID_ARGUMENT, MODE (COMPLEX)); PUSH_PRIMITIVE (p, atan2 (VALUE (&im_x), VALUE (&re_x)), A68_REAL); } /** @brief OP CONJ = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_conj_complex (NODE_T * p) { A68_REAL *im; POP_OPERAND_ADDRESS (p, im, A68_REAL); VALUE (im) = -VALUE (im); } /** @brief OP + = (COMPLEX, COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_add_complex (NODE_T * p) { A68_REAL *re_x, *im_x, re_y, im_y; POP_COMPLEX (p, &re_y, &im_y); im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); VALUE (im_x) += VALUE (&im_y); VALUE (re_x) += VALUE (&re_y); CHECK_COMPLEX_REPRESENTATION (p, VALUE (re_x), VALUE (im_x)); } /** @brief OP - = (COMPLEX, COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_sub_complex (NODE_T * p) { A68_REAL *re_x, *im_x, re_y, im_y; POP_COMPLEX (p, &re_y, &im_y); im_x = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); re_x = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); VALUE (im_x) -= VALUE (&im_y); VALUE (re_x) -= VALUE (&re_y); CHECK_COMPLEX_REPRESENTATION (p, VALUE (re_x), VALUE (im_x)); } /** @brief OP * = (COMPLEX, COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_mul_complex (NODE_T * p) { A68_REAL re_x, im_x, re_y, im_y; double re, im; POP_COMPLEX (p, &re_y, &im_y); POP_COMPLEX (p, &re_x, &im_x); re = VALUE (&re_x) * VALUE (&re_y) - VALUE (&im_x) * VALUE (&im_y); im = VALUE (&im_x) * VALUE (&re_y) + VALUE (&re_x) * VALUE (&im_y); CHECK_COMPLEX_REPRESENTATION (p, re, im); PUSH_COMPLEX (p, re, im); } /** @brief OP / = (COMPLEX, COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_div_complex (NODE_T * p) { A68_REAL re_x, im_x, re_y, im_y; double re = 0.0, im = 0.0; POP_COMPLEX (p, &re_y, &im_y); POP_COMPLEX (p, &re_x, &im_x); #if ! defined HAVE_IEEE_754 PRELUDE_ERROR (VALUE (&re_y) == 0.0 && VALUE (&im_y) == 0.0, p, ERROR_DIVISION_BY_ZERO, MODE (COMPLEX)); #endif if (ABS (VALUE (&re_y)) >= ABS (VALUE (&im_y))) { double r = VALUE (&im_y) / VALUE (&re_y), den = VALUE (&re_y) + r * VALUE (&im_y); re = (VALUE (&re_x) + r * VALUE (&im_x)) / den; im = (VALUE (&im_x) - r * VALUE (&re_x)) / den; } else { double r = VALUE (&re_y) / VALUE (&im_y), den = VALUE (&im_y) + r * VALUE (&re_y); re = (VALUE (&re_x) * r + VALUE (&im_x)) / den; im = (VALUE (&im_x) * r - VALUE (&re_x)) / den; } CHECK_COMPLEX_REPRESENTATION (p, re, im); PUSH_COMPLEX (p, re, im); } /** @brief OP ** = (COMPLEX, INT) COMPLEX @param p Node in syntax tree. **/ void genie_pow_complex_int (NODE_T * p) { A68_REAL re_x, im_x; double re_y, im_y, re_z, im_z, rea; A68_INT j; int expo; BOOL_T negative; POP_OBJECT (p, &j, A68_INT); POP_COMPLEX (p, &re_x, &im_x); re_z = 1.0; im_z = 0.0; re_y = VALUE (&re_x); im_y = VALUE (&im_x); expo = 1; negative = (BOOL_T) (VALUE (&j) < 0); if (negative) { VALUE (&j) = -VALUE (&j); } while ((unsigned) expo <= (unsigned) (VALUE (&j))) { if (expo & VALUE (&j)) { rea = re_z * re_y - im_z * im_y; im_z = re_z * im_y + im_z * re_y; re_z = rea; } rea = re_y * re_y - im_y * im_y; im_y = im_y * re_y + re_y * im_y; re_y = rea; expo <<= 1; } CHECK_COMPLEX_REPRESENTATION (p, re_z, im_z); if (negative) { PUSH_PRIMITIVE (p, 1.0, A68_REAL); PUSH_PRIMITIVE (p, 0.0, A68_REAL); PUSH_PRIMITIVE (p, re_z, A68_REAL); PUSH_PRIMITIVE (p, im_z, A68_REAL); genie_div_complex (p); } else { PUSH_PRIMITIVE (p, re_z, A68_REAL); PUSH_PRIMITIVE (p, im_z, A68_REAL); } } /** @brief OP = = (COMPLEX, COMPLEX) BOOL @param p Node in syntax tree. **/ void genie_eq_complex (NODE_T * p) { A68_REAL re_x, im_x, re_y, im_y; POP_COMPLEX (p, &re_y, &im_y); POP_COMPLEX (p, &re_x, &im_x); PUSH_PRIMITIVE (p, (BOOL_T) ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL); } /** @brief OP /= = (COMPLEX, COMPLEX) BOOL @param p Node in syntax tree. **/ void genie_ne_complex (NODE_T * p) { A68_REAL re_x, im_x, re_y, im_y; POP_COMPLEX (p, &re_y, &im_y); POP_COMPLEX (p, &re_x, &im_x); PUSH_PRIMITIVE (p, (BOOL_T) ! ((VALUE (&re_x) == VALUE (&re_y)) && (VALUE (&im_x) == VALUE (&im_y))), A68_BOOL); } /** @brief OP +:= = (REF COMPLEX, COMPLEX) REF COMPLEX @param p Node in syntax tree. **/ void genie_plusab_complex (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_add_complex); } /** @brief OP -:= = (REF COMPLEX, COMPLEX) REF COMPLEX @param p Node in syntax tree. **/ void genie_minusab_complex (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_sub_complex); } /** @brief OP *:= = (REF COMPLEX, COMPLEX) REF COMPLEX @param p Node in syntax tree. **/ void genie_timesab_complex (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_mul_complex); } /** @brief OP /:= = (REF COMPLEX, COMPLEX) REF COMPLEX @param p Node in syntax tree. **/ void genie_divab_complex (NODE_T * p) { genie_f_and_becomes (p, MODE (REF_COMPLEX), genie_div_complex); } /** @brief OP LENG = (COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_lengthen_complex_to_long_complex (NODE_T * p) { int digits = DIGITS (MODE (LONG_REAL)); MP_T *z; A68_REAL a, b; POP_OBJECT (p, &b, A68_REAL); POP_OBJECT (p, &a, A68_REAL); STACK_MP (z, p, digits); (void) real_to_mp (p, z, VALUE (&a), digits); MP_STATUS (z) = (MP_T) INIT_MASK; STACK_MP (z, p, digits); (void) real_to_mp (p, z, VALUE (&b), digits); MP_STATUS (z) = (MP_T) INIT_MASK; } /** @brief OP SHORTEN = (LONG COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_shorten_long_complex_to_complex (NODE_T * p) { int digits = DIGITS (MODE (LONG_REAL)), size = SIZE (MODE (LONG_REAL)); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); DECREMENT_STACK_POINTER (p, 2 * size); PUSH_PRIMITIVE (p, mp_to_real (p, a, digits), A68_REAL); PUSH_PRIMITIVE (p, mp_to_real (p, b, digits), A68_REAL); } /** @brief OP LENG = (LONG COMPLEX) LONG LONG COMPLEX @param p Node in syntax tree. **/ void genie_lengthen_long_complex_to_longlong_complex (NODE_T * p) { int digits = DIGITS (MODE (LONG_REAL)), size = SIZE (MODE (LONG_REAL)); int digs_long = DIGITS (MODE (LONGLONG_REAL)), size_long = SIZE (MODE (LONGLONG_REAL)); ADDR_T pop_sp = stack_pointer; MP_T *a, *b, *c, *d; b = (MP_T *) STACK_OFFSET (-size); a = (MP_T *) STACK_OFFSET (-2 * size); STACK_MP (c, p, digs_long); STACK_MP (d, p, digs_long); (void) lengthen_mp (p, c, digs_long, a, digits); (void) lengthen_mp (p, d, digs_long, b, digits); MOVE_MP (a, c, digs_long); MOVE_MP (&a[2 + digs_long], d, digs_long); stack_pointer = pop_sp; MP_STATUS (a) = (MP_T) INIT_MASK; (&a[2 + digs_long])[0] = (MP_T) INIT_MASK; INCREMENT_STACK_POINTER (p, 2 * (size_long - size)); } /** @brief OP SHORTEN = (LONG LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_shorten_longlong_complex_to_long_complex (NODE_T * p) { int digits = DIGITS (MODE (LONG_REAL)), size = SIZE (MODE (LONG_REAL)); int digs_long = DIGITS (MODE (LONGLONG_REAL)), size_long = SIZE (MODE (LONGLONG_REAL)); ADDR_T pop_sp = stack_pointer; MP_T *a, *b; b = (MP_T *) STACK_OFFSET (-size_long); a = (MP_T *) STACK_OFFSET (-2 * size_long); (void) shorten_mp (p, a, digits, a, digs_long); (void) shorten_mp (p, &a[2 + digits], digits, b, digs_long); stack_pointer = pop_sp; MP_STATUS (a) = (MP_T) INIT_MASK; (&a[2 + digits])[0] = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, 2 * (size_long - size)); } /** @brief OP RE = (LONG COMPLEX) LONG REAL @param p Node in syntax tree. **/ void genie_re_long_complex (NODE_T * p) { int size = SIZE (SUB_MOID (p)); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_STATUS (a) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, (int) size_long_mp ()); } /** @brief OP IM = (LONG COMPLEX) LONG REAL @param p Node in syntax tree. **/ void genie_im_long_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digits = DIGITS (mode), size = SIZE (mode); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MOVE_MP (a, b, digits); MP_STATUS (a) = (MP_T) INIT_MASK; DECREMENT_STACK_POINTER (p, size); } /** @brief OP - = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_minus_long_complex (NODE_T * p) { int size = SIZEC (SUB_MOID (p)); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_DIGIT (a, 1) = -MP_DIGIT (a, 1); MP_DIGIT (b, 1) = -MP_DIGIT (b, 1); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; } /** @brief OP CONJ = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_conj_long_complex (NODE_T * p) { int size = SIZEC (SUB_MOID (p)); MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_DIGIT (b, 1) = -MP_DIGIT (b, 1); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; } /** @brief OP ABS = (LONG COMPLEX) LONG REAL @param p Node in syntax tree. **/ void genie_abs_long_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digits = DIGITS (mode), size = SIZE (mode); ADDR_T pop_sp = stack_pointer; MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_T *z; STACK_MP (z, p, digits); (void) hypot_mp (p, z, a, b, digits); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, size); MOVE_MP (a, z, digits); MP_STATUS (a) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /** @brief OP ARG = (LONG COMPLEX) LONG REAL @param p Node in syntax tree. **/ void genie_arg_long_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digits = DIGITS (mode), size = SIZE (mode); ADDR_T pop_sp = stack_pointer; MP_T *b = (MP_T *) STACK_OFFSET (-size); MP_T *a = (MP_T *) STACK_OFFSET (-2 * size); MP_T *z; STACK_MP (z, p, digits); (void) atan2_mp (p, z, a, b, digits); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, size); MOVE_MP (a, z, digits); MP_STATUS (a) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /** @brief OP + = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_add_long_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *d = (MP_T *) STACK_OFFSET (-size); MP_T *c = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); (void) add_mp (p, b, b, d, digits); (void) add_mp (p, a, a, c, digits); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } /** @brief OP - = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_sub_long_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *d = (MP_T *) STACK_OFFSET (-size); MP_T *c = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); (void) sub_mp (p, b, b, d, digits); (void) sub_mp (p, a, a, c, digits); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } /** @brief OP * = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_mul_long_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *d = (MP_T *) STACK_OFFSET (-size); MP_T *c = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); (void) cmul_mp (p, a, b, c, d, digits); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } /** @brief OP / = (LONG COMPLEX, LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_div_long_complex (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *d = (MP_T *) STACK_OFFSET (-size); MP_T *c = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); PRELUDE_ERROR (cdiv_mp (p, a, b, c, d, digits) == NO_MP, p, ERROR_DIVISION_BY_ZERO, mode); MP_STATUS (a) = (MP_T) INIT_MASK; MP_STATUS (b) = (MP_T) INIT_MASK; stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 2 * size); } /** @brief OP ** = (LONG COMPLEX, INT) LONG COMPLEX @param p Node in syntax tree. **/ void genie_pow_long_complex_int (NODE_T * p) { MOID_T *mode = SUB_MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp; MP_T *re_x, *im_x, *re_y, *im_y, *re_z, *im_z, *rea, *acc; A68_INT j; int expo; BOOL_T negative; POP_OBJECT (p, &j, A68_INT); pop_sp = stack_pointer; im_x = (MP_T *) STACK_OFFSET (-size); re_x = (MP_T *) STACK_OFFSET (-2 * size); STACK_MP (re_z, p, digits); (void) set_mp_short (re_z, (MP_T) 1, 0, digits); STACK_MP (im_z, p, digits); SET_MP_ZERO (im_z, digits); STACK_MP (re_y, p, digits); STACK_MP (im_y, p, digits); MOVE_MP (re_y, re_x, digits); MOVE_MP (im_y, im_x, digits); STACK_MP (rea, p, digits); STACK_MP (acc, p, digits); expo = 1; negative = (BOOL_T) (VALUE (&j) < 0); if (negative) { VALUE (&j) = -VALUE (&j); } while ((unsigned) expo <= (unsigned) (VALUE (&j))) { if (expo & VALUE (&j)) { (void) mul_mp (p, acc, im_z, im_y, digits); (void) mul_mp (p, rea, re_z, re_y, digits); (void) sub_mp (p, rea, rea, acc, digits); (void) mul_mp (p, acc, im_z, re_y, digits); (void) mul_mp (p, im_z, re_z, im_y, digits); (void) add_mp (p, im_z, im_z, acc, digits); MOVE_MP (re_z, rea, digits); } (void) mul_mp (p, acc, im_y, im_y, digits); (void) mul_mp (p, rea, re_y, re_y, digits); (void) sub_mp (p, rea, rea, acc, digits); (void) mul_mp (p, acc, im_y, re_y, digits); (void) mul_mp (p, im_y, re_y, im_y, digits); (void) add_mp (p, im_y, im_y, acc, digits); MOVE_MP (re_y, rea, digits); expo <<= 1; } stack_pointer = pop_sp; if (negative) { (void) set_mp_short (re_x, (MP_T) 1, 0, digits); SET_MP_ZERO (im_x, digits); INCREMENT_STACK_POINTER (p, 2 * size); genie_div_long_complex (p); } else { MOVE_MP (re_x, re_z, digits); MOVE_MP (im_x, im_z, digits); } MP_STATUS (re_x) = (MP_T) INIT_MASK; MP_STATUS (im_x) = (MP_T) INIT_MASK; } /** @brief OP = = (LONG COMPLEX, LONG COMPLEX) BOOL @param p Node in syntax tree. **/ void genie_eq_long_complex (NODE_T * p) { int digits = DIGITSC (LHS_MODE (p)), size = SIZEC (LHS_MODE (p)); ADDR_T pop_sp = stack_pointer; MP_T *d = (MP_T *) STACK_OFFSET (-size); MP_T *c = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); (void) sub_mp (p, b, b, d, digits); (void) sub_mp (p, a, a, c, digits); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 4 * size); PUSH_PRIMITIVE (p, (BOOL_T) (MP_DIGIT (a, 1) == 0 && MP_DIGIT (b, 1) == 0), A68_BOOL); } /** @brief OP /= = (LONG COMPLEX, LONG COMPLEX) BOOL @param p Node in syntax tree. **/ void genie_ne_long_complex (NODE_T * p) { int digits = DIGITSC (LHS_MODE (p)), size = SIZEC (LHS_MODE (p)); ADDR_T pop_sp = stack_pointer; MP_T *d = (MP_T *) STACK_OFFSET (-size); MP_T *c = (MP_T *) STACK_OFFSET (-2 * size); MP_T *b = (MP_T *) STACK_OFFSET (-3 * size); MP_T *a = (MP_T *) STACK_OFFSET (-4 * size); (void) sub_mp (p, b, b, d, digits); (void) sub_mp (p, a, a, c, digits); stack_pointer = pop_sp; DECREMENT_STACK_POINTER (p, 4 * size); PUSH_PRIMITIVE (p, (BOOL_T) (MP_DIGIT (a, 1) != 0 || MP_DIGIT (b, 1) != 0), A68_BOOL); } /** @brief OP +:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX @param p Node in syntax tree. **/ void genie_plusab_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_add_long_complex); } /** @brief OP -:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX @param p Node in syntax tree. **/ void genie_minusab_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_sub_long_complex); } /** @brief OP *:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX @param p Node in syntax tree. **/ void genie_timesab_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_mul_long_complex); } /** @brief OP /:= = (REF LONG COMPLEX, LONG COMPLEX) REF LONG COMPLEX @param p Node in syntax tree. **/ void genie_divab_long_complex (NODE_T * p) { MOID_T *mode = LHS_MODE (p); genie_f_and_becomes (p, mode, genie_div_long_complex); } /** @brief PROC csqrt = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_sqrt_complex (NODE_T * p) { A68_REAL *re, *im; im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); RESET_ERRNO; if (VALUE (re) == 0.0 && VALUE (im) == 0.0) { VALUE (re) = 0.0; VALUE (im) = 0.0; } else { double x = ABS (VALUE (re)), y = ABS (VALUE (im)), w; if (x >= y) { double t = y / x; w = sqrt (x) * sqrt (0.5 * (1.0 + sqrt (1.0 + t * t))); } else { double t = x / y; w = sqrt (y) * sqrt (0.5 * (t + sqrt (1.0 + t * t))); } if (VALUE (re) >= 0.0) { VALUE (re) = w; VALUE (im) = VALUE (im) / (2.0 * w); } else { double ai = VALUE (im); double vi = (ai >= 0.0 ? w : -w); VALUE (re) = ai / (2.0 * vi); VALUE (im) = vi; } } MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT); } /** @brief PROC long csqrt = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_sqrt_long_complex (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *im = (MP_T *) STACK_OFFSET (-size); MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); RESET_ERRNO; (void) csqrt_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /** @brief PROC cexp = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_exp_complex (NODE_T * p) { A68_REAL *re, *im; double r; im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); RESET_ERRNO; r = exp (VALUE (re)); VALUE (re) = r * cos (VALUE (im)); VALUE (im) = r * sin (VALUE (im)); MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT); } /** @brief PROC long cexp = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_exp_long_complex (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *im = (MP_T *) STACK_OFFSET (-size); MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); (void) cexp_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /** @brief PROC cln = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_ln_complex (NODE_T * p) { A68_REAL *re, *im, r, th; im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); RESET_ERRNO; PUSH_COMPLEX (p, VALUE (re), VALUE (im)); genie_abs_complex (p); POP_OBJECT (p, &r, A68_REAL); PUSH_COMPLEX (p, VALUE (re), VALUE (im)); genie_arg_complex (p); POP_OBJECT (p, &th, A68_REAL); VALUE (re) = log (VALUE (&r)); VALUE (im) = VALUE (&th); MATH_RTE (p, errno != 0, MODE (COMPLEX), NO_TEXT); } /** @brief PROC long cln = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_ln_long_complex (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *im = (MP_T *) STACK_OFFSET (-size); MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); (void) cln_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /** @brief PROC csin = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_sin_complex (NODE_T * p) { A68_REAL *re, *im; im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); RESET_ERRNO; if (VALUE (im) == 0.0) { VALUE (re) = sin (VALUE (re)); VALUE (im) = 0.0; } else { double r = VALUE (re), i = VALUE (im); VALUE (re) = sin (r) * cosh (i); VALUE (im) = cos (r) * sinh (i); } MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /** @brief PROC long csin = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_sin_long_complex (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *im = (MP_T *) STACK_OFFSET (-size); MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); (void) csin_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /** @brief PROC ccos = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_cos_complex (NODE_T * p) { A68_REAL *re, *im; im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); RESET_ERRNO; if (VALUE (im) == 0.0) { VALUE (re) = cos (VALUE (re)); VALUE (im) = 0.0; } else { double r = VALUE (re), i = VALUE (im); VALUE (re) = cos (r) * cosh (i); VALUE (im) = sin (r) * sinh (-i); } MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /** @brief PROC long ccos = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_cos_long_complex (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *im = (MP_T *) STACK_OFFSET (-size); MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); (void) ccos_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /** @brief PROC ctan = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_tan_complex (NODE_T * p) { A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); double r, i; A68_REAL u, v; RESET_ERRNO; r = VALUE (re); i = VALUE (im); PUSH_PRIMITIVE (p, r, A68_REAL); PUSH_PRIMITIVE (p, i, A68_REAL); genie_sin_complex (p); POP_OBJECT (p, &v, A68_REAL); POP_OBJECT (p, &u, A68_REAL); PUSH_PRIMITIVE (p, r, A68_REAL); PUSH_PRIMITIVE (p, i, A68_REAL); genie_cos_complex (p); VALUE (re) = VALUE (&u); VALUE (im) = VALUE (&v); genie_div_complex (p); MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /** @brief PROC long ctan = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_tan_long_complex (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); MP_T *im = (MP_T *) STACK_OFFSET (-size); (void) ctan_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /** @brief PROC carcsin= (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_arcsin_complex (NODE_T * p) { A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); RESET_ERRNO; if (im == 0) { VALUE (re) = asin (VALUE (re)); } else { double r = VALUE (re), i = VALUE (im); double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i); double a = 0.5 * (u + v), b = 0.5 * (u - v); VALUE (re) = asin (b); VALUE (im) = log (a + sqrt (a * a - 1)); } MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /** @brief PROC long arcsin = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_asin_long_complex (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); MP_T *im = (MP_T *) STACK_OFFSET (-size); RESET_ERRNO; (void) casin_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /** @brief PROC carccos = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_arccos_complex (NODE_T * p) { A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); RESET_ERRNO; if (im == 0) { VALUE (re) = acos (VALUE (re)); } else { double r = VALUE (re), i = VALUE (im); double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i); double a = 0.5 * (u + v), b = 0.5 * (u - v); VALUE (re) = acos (b); VALUE (im) = -log (a + sqrt (a * a - 1)); } MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /** @brief PROC long carccos = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_acos_long_complex (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); MP_T *im = (MP_T *) STACK_OFFSET (-size); RESET_ERRNO; (void) cacos_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } /** @brief PROC carctan = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_arctan_complex (NODE_T * p) { A68_REAL *re = (A68_REAL *) (STACK_OFFSET (-2 * SIZE (MODE (REAL)))); A68_REAL *im = (A68_REAL *) (STACK_OFFSET (-SIZE (MODE (REAL)))); RESET_ERRNO; if (im == 0) { VALUE (re) = atan (VALUE (re)); } else { double r = VALUE (re), i = VALUE (im); double a = a68g_hypot (r, i + 1), b = a68g_hypot (r, i - 1); VALUE (re) = 0.5 * atan (2 * r / (1 - r * r - i * i)); VALUE (im) = 0.5 * log (a / b); } MATH_RTE (p, errno != 0, MODE (REAL), NO_TEXT); } /** @brief PROC long catan = (LONG COMPLEX) LONG COMPLEX @param p Node in syntax tree. **/ void genie_atan_long_complex (NODE_T * p) { MOID_T *mode = MOID (p); int digits = DIGITSC (mode), size = SIZEC (mode); ADDR_T pop_sp = stack_pointer; MP_T *re = (MP_T *) STACK_OFFSET (-2 * size); MP_T *im = (MP_T *) STACK_OFFSET (-size); RESET_ERRNO; (void) catan_mp (p, re, im, digits); stack_pointer = pop_sp; MP_STATUS (re) = (MP_T) INIT_MASK; MP_STATUS (im) = (MP_T) INIT_MASK; MATH_RTE (p, errno != 0, mode, NO_TEXT); } #if defined HAVE_GNU_GSL /** @brief PROC csinh = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_sinh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_sinh); } /** @brief PROC ccosh = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_cosh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_cosh); } /** @brief PROC ctanh = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_tanh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_tanh); } /** @brief PROC carcsinh = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_arcsinh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_arcsinh); } /** @brief PROC carccosh = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_arccosh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_arccosh); } /** @brief PROC carctanh = (COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_arctanh_complex (NODE_T * p) { GSL_COMPLEX_FUNCTION (gsl_complex_arctanh); } #endif /* defined HAVE_GNU_GSL */ /* Standard prelude implementation, transput */ /* Transput library - General routines and (formatted) transput. But Eeyore wasn't listening. He was taking the balloon out, and putting it back again, as happy as could be ... Winnie the Pooh, A.A. Milne. - Revised Report on the Algorithmic Language Algol 68. */ A68_CHANNEL stand_in_channel, stand_out_channel, stand_draw_channel, stand_back_channel, stand_error_channel, associate_channel, skip_channel; A68_REF stand_in, stand_out, stand_back, stand_error, skip_file; A68_FORMAT nil_format = { INIT_MASK, NULL, 0 }; /* File table handling In a table we record opened files. When execution ends, unclosed files are closed, and temps are removed. This keeps /tmp free of spurious files :-) */ typedef struct FILE_ENTRY FILE_ENTRY; struct FILE_ENTRY { NODE_T *pos; BOOL_T is_open, is_tmp; FILE_T fd; A68_REF idf; }; FILE_ENTRY file_entries[MAX_OPEN_FILES]; /** @brief Init a file entry. @param k Entry to initialise. **/ void init_file_entry (int k) { if (k >= 0 && k < MAX_OPEN_FILES) { FILE_ENTRY *fe = &(file_entries[k]); POS (fe) = NO_NODE; IS_OPEN (fe) = A68_FALSE; IS_TMP (fe) = A68_FALSE; FD (fe) = A68_NO_FILENO; IDF (fe) = nil_ref; } } /** @brief Initialise file entry table. **/ void init_file_entries (void) { int k; for (k = 0; k < MAX_OPEN_FILES; k ++) { init_file_entry (k); } } /** @brief Store file for later closing when not explicitly closed. @param p Entry in syntax tree. @param fd File descriptor. @param idf File name. @param is_tmp Whether file is a temp file. @return Entry in table. **/ int store_file_entry (NODE_T *p, FILE_T fd, char *idf, BOOL_T is_tmp) { int k; for (k = 0; k < MAX_OPEN_FILES; k ++) { FILE_ENTRY *fe = &(file_entries[k]); if (!IS_OPEN (fe)) { int len = 1 + (int) strlen (idf); POS (fe) = p; IS_OPEN (fe) = A68_TRUE; IS_TMP (fe) = is_tmp; FD (fe) = fd; IDF (fe) = heap_generator (p, MODE (C_STRING), len); BLOCK_GC_HANDLE (&(IDF (fe))); bufcpy (DEREF (char, &IDF (fe)), idf, len); return (k); } } diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_OPEN_FILES); exit_genie (p, A68_RUNTIME_ERROR); return (-1); /* Fool them */ } /** @brief Close file and delete temp file. @param p Entry in syntax tree. @param k Entry in table. **/ static void close_file_entry (NODE_T *p, int k) { if (k >= 0 && k < MAX_OPEN_FILES) { FILE_ENTRY *fe = &(file_entries[k]); if (IS_OPEN (fe)) { /* Close the file */ if (FD (fe) != A68_NO_FILENO && close (FD (fe)) == -1) { init_file_entry (k); diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CLOSE); exit_genie (p, A68_RUNTIME_ERROR); } IS_OPEN (fe) = A68_FALSE; } } } /** @brief Close file and delete temp file. @param p Entry in syntax tree. @param k Entry in table. **/ static void free_file_entry (NODE_T *p, int k) { close_file_entry (p, k); if (k >= 0 && k < MAX_OPEN_FILES) { FILE_ENTRY *fe = &(file_entries[k]); if (IS_OPEN (fe)) { /* Attempt to remove a temp file, but ignore failure */ if (FD (fe) != A68_NO_FILENO && IS_TMP (fe)) { if (!IS_NIL (IDF (fe))) { char *filename; CHECK_INIT (p, INITIALISED (&(IDF (fe))), MODE (ROWS)); filename = DEREF (char, &IDF (fe)); if (filename != NO_TEXT) { (void) remove (filename); } } } /* Restore the fields */ if (!IS_NIL (IDF (fe))) { UNBLOCK_GC_HANDLE (&(IDF (fe))); } init_file_entry (k); } } } /** @brief Close all files and delete all temp files. **/ void free_file_entries (void) { int k; for (k = 0; k < MAX_OPEN_FILES; k ++) { free_file_entry (NO_NODE, k); } } /** @brief PROC char in string = (CHAR, REF INT, STRING) BOOL @param p Node in syntax tree. **/ void genie_char_in_string (NODE_T * p) { A68_CHAR c; A68_INT pos; A68_REF ref_pos, ref_str, row; A68_ARRAY *arr; A68_TUPLE *tup; char *q, ch; int k, len; POP_REF (p, &ref_str); row = *(A68_REF *) & ref_str; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); POP_REF (p, &ref_pos); POP_OBJECT (p, &c, A68_CHAR); reset_transput_buffer (PATTERN_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_str); len = get_transput_buffer_index (PATTERN_BUFFER); q = get_transput_buffer (PATTERN_BUFFER); ch = (char) VALUE (&c); for (k = 0; k < len; k++) { if (q[k] == ch) { STATUS (&pos) = INIT_MASK; VALUE (&pos) = k + LOWER_BOUND (tup); * DEREF (A68_INT, &ref_pos) = pos; PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); return; } } PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } /** @brief PROC last char in string = (CHAR, REF INT, STRING) BOOL @param p Node in syntax tree. **/ void genie_last_char_in_string (NODE_T * p) { A68_CHAR c; A68_INT pos; A68_REF ref_pos, ref_str, row; A68_ARRAY *arr; A68_TUPLE *tup; char *q, ch; int k, len; POP_REF (p, &ref_str); row = *(A68_REF *) & ref_str; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); POP_REF (p, &ref_pos); POP_OBJECT (p, &c, A68_CHAR); reset_transput_buffer (PATTERN_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_str); len = get_transput_buffer_index (PATTERN_BUFFER); q = get_transput_buffer (PATTERN_BUFFER); ch = (char) VALUE (&c); for (k = len - 1; k >= 0; k--) { if (q[k] == ch) { STATUS (&pos) = INIT_MASK; VALUE (&pos) = k + LOWER_BOUND (tup); * DEREF (A68_INT, &ref_pos) = pos; PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); return; } } PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } /** @brief PROC string in string = (STRING, REF INT, STRING) BOOL @param p Node in syntax tree. **/ void genie_string_in_string (NODE_T * p) { A68_REF ref_pos, ref_str, ref_pat, row; A68_ARRAY *arr; A68_TUPLE *tup; char *q; POP_REF (p, &ref_str); row = *(A68_REF *) & ref_str; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); POP_REF (p, &ref_pos); POP_REF (p, &ref_pat); reset_transput_buffer (PATTERN_BUFFER); reset_transput_buffer (STRING_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat); add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) & ref_str); q = strstr (get_transput_buffer (STRING_BUFFER), get_transput_buffer (PATTERN_BUFFER)); if (q != NO_TEXT) { if (!IS_NIL (ref_pos)) { A68_INT pos; STATUS (&pos) = INIT_MASK; /* ANSI standard leaves pointer difference undefined */ VALUE (&pos) = LOWER_BOUND (tup) + (int) get_transput_buffer_index (STRING_BUFFER) - (int) strlen (q); * DEREF (A68_INT, &ref_pos) = pos; } PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } } /* Strings in transput are of arbitrary size. For this, we have transput buffers. A transput buffer is a REF STRUCT (INT size, index, STRING buffer). It is in the heap, but cannot be gced. If it is too small, we give up on it and make a larger one. */ static A68_REF ref_transput_buffer[MAX_TRANSPUT_BUFFER]; /** @brief Set max number of chars in a transput buffer. @param n Transput buffer number. @param size Max number of chars. **/ void set_transput_buffer_size (int n, int size) { A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n])); STATUS (k) = INIT_MASK; VALUE (k) = size; } /** @brief Set char index for transput buffer. @param n Transput buffer number. @param cindex Char index. **/ void set_transput_buffer_index (int n, int cindex) { A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n]) + SIZE (MODE (INT))); STATUS (k) = INIT_MASK; VALUE (k) = cindex; } /** @brief Get max number of chars in a transput buffer. @param n Transput buffer number. @return See brief description. **/ int get_transput_buffer_size (int n) { A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n])); return (VALUE (k)); } /** @brief Get char index for transput buffer. @param n Transput buffer number. @return See brief description. **/ int get_transput_buffer_index (int n) { A68_INT *k = (A68_INT *) (ADDRESS (&ref_transput_buffer[n]) + SIZE (MODE (INT))); return (VALUE (k)); } /** @brief Get char[] from transput buffer. @param n Transput buffer number. @return See brief description. **/ char *get_transput_buffer (int n) { return ((char *) (ADDRESS (&ref_transput_buffer[n]) + 2 * SIZE (MODE (INT)))); } /** @brief Mark transput buffer as no longer in use. @param n Transput buffer number. **/ void unblock_transput_buffer (int n) { set_transput_buffer_index (n, -1); } /** @brief Find first unused transput buffer (for opening a file). @param p Node in syntax tree position in syntax tree. @return See brief description. **/ int get_unblocked_transput_buffer (NODE_T * p) { int k; for (k = FIXED_TRANSPUT_BUFFERS; k < MAX_TRANSPUT_BUFFER; k++) { if (get_transput_buffer_index (k) == -1) { return (k); } } /* Oops! */ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_OPEN_FILES); exit_genie (p, A68_RUNTIME_ERROR); return (-1); } /** @brief Empty contents of transput buffer. @param n Transput buffer number. **/ void reset_transput_buffer (int n) { set_transput_buffer_index (n, 0); (get_transput_buffer (n))[0] = NULL_CHAR; } /** @brief Initialise transput buffers before use. @param p Node in syntax tree position in syntax tree. **/ void init_transput_buffers (NODE_T * p) { int k; for (k = 0; k < MAX_TRANSPUT_BUFFER; k++) { ref_transput_buffer[k] = heap_generator (p, MODE (ROWS), 2 * SIZE (MODE (INT)) + TRANSPUT_BUFFER_SIZE); BLOCK_GC_HANDLE (&ref_transput_buffer[k]); set_transput_buffer_size (k, TRANSPUT_BUFFER_SIZE); reset_transput_buffer (k); } /* Last buffers are available for FILE values */ for (k = FIXED_TRANSPUT_BUFFERS; k < MAX_TRANSPUT_BUFFER; k++) { unblock_transput_buffer (k); } } /** @brief Make a transput buffer larger. @param p Node in syntax tree. @param k Transput buffer number. @param size New size in characters. **/ void enlarge_transput_buffer (NODE_T * p, int k, int size) { int tbindex = get_transput_buffer_index (k); char *sb_1 = get_transput_buffer (k), *sb_2; UNBLOCK_GC_HANDLE (&ref_transput_buffer[k]); ref_transput_buffer[k] = heap_generator (p, MODE (ROWS), 2 * SIZE (MODE (INT)) + size); BLOCK_GC_HANDLE (&ref_transput_buffer[k]); set_transput_buffer_size (k, size); set_transput_buffer_index (k, tbindex); sb_2 = get_transput_buffer (k); bufcpy (sb_2, sb_1, size); } /** @brief Add char to transput buffer; if the buffer is full, make it larger. @param p Node in syntax tree. @param k Transput buffer number. @param ch Char to add. **/ void add_char_transput_buffer (NODE_T * p, int k, char ch) { char *sb = get_transput_buffer (k); int size = get_transput_buffer_size (k); int tbindex = get_transput_buffer_index (k); if (tbindex == size - 2) { enlarge_transput_buffer (p, k, 10 * size /* size + TRANSPUT_BUFFER_SIZE */ ); add_char_transput_buffer (p, k, ch); } else { sb[tbindex] = ch; sb[tbindex + 1] = NULL_CHAR; set_transput_buffer_index (k, tbindex + 1); } } /** @brief Add char[] to transput buffer. @param p Node in syntax tree. @param k Transput buffer number. @param ch String to add. **/ void add_string_transput_buffer (NODE_T * p, int k, char *ch) { for (; ch[0] != NULL_CHAR; ch++) { add_char_transput_buffer (p, k, ch[0]); } } /** @brief Add A68 string to transput buffer. @param p Node in syntax tree. @param k Transput buffer number. @param ref Fat pointer to A68 string. **/ void add_a_string_transput_buffer (NODE_T * p, int k, BYTE_T * ref) { A68_REF row = *(A68_REF *) ref; A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); if (ROW_SIZE (tup) > 0) { int i; BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr)); for (i = LWB (tup); i <= UPB (tup); i++) { int addr = INDEX_1_DIM (arr, tup, i); A68_CHAR *ch = (A68_CHAR *) & (base_address[addr]); CHECK_INIT (p, INITIALISED (ch), MODE (CHAR)); add_char_transput_buffer (p, k, (char) VALUE (ch)); } } } /** @brief Pop A68 string and add to buffer. @param p Node in syntax tree. @param k Transput buffer number. **/ void add_string_from_stack_transput_buffer (NODE_T * p, int k) { DECREMENT_STACK_POINTER (p, A68_REF_SIZE); add_a_string_transput_buffer (p, k, STACK_TOP); } /** @brief Pop first character from transput buffer. @param k Transput buffer number. @return See brief description. **/ char pop_char_transput_buffer (int k) { char *sb = get_transput_buffer (k); int tbindex = get_transput_buffer_index (k); if (tbindex <= 0) { return (NULL_CHAR); } else { char ch = sb[0]; MOVE (&sb[0], &sb[1], tbindex); set_transput_buffer_index (k, tbindex - 1); return (ch); } } /** @brief Add C string to A68 string. @param p Node in syntax tree. @param ref_str Fat pointer to A68 string. @param str Pointer to C string. **/ static void add_c_string_to_a_string (NODE_T * p, A68_REF ref_str, char *str) { A68_REF a, c, d; A68_ARRAY *a_1, *a_3; A68_TUPLE *t_1, *t_3; int l_1, l_2, u, v; BYTE_T *b_1, *b_3; l_2 = (int) strlen (str); /* left part */ CHECK_REF (p, ref_str, MODE (REF_STRING)); a = * DEREF (A68_REF, &ref_str); CHECK_INIT (p, INITIALISED (&a), MODE (STRING)); GET_DESCRIPTOR (a_1, t_1, &a); l_1 = ROW_SIZE (t_1); /* Sum string */ c = heap_generator (p, MODE (STRING), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); d = heap_generator (p, MODE (STRING), (l_1 + l_2) * SIZE (MODE (CHAR))); /* Calculate again since garbage collector might have moved data */ GET_DESCRIPTOR (a_1, t_1, &a); /* Make descriptor of new string */ GET_DESCRIPTOR (a_3, t_3, &c); DIM (a_3) = 1; MOID (a_3) = MODE (CHAR); ELEM_SIZE (a_3) = SIZE (MODE (CHAR)); SLICE_OFFSET (a_3) = 0; FIELD_OFFSET (a_3) = 0; ARRAY (a_3) = d; LWB (t_3) = 1; UPB (t_3) = l_1 + l_2; SHIFT (t_3) = LWB (t_3); SPAN (t_3) = 1; /* add strings */ b_1 = (ROW_SIZE (t_1) > 0 ? DEREF (BYTE_T, &ARRAY (a_1)) : NO_BYTE); b_3 = DEREF (BYTE_T, &ARRAY (a_3)); u = 0; for (v = LWB (t_1); v <= UPB (t_1); v++) { MOVE ((BYTE_T *) & b_3[u], (BYTE_T *) & b_1[INDEX_1_DIM (a_1, t_1, v)], SIZE (MODE (CHAR))); u += SIZE (MODE (CHAR)); } for (v = 0; v < l_2; v++) { A68_CHAR ch; STATUS (&ch) = INIT_MASK; VALUE (&ch) = str[v]; MOVE ((BYTE_T *) & b_3[u], (BYTE_T *) & ch, SIZE (MODE (CHAR))); u += SIZE (MODE (CHAR)); } * DEREF (A68_REF, &ref_str) = c; } /** @brief Purge buffer for file. @param p Node in syntax tree. @param ref_file @param k Transput buffer number for file. **/ void write_purge_buffer (NODE_T * p, A68_REF ref_file, int k) { A68_FILE *file = FILE_DEREF (&ref_file); if (IS_NIL (STRING (file))) { if (!(FD (file) == STDOUT_FILENO && halt_typing)) { WRITE (FD (file), get_transput_buffer (k)); } } else { add_c_string_to_a_string (p, STRING (file), get_transput_buffer (k)); } reset_transput_buffer (k); } /* Routines that involve the A68 expression stack */ /** @brief Allocate a temporary string on the stack. @param p Node in syntax tree. @param size Size in characters. @return See brief description. **/ char *stack_string (NODE_T * p, int size) { char *new_str = (char *) STACK_TOP; INCREMENT_STACK_POINTER (p, size); if (stack_pointer > expr_stack_limit) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW); exit_genie (p, A68_RUNTIME_ERROR); } FILL (new_str, NULL_CHAR, size); return (new_str); } /* Transput basic RTS routines */ /** @brief REF FILE standin @param p Node in syntax tree. **/ void genie_stand_in (NODE_T * p) { PUSH_REF (p, stand_in); } /** @brief REF FILE standout @param p Node in syntax tree. **/ void genie_stand_out (NODE_T * p) { PUSH_REF (p, stand_out); } /** @brief REF FILE standback @param p Node in syntax tree. **/ void genie_stand_back (NODE_T * p) { PUSH_REF (p, stand_back); } /** @brief REF FILE standerror @param p Node in syntax tree. **/ void genie_stand_error (NODE_T * p) { PUSH_REF (p, stand_error); } /** @brief CHAR error char @param p Node in syntax tree. **/ void genie_error_char (NODE_T * p) { PUSH_PRIMITIVE (p, ERROR_CHAR, A68_CHAR); } /** @brief CHAR exp char @param p Node in syntax tree. **/ void genie_exp_char (NODE_T * p) { PUSH_PRIMITIVE (p, EXPONENT_CHAR, A68_CHAR); } /** @brief CHAR flip char @param p Node in syntax tree. **/ void genie_flip_char (NODE_T * p) { PUSH_PRIMITIVE (p, FLIP_CHAR, A68_CHAR); } /** @brief CHAR flop char @param p Node in syntax tree. **/ void genie_flop_char (NODE_T * p) { PUSH_PRIMITIVE (p, FLOP_CHAR, A68_CHAR); } /** @brief CHAR null char @param p Node in syntax tree. **/ void genie_null_char (NODE_T * p) { PUSH_PRIMITIVE (p, NULL_CHAR, A68_CHAR); } /** @brief CHAR blank @param p Node in syntax tree. **/ void genie_blank_char (NODE_T * p) { PUSH_PRIMITIVE (p, BLANK_CHAR, A68_CHAR); } /** @brief CHAR newline char @param p Node in syntax tree. **/ void genie_newline_char (NODE_T * p) { PUSH_PRIMITIVE (p, NEWLINE_CHAR, A68_CHAR); } /** @brief CHAR formfeed char @param p Node in syntax tree. **/ void genie_formfeed_char (NODE_T * p) { PUSH_PRIMITIVE (p, FORMFEED_CHAR, A68_CHAR); } /** @brief CHAR tab char @param p Node in syntax tree. **/ void genie_tab_char (NODE_T * p) { PUSH_PRIMITIVE (p, TAB_CHAR, A68_CHAR); } /** @brief CHANNEL standin channel @param p Node in syntax tree. **/ void genie_stand_in_channel (NODE_T * p) { PUSH_OBJECT (p, stand_in_channel, A68_CHANNEL); } /** @brief CHANNEL standout channel @param p Node in syntax tree. **/ void genie_stand_out_channel (NODE_T * p) { PUSH_OBJECT (p, stand_out_channel, A68_CHANNEL); } /** @brief CHANNEL stand draw channel @param p Node in syntax tree. **/ void genie_stand_draw_channel (NODE_T * p) { PUSH_OBJECT (p, stand_draw_channel, A68_CHANNEL); } /** @brief CHANNEL standback channel @param p Node in syntax tree. **/ void genie_stand_back_channel (NODE_T * p) { PUSH_OBJECT (p, stand_back_channel, A68_CHANNEL); } /** @brief CHANNEL standerror channel @param p Node in syntax tree. **/ void genie_stand_error_channel (NODE_T * p) { PUSH_OBJECT (p, stand_error_channel, A68_CHANNEL); } /** @brief PROC STRING program idf @param p Node in syntax tree. **/ void genie_program_idf (NODE_T * p) { PUSH_REF (p, c_to_a_string (p, FILE_SOURCE_NAME (&program), DEFAULT_WIDTH)); } /* FILE and CHANNEL initialisations */ /** @brief Set_default_event_procedure. @param z **/ void set_default_event_procedure (A68_PROCEDURE * z) { STATUS (z) = INIT_MASK; NODE (&(BODY (z))) = NO_NODE; ENVIRON (z) = 0; } /** @brief Initialise channel. @param chan Channel. @param r Reset possible. @param s Set possible. @param g Get possible. @param p Put possible. @param b Bin possible. @param d Draw possible. **/ static void init_channel (A68_CHANNEL * chan, BOOL_T r, BOOL_T s, BOOL_T g, BOOL_T p, BOOL_T b, BOOL_T d) { STATUS (chan) = INIT_MASK; RESET (chan) = r; SET (chan) = s; GET (chan) = g; PUT (chan) = p; BIN (chan) = b; DRAW (chan) = d; COMPRESS (chan) = A68_TRUE; } /** @brief Set default event handlers. @param f File. **/ void set_default_event_procedures (A68_FILE * f) { set_default_event_procedure (&(FILE_END_MENDED (f))); set_default_event_procedure (&(PAGE_END_MENDED (f))); set_default_event_procedure (&(LINE_END_MENDED (f))); set_default_event_procedure (&(VALUE_ERROR_MENDED (f))); set_default_event_procedure (&(OPEN_ERROR_MENDED (f))); set_default_event_procedure (&(TRANSPUT_ERROR_MENDED (f))); set_default_event_procedure (&(FORMAT_END_MENDED (f))); set_default_event_procedure (&(FORMAT_ERROR_MENDED (f))); } /** @brief Set up a REF FILE object. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param c Channel. @param s File number. @param rm Read mood. @param wm Write mood. @param cm Char mood. @param env Unix ENVIRONMENT variable. **/ static void init_file (NODE_T * p, A68_REF * ref_file, A68_CHANNEL c, FILE_T s, BOOL_T rm, BOOL_T wm, BOOL_T cm, char *env) { A68_FILE *f; char *filename = (env == NO_TEXT ? NO_TEXT : getenv (env)); *ref_file = heap_generator (p, MODE (REF_FILE), SIZE (MODE (FILE))); BLOCK_GC_HANDLE (ref_file); f = FILE_DEREF (ref_file); STATUS (f) = INIT_MASK; TERMINATOR (f) = nil_ref; CHANNEL (f) = c; if (filename != NO_TEXT && strlen (filename) > 0) { int len = 1 + (int) strlen (filename); IDENTIFICATION (f) = heap_generator (p, MODE (C_STRING), len); BLOCK_GC_HANDLE (&(IDENTIFICATION (f))); bufcpy (DEREF (char, &IDENTIFICATION (f)), filename, len); FD (f) = A68_NO_FILENO; READ_MOOD (f) = A68_FALSE; WRITE_MOOD (f) = A68_FALSE; CHAR_MOOD (f) = A68_FALSE; DRAW_MOOD (f) = A68_FALSE; } else { IDENTIFICATION (f) = nil_ref; FD (f) = s; READ_MOOD (f) = rm; WRITE_MOOD (f) = wm; CHAR_MOOD (f) = cm; DRAW_MOOD (f) = A68_FALSE; } TRANSPUT_BUFFER (f) = get_unblocked_transput_buffer (p); reset_transput_buffer (TRANSPUT_BUFFER (f)); END_OF_FILE (f) = A68_FALSE; TMP_FILE (f) = A68_FALSE; OPENED (f) = A68_TRUE; OPEN_EXCLUSIVE (f) = A68_FALSE; FORMAT (f) = nil_format; STRING (f) = nil_ref; STRPOS (f) = 0; FILE_ENTRY (f) = -1; set_default_event_procedures (f); } /** @brief Initialise the transput RTL. @param p Node in syntax tree. **/ void genie_init_transput (NODE_T * p) { init_transput_buffers (p); /* Channels */ init_channel (&stand_in_channel, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE, A68_FALSE); init_channel (&stand_out_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE); init_channel (&stand_back_channel, A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_FALSE); init_channel (&stand_error_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE, A68_FALSE, A68_FALSE); init_channel (&associate_channel, A68_TRUE, A68_TRUE, A68_TRUE, A68_TRUE, A68_FALSE, A68_FALSE); init_channel (&skip_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE); #if defined HAVE_GNU_PLOTUTILS init_channel (&stand_draw_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE); #else /* */ init_channel (&stand_draw_channel, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_FALSE, A68_TRUE); #endif /* */ /* Files */ init_file (p, &stand_in, stand_in_channel, STDIN_FILENO, A68_TRUE, A68_FALSE, A68_TRUE, "A68G_STANDIN"); init_file (p, &stand_out, stand_out_channel, STDOUT_FILENO, A68_FALSE, A68_TRUE, A68_TRUE, "A68G_STANDOUT"); init_file (p, &stand_back, stand_back_channel, A68_NO_FILENO, A68_FALSE, A68_FALSE, A68_FALSE, NO_TEXT); init_file (p, &stand_error, stand_error_channel, STDERR_FILENO, A68_FALSE, A68_TRUE, A68_TRUE, "A68G_STANDERROR"); init_file (p, &skip_file, skip_channel, A68_NO_FILENO, A68_FALSE, A68_FALSE, A68_FALSE, NO_TEXT); } /** @brief PROC (REF FILE) STRING idf @param p Node in syntax tree. **/ void genie_idf (NODE_T * p) { A68_REF ref_file, ref_filename; char *filename; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); ref_file = *(A68_REF *) STACK_TOP; ref_filename = IDENTIFICATION (FILE_DEREF (&ref_file)); CHECK_REF (p, ref_filename, MODE (ROWS)); filename = DEREF (char, &ref_filename); PUSH_REF (p, c_to_a_string (p, filename, DEFAULT_WIDTH)); } /** @brief PROC (REF FILE) STRING term @param p Node in syntax tree. **/ void genie_term (NODE_T * p) { A68_REF ref_file, ref_term; char *term; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); ref_file = *(A68_REF *) STACK_TOP; ref_term = TERMINATOR (FILE_DEREF (&ref_file)); CHECK_REF (p, ref_term, MODE (ROWS)); term = DEREF (char, &ref_term); PUSH_REF (p, c_to_a_string (p, term, DEFAULT_WIDTH)); } /** @brief PROC (REF FILE, STRING) VOID make term @param p Node in syntax tree. **/ void genie_make_term (NODE_T * p) { int size; A68_FILE *file; A68_REF ref_file, str; POP_REF (p, &str); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); ref_file = *(A68_REF *) STACK_TOP; file = FILE_DEREF (&ref_file); /* Don't check initialisation so we can "make term" before opening. That is ok */ size = a68_string_size (p, str); if (INITIALISED (&(TERMINATOR (file))) && !IS_NIL (TERMINATOR (file))) { UNBLOCK_GC_HANDLE (&(TERMINATOR (file))); } TERMINATOR (file) = heap_generator (p, MODE (C_STRING), 1 + size); BLOCK_GC_HANDLE (&(TERMINATOR (file))); ASSERT (a_to_c_string (p, DEREF (char, &TERMINATOR (file)), str) != NO_TEXT); } /** @brief PROC (REF FILE) BOOL put possible @param p Node in syntax tree. **/ void genie_put_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, PUT (&CHANNEL (file)), A68_BOOL); } /** @brief PROC (REF FILE) BOOL get possible @param p Node in syntax tree. **/ void genie_get_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, GET (&CHANNEL (file)), A68_BOOL); } /** @brief PROC (REF FILE) BOOL bin possible @param p Node in syntax tree. **/ void genie_bin_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, BIN (&CHANNEL (file)), A68_BOOL); } /** @brief PROC (REF FILE) BOOL set possible @param p Node in syntax tree. **/ void genie_set_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, SET (&CHANNEL (file)), A68_BOOL); } /** @brief PROC (REF FILE) BOOL reidf possible @param p Node in syntax tree. **/ void genie_reidf_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } /** @brief PROC (REF FILE) BOOL reset possible @param p Node in syntax tree. **/ void genie_reset_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, RESET (&CHANNEL (file)), A68_BOOL); } /** @brief PROC (REF FILE) BOOL compressible @param p Node in syntax tree. **/ void genie_compressible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, COMPRESS (&CHANNEL (file)), A68_BOOL); } /** @brief PROC (REF FILE) BOOL draw possible @param p Node in syntax tree. **/ void genie_draw_possible (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PUSH_PRIMITIVE (p, DRAW (&CHANNEL (file)), A68_BOOL); } /** @brief PROC (REF FILE, STRING, CHANNEL) INT open @param p Node in syntax tree. **/ void genie_open (NODE_T * p) { A68_CHANNEL channel; A68_REF ref_iden, ref_file; A68_FILE *file; int size; POP_OBJECT (p, &channel, A68_CHANNEL); POP_REF (p, &ref_iden); CHECK_REF (p, ref_iden, MODE (REF_STRING)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); STATUS (file) = INIT_MASK; FILE_ENTRY (file) = -1; CHANNEL (file) = channel; OPENED (file) = A68_TRUE; OPEN_EXCLUSIVE (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; TMP_FILE (file) = A68_FALSE; size = a68_string_size (p, ref_iden); if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) { UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); } IDENTIFICATION (file) = heap_generator (p, MODE (C_STRING), 1 + size); BLOCK_GC_HANDLE (&(IDENTIFICATION (file))); ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT); TERMINATOR (file) = nil_ref; FORMAT (file) = nil_format; FD (file) = A68_NO_FILENO; if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) { UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file))); } STRING (file) = nil_ref; STRPOS (file) = 0; DEVICE_MADE (&DEVICE (file)) = A68_FALSE; STREAM (&DEVICE (file)) = NO_STREAM; set_default_event_procedures (file); { struct stat status; if (stat (DEREF (char, &IDENTIFICATION (file)), &status) == 0) { PUSH_PRIMITIVE (p, (S_ISREG (ST_MODE (&status)) != 0 ? 0 : 1), A68_INT); } else { PUSH_PRIMITIVE (p, 1, A68_INT); } RESET_ERRNO; } } /** @brief PROC (REF FILE, STRING, CHANNEL) INT establish @param p Node in syntax tree. **/ void genie_establish (NODE_T * p) { A68_CHANNEL channel; A68_REF ref_iden, ref_file; A68_FILE *file; int size; POP_OBJECT (p, &channel, A68_CHANNEL); POP_REF (p, &ref_iden); CHECK_REF (p, ref_iden, MODE (REF_STRING)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); STATUS (file) = INIT_MASK; FILE_ENTRY (file) = -1; CHANNEL (file) = channel; OPENED (file) = A68_TRUE; OPEN_EXCLUSIVE (file) = A68_TRUE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; TMP_FILE (file) = A68_FALSE; if (!PUT (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting"); exit_genie (p, A68_RUNTIME_ERROR); } size = a68_string_size (p, ref_iden); if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) { UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); } IDENTIFICATION (file) = heap_generator (p, MODE (C_STRING), 1 + size); BLOCK_GC_HANDLE (&(IDENTIFICATION (file))); ASSERT (a_to_c_string (p, DEREF (char, &IDENTIFICATION (file)), ref_iden) != NO_TEXT); TERMINATOR (file) = nil_ref; FORMAT (file) = nil_format; FD (file) = A68_NO_FILENO; if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) { UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file))); } STRING (file) = nil_ref; STRPOS (file) = 0; DEVICE_MADE (&DEVICE (file)) = A68_FALSE; STREAM (&DEVICE (file)) = NO_STREAM; set_default_event_procedures (file); PUSH_PRIMITIVE (p, 0, A68_INT); } /** @brief PROC (REF FILE, CHANNEL) INT create @param p Node in syntax tree. **/ void genie_create (NODE_T * p) { A68_CHANNEL channel; A68_REF ref_file; A68_FILE *file; POP_OBJECT (p, &channel, A68_CHANNEL); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); STATUS (file) = INIT_MASK; FILE_ENTRY (file) = -1; CHANNEL (file) = channel; OPENED (file) = A68_TRUE; OPEN_EXCLUSIVE (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; TMP_FILE (file) = A68_TRUE; if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) { UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); } IDENTIFICATION (file) = nil_ref; TERMINATOR (file) = nil_ref; FORMAT (file) = nil_format; FD (file) = A68_NO_FILENO; if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) { UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file))); } STRING (file) = nil_ref; STRPOS (file) = 0; DEVICE_MADE (&DEVICE (file)) = A68_FALSE; STREAM (&DEVICE (file)) = NO_STREAM; set_default_event_procedures (file); PUSH_PRIMITIVE (p, 0, A68_INT); } /** @brief PROC (REF FILE, REF STRING) VOID associate @param p Node in syntax tree. **/ void genie_associate (NODE_T * p) { A68_REF ref_string, ref_file; A68_FILE *file; POP_REF (p, &ref_string); CHECK_REF (p, ref_string, MODE (REF_STRING)); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); if (IS_IN_HEAP (&ref_file) && !IS_IN_HEAP (&ref_string)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, MODE (REF_STRING)); exit_genie (p, A68_RUNTIME_ERROR); } else if (IS_IN_FRAME (&ref_file) && IS_IN_FRAME (&ref_string)) { if (REF_SCOPE (&ref_string) > REF_SCOPE (&ref_file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SCOPE_DYNAMIC_1, MODE (REF_STRING)); exit_genie (p, A68_RUNTIME_ERROR); } } file = FILE_DEREF (&ref_file); STATUS (file) = INIT_MASK; FILE_ENTRY (file) = -1; CHANNEL (file) = associate_channel; OPENED (file) = A68_TRUE; OPEN_EXCLUSIVE (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; TMP_FILE (file) = A68_FALSE; if (INITIALISED (&(IDENTIFICATION (file))) && !IS_NIL (IDENTIFICATION (file))) { UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); } IDENTIFICATION (file) = nil_ref; TERMINATOR (file) = nil_ref; FORMAT (file) = nil_format; FD (file) = A68_NO_FILENO; if (INITIALISED (&(STRING (file))) && !IS_NIL (STRING (file))) { UNBLOCK_GC_HANDLE (DEREF (A68_REF, &STRING (file))); } STRING (file) = ref_string; BLOCK_GC_HANDLE ((A68_REF *) (&(STRING (file)))); STRPOS (file) = 0; DEVICE_MADE (&DEVICE (file)) = A68_FALSE; STREAM (&DEVICE (file)) = NO_STREAM; set_default_event_procedures (file); } /** @brief PROC (REF FILE) VOID close @param p Node in syntax tree. **/ void genie_close (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) { return; } DEVICE_MADE (&DEVICE (file)) = A68_FALSE; #if defined HAVE_GNU_PLOTUTILS if (DEVICE_OPENED (&DEVICE (file))) { ASSERT(close_device (p, file) == A68_TRUE); STREAM (&DEVICE (file)) = NO_STREAM; return; } #endif /* */ FD (file) = A68_NO_FILENO; OPENED (file) = A68_FALSE; unblock_transput_buffer (TRANSPUT_BUFFER (file)); set_default_event_procedures (file); free_file_entry (p, FILE_ENTRY (file)); } /** @brief PROC (REF FILE) VOID lock @param p Node in syntax tree. **/ void genie_lock (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) { return; } DEVICE_MADE (&DEVICE (file)) = A68_FALSE; #if defined HAVE_GNU_PLOTUTILS if (DEVICE_OPENED (&DEVICE (file))) { ASSERT(close_device (p, file) == A68_TRUE); STREAM (&DEVICE (file)) = NO_STREAM; return; } #endif /* */ #if ! defined HAVE_WIN32 RESET_ERRNO; ASSERT (fchmod (FD (file), (mode_t) 0x0) != -1); #endif if (FD (file) != A68_NO_FILENO && close (FD (file)) == -1) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_LOCK); exit_genie (p, A68_RUNTIME_ERROR); } else { FD (file) = A68_NO_FILENO; OPENED (file) = A68_FALSE; unblock_transput_buffer (TRANSPUT_BUFFER (file)); set_default_event_procedures (file); } free_file_entry (p, FILE_ENTRY (file)); } /** @brief PROC (REF FILE) VOID erase @param p Node in syntax tree. **/ void genie_erase (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file) || (!READ_MOOD (file) && !WRITE_MOOD (file) && !DRAW_MOOD (file))) { return; } DEVICE_MADE (&DEVICE (file)) = A68_FALSE; #if defined HAVE_GNU_PLOTUTILS if (DEVICE_OPENED (&DEVICE (file))) { ASSERT(close_device (p, file) == A68_TRUE); STREAM (&DEVICE (file)) = NO_STREAM; return; } #endif /* */ if (FD (file) != A68_NO_FILENO && close (FD (file)) == -1) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_SCRATCH); exit_genie (p, A68_RUNTIME_ERROR); } else { unblock_transput_buffer (TRANSPUT_BUFFER (file)); set_default_event_procedures (file); } /* Remove the file */ if (!IS_NIL (IDENTIFICATION (file))) { char *filename; CHECK_INIT (p, INITIALISED (&(IDENTIFICATION (file))), MODE (ROWS)); filename = DEREF (char, &IDENTIFICATION (file)); if (remove (filename) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_SCRATCH); exit_genie (p, A68_RUNTIME_ERROR); } UNBLOCK_GC_HANDLE (&(IDENTIFICATION (file))); IDENTIFICATION (file) = nil_ref; } init_file_entry (FILE_ENTRY (file)); } /** @brief PROC (REF FILE) VOID backspace @param p Node in syntax tree. **/ void genie_backspace (NODE_T * p) { ADDR_T pop_sp = stack_pointer; PUSH_PRIMITIVE (p, -1, A68_INT); genie_set (p); stack_pointer = pop_sp; } /** @brief PROC (REF FILE, INT) INT set @param p Node in syntax tree. **/ void genie_set (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_INT pos; POP_OBJECT (p, &pos, A68_INT); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (!SET (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CANT_SET); exit_genie (p, A68_RUNTIME_ERROR); } if (!IS_NIL (STRING (file))) { A68_REF z = * DEREF (A68_REF, &STRING (file)); A68_ARRAY *a; A68_TUPLE *t; int size; /* Circumvent buffering problems */ STRPOS (file) -= get_transput_buffer_index (TRANSPUT_BUFFER (file)); ASSERT (STRPOS (file) > 0); reset_transput_buffer (TRANSPUT_BUFFER (file)); /* Now set */ CHECK_INT_ADDITION (p, STRPOS (file), VALUE (&pos)); STRPOS (file) += VALUE (&pos); GET_DESCRIPTOR (a, t, &z); size = ROW_SIZE (t); if (size <= 0 || STRPOS (file) < 0 || STRPOS (file) >= size) { A68_BOOL res; on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &res, A68_BOOL); if (VALUE (&res) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED); exit_genie (p, A68_RUNTIME_ERROR); } } PUSH_PRIMITIVE (p, STRPOS (file), A68_INT); } else if (FD (file) == A68_NO_FILENO) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_RESET); exit_genie (p, A68_RUNTIME_ERROR); } else { __off_t curpos = lseek (FD (file), 0, SEEK_CUR); __off_t maxpos = lseek (FD (file), 0, SEEK_END); __off_t res = lseek (FD (file), curpos, SEEK_SET); /* Circumvent buffering problems */ int reserve = get_transput_buffer_index (TRANSPUT_BUFFER (file)); curpos -= (__off_t) reserve; res = lseek (FD (file), -reserve, SEEK_CUR); ASSERT (res != -1 && errno == 0); reset_transput_buffer (TRANSPUT_BUFFER (file)); /* Now set */ CHECK_INT_ADDITION (p, curpos, VALUE (&pos)); curpos += VALUE (&pos); if (curpos < 0 || curpos >= maxpos) { A68_BOOL ret; on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &ret, A68_BOOL); if (VALUE (&ret) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, (int) lseek (FD (file), 0, SEEK_CUR), A68_INT); } else { res = lseek (FD (file), curpos, SEEK_SET); if (res == -1 || errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_SET); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, (int) res, A68_INT); } } } /** @brief PROC (REF FILE) VOID reset @param p Node in syntax tree. **/ void genie_reset (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (!RESET (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CANT_RESET); exit_genie (p, A68_RUNTIME_ERROR); } if (IS_NIL (STRING (file))) { close_file_entry (p, FILE_ENTRY (file)); } else { STRPOS (file) = 0; } READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; DRAW_MOOD (file) = A68_FALSE; FD (file) = A68_NO_FILENO; /* set_default_event_procedures (file); */ } /** @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on file end @param p Node in syntax tree. **/ void genie_on_file_end (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); FILE_END_MENDED (file) = z; } /** @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on page end @param p Node in syntax tree. **/ void genie_on_page_end (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); PAGE_END_MENDED (file) = z; } /** @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on line end @param p Node in syntax tree. **/ void genie_on_line_end (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); LINE_END_MENDED (file) = z; } /** @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format end @param p Node in syntax tree. **/ void genie_on_format_end (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); FORMAT_END_MENDED (file) = z; } /** @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on format error @param p Node in syntax tree. **/ void genie_on_format_error (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); FORMAT_ERROR_MENDED (file) = z; } /** @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on value error @param p Node in syntax tree. **/ void genie_on_value_error (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); VALUE_ERROR_MENDED (file) = z; } /** @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on open error @param p Node in syntax tree. **/ void genie_on_open_error (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); OPEN_ERROR_MENDED (file) = z; } /** @brief PROC (REF FILE, PROC (REF FILE) BOOL) VOID on transput error @param p Node in syntax tree. **/ void genie_on_transput_error (NODE_T * p) { A68_PROCEDURE z; A68_REF ref_file; A68_FILE *file; POP_PROCEDURE (p, &z); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); TRANSPUT_ERROR_MENDED (file) = z; } /** @brief Invoke event routine. @param p Node in syntax tree. @param z Routine to invoke. @param ref_file Fat pointer to A68 file. **/ void on_event_handler (NODE_T * p, A68_PROCEDURE z, A68_REF ref_file) { if (NODE (&(BODY (&z))) == NO_NODE) { /* Default procedure */ PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } else { ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; PUSH_REF (p, ref_file); genie_call_event_routine (p, MODE (PROC_REF_FILE_BOOL), &z, pop_sp, pop_fp); } } /** @brief Handle end-of-file event. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. **/ void end_of_file_error (NODE_T * p, A68_REF ref_file) { A68_BOOL z; on_event_handler (p, FILE_END_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ENDED); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief Handle file-open-error event. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param mode Mode for opening. **/ void open_error (NODE_T * p, A68_REF ref_file, char *mode) { A68_BOOL z; on_event_handler (p, OPEN_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { A68_FILE *file; char *filename; CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!IS_NIL (IDENTIFICATION (file))) { filename = DEREF (char, &IDENTIFICATION (FILE_DEREF (&ref_file))); } else { filename = "(missing filename)"; } diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_CANNOT_OPEN_FOR, filename, mode); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief Handle value error event. @param p Node in syntax tree. @param m Mode of object read or written. @param ref_file Fat pointer to A68 file. **/ void value_error (NODE_T * p, MOID_T * m, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); if (END_OF_FILE (f)) { end_of_file_error (p, ref_file); } else { A68_BOOL z; on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m); exit_genie (p, A68_RUNTIME_ERROR); } } } /** @brief Handle value_error event. @param p Node in syntax tree. @param m Mode of object read or written. @param ref_file Fat pointer to A68 file. **/ void value_sign_error (NODE_T * p, MOID_T * m, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); if (END_OF_FILE (f)) { end_of_file_error (p, ref_file); } else { A68_BOOL z; on_event_handler (p, VALUE_ERROR_MENDED (f), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT_SIGN, m); exit_genie (p, A68_RUNTIME_ERROR); } } } /** @brief Handle transput-error event. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param m Mode of object read or written. **/ void transput_error (NODE_T * p, A68_REF ref_file, MOID_T * m) { A68_BOOL z; on_event_handler (p, TRANSPUT_ERROR_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_TRANSPUT, m); exit_genie (p, A68_RUNTIME_ERROR); } } /* Implementation of put and get */ /** @brief Get next char from file. @param f File. @return See brief description. **/ int char_scanner (A68_FILE * f) { if (get_transput_buffer_index (TRANSPUT_BUFFER (f)) > 0) { /* There are buffered characters */ END_OF_FILE (f) = A68_FALSE; return (pop_char_transput_buffer (TRANSPUT_BUFFER (f))); } else if (IS_NIL (STRING (f))) { /* Fetch next CHAR from the FILE */ ssize_t chars_read; char ch; chars_read = io_read_conv (FD (f), &ch, 1); if (chars_read == 1) { END_OF_FILE (f) = A68_FALSE; return (ch); } else { END_OF_FILE (f) = A68_TRUE; return (EOF_CHAR); } } else { /* File is associated with a STRING. Give next CHAR. When we're outside the STRING give EOF_CHAR. */ A68_REF z = * DEREF (A68_REF, &STRING (f)); A68_ARRAY *a; A68_TUPLE *t; BYTE_T *base; A68_CHAR *ch; int k; GET_DESCRIPTOR (a, t, &z); k = STRPOS (f) + LWB (t); if (ROW_SIZE (t) <= 0 || k < LWB (t) || k > UPB (t)) { END_OF_FILE (f) = A68_TRUE; return (EOF_CHAR); } else { base = DEREF (BYTE_T, &ARRAY (a)); ch = (A68_CHAR *) & (base[INDEX_1_DIM (a, t, k)]); STRPOS (f)++; return (VALUE (ch)); } } } /** @brief Push back look-ahead character to file. @param p Node in syntax tree. @param f File. @param ch Character to push. **/ void unchar_scanner (NODE_T * p, A68_FILE * f, char ch) { END_OF_FILE (f) = A68_FALSE; add_char_transput_buffer (p, TRANSPUT_BUFFER (f), ch); } /** @brief PROC (REF FILE) BOOL eof @param p Node in syntax tree. **/ void genie_eof (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } else if (READ_MOOD (file)) { int ch = char_scanner (file); PUSH_PRIMITIVE (p, (BOOL_T) ((ch == EOF_CHAR || END_OF_FILE (file)) ? A68_TRUE : A68_FALSE), A68_BOOL); unchar_scanner (p, file, (char) ch); } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief PROC (REF FILE) BOOL eoln @param p Node in syntax tree. **/ void genie_eoln (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } else if (READ_MOOD (file)) { int ch = char_scanner (file); if (END_OF_FILE (file)) { end_of_file_error (p, ref_file); } PUSH_PRIMITIVE (p, (BOOL_T) (ch == NEWLINE_CHAR ? A68_TRUE : A68_FALSE), A68_BOOL); unchar_scanner (p, file, (char) ch); } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief PROC (REF FILE) VOID new line @param p Node in syntax tree. **/ void genie_new_line (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { on_event_handler (p, LINE_END_MENDED (file), ref_file); if (IS_NIL (STRING (file))) { WRITE (FD (file), NEWLINE_STRING); } else { add_c_string_to_a_string (p, STRING (file), NEWLINE_STRING); } } else if (READ_MOOD (file)) { BOOL_T go_on = A68_TRUE; while (go_on) { int ch; if (END_OF_FILE (file)) { end_of_file_error (p, ref_file); } ch = char_scanner (file); go_on = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file)); } } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief PROC (REF FILE) VOID new page @param p Node in syntax tree. **/ void genie_new_page (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { on_event_handler (p, PAGE_END_MENDED (file), ref_file); if (IS_NIL (STRING (file))) { WRITE (FD (file), "\f"); } else { add_c_string_to_a_string (p, STRING (file), "\f"); } } else if (READ_MOOD (file)) { BOOL_T go_on = A68_TRUE; while (go_on) { int ch; if (END_OF_FILE (file)) { end_of_file_error (p, ref_file); } ch = char_scanner (file); go_on = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file)); } } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief PROC (REF FILE) VOID space @param p Node in syntax tree. **/ void genie_space (NODE_T * p) { A68_REF ref_file; A68_FILE *file; POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { WRITE (FD (file), " "); } else if (READ_MOOD (file)) { if (!END_OF_FILE (file)) { (void) char_scanner (file); } } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "undetermined"); exit_genie (p, A68_RUNTIME_ERROR); } } #define IS_NL_FF(ch) ((ch) == NEWLINE_CHAR || (ch) == FORMFEED_CHAR) /** @brief Skip new-lines and form-feeds. @param p Node in syntax tree. @param ch Pointer to scanned character. @param ref_file Fat pointer to A68 file. **/ void skip_nl_ff (NODE_T * p, int *ch, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); while ((*ch) != EOF_CHAR && IS_NL_FF (*ch)) { A68_BOOL *z = (A68_BOOL *) STACK_TOP; ADDR_T pop_sp = stack_pointer; unchar_scanner (p, f, (char) (*ch)); if (*ch == NEWLINE_CHAR) { on_event_handler (p, LINE_END_MENDED (f), ref_file); stack_pointer = pop_sp; if (VALUE (z) == A68_FALSE) { PUSH_REF (p, ref_file); genie_new_line (p); } } else if (*ch == FORMFEED_CHAR) { on_event_handler (p, PAGE_END_MENDED (f), ref_file); stack_pointer = pop_sp; if (VALUE (z) == A68_FALSE) { PUSH_REF (p, ref_file); genie_new_page (p); } } (*ch) = char_scanner (f); } } /** @brief Scan an int from file. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. **/ void scan_integer (NODE_T * p, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); int ch; reset_transput_buffer (INPUT_BUFFER); ch = char_scanner (f); while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) { if (IS_NL_FF (ch)) { skip_nl_ff (p, &ch, ref_file); } else { ch = char_scanner (f); } } if (ch != EOF_CHAR && (ch == '+' || ch == '-')) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } while (ch != EOF_CHAR && IS_DIGIT (ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } if (ch != EOF_CHAR) { unchar_scanner (p, f, (char) ch); } } /** @brief Scan a real from file. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. **/ void scan_real (NODE_T * p, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); char x_e = EXPONENT_CHAR; int ch; reset_transput_buffer (INPUT_BUFFER); ch = char_scanner (f); while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) { if (IS_NL_FF (ch)) { skip_nl_ff (p, &ch, ref_file); } else { ch = char_scanner (f); } } if (ch != EOF_CHAR && (ch == '+' || ch == '-')) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } while (ch != EOF_CHAR && IS_DIGIT (ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } if (ch == EOF_CHAR || !(ch == POINT_CHAR || TO_UPPER (ch) == TO_UPPER (x_e))) { goto salida; } if (ch == POINT_CHAR) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); while (ch != EOF_CHAR && IS_DIGIT (ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } } if (ch == EOF_CHAR || TO_UPPER (ch) != TO_UPPER (x_e)) { goto salida; } if (TO_UPPER (ch) == TO_UPPER (x_e)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); while (ch != EOF_CHAR && ch == BLANK_CHAR) { ch = char_scanner (f); } if (ch != EOF_CHAR && (ch == '+' || ch == '-')) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } while (ch != EOF_CHAR && IS_DIGIT (ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } } salida:if (ch != EOF_CHAR) { unchar_scanner (p, f, (char) ch); } } /** @brief Scan a bits from file. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. **/ void scan_bits (NODE_T * p, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); int ch, flip = FLIP_CHAR, flop = FLOP_CHAR; reset_transput_buffer (INPUT_BUFFER); ch = char_scanner (f); while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) { if (IS_NL_FF (ch)) { skip_nl_ff (p, &ch, ref_file); } else { ch = char_scanner (f); } } while (ch != EOF_CHAR && (ch == flip || ch == flop)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } if (ch != EOF_CHAR) { unchar_scanner (p, f, (char) ch); } } /** @brief Scan a char from file. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. **/ void scan_char (NODE_T * p, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); int ch; reset_transput_buffer (INPUT_BUFFER); ch = char_scanner (f); skip_nl_ff (p, &ch, ref_file); if (ch != EOF_CHAR) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); } } /** @brief Scan a string from file. @param p Node in syntax tree. @param term String with terminators. @param ref_file Fat pointer to A68 file. **/ void scan_string (NODE_T * p, char *term, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); if (END_OF_FILE (f)) { reset_transput_buffer (INPUT_BUFFER); end_of_file_error (p, ref_file); } else { BOOL_T go_on; int ch; reset_transput_buffer (INPUT_BUFFER); ch = char_scanner (f); go_on = A68_TRUE; while (go_on) { if (ch == EOF_CHAR || END_OF_FILE (f)) { if (get_transput_buffer_index (INPUT_BUFFER) == 0) { end_of_file_error (p, ref_file); } go_on = A68_FALSE; } else if (IS_NL_FF (ch)) { ADDR_T pop_sp = stack_pointer; unchar_scanner (p, f, (char) ch); if (ch == NEWLINE_CHAR) { on_event_handler (p, LINE_END_MENDED (f), ref_file); } else if (ch == FORMFEED_CHAR) { on_event_handler (p, PAGE_END_MENDED (f), ref_file); } stack_pointer = pop_sp; go_on = A68_FALSE; } else if (term != NO_TEXT && a68g_strchr (term, ch) != NO_TEXT) { go_on = A68_FALSE; unchar_scanner (p, f, (char) ch); } else { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (f); } } } } /** @brief Make temp file name. @param fn Pointer to string to hold filename. @param flags Mode to open file with. @param permissions Permissions to open file with. @return Whether file is good for use. **/ BOOL_T a68g_mkstemp (char *fn, int flags, mode_t permissions) { /* "tmpnam" is not safe, "mkstemp" is Unix, so a68g brings its own tmpnam */ #define TMP_SIZE 32 #define TRIALS 32 char tfilename[BUFFER_SIZE]; char *letters = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; int i, k, len = (int) strlen (letters); BOOL_T good_file = A68_FALSE; /* Next are prefixes to try. First we try /tmp, and if that won't go, the current dir. */ char *prefix[] = { "/tmp/a68g_", "./a68g_", NO_TEXT }; for (i = 0; prefix[i] != NO_TEXT; i ++) { for (k = 0; k < TRIALS && good_file == A68_FALSE; k++) { int j, cindex; FILE_T fd; bufcpy (tfilename, prefix[i], BUFFER_SIZE); for (j = 0; j < TMP_SIZE; j++) { char chars[2]; do { cindex = (int) (rng_53_bit () * len); } while (cindex < 0 || cindex >= len); chars[0] = letters[cindex]; chars[1] = NULL_CHAR; bufcat (tfilename, chars, BUFFER_SIZE); } bufcat (tfilename, ".tmp", BUFFER_SIZE); RESET_ERRNO; fd = open (tfilename, flags | O_EXCL, permissions); good_file = (BOOL_T) (fd != A68_NO_FILENO && errno == 0); if (good_file) { (void) close (fd); } } } if (good_file) { bufcpy (fn, tfilename, BUFFER_SIZE); return (A68_TRUE); } else { return (A68_FALSE); } #undef TMP_SIZE #undef TRIALS } /** @brief Open a file, or establish it. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param flags Required access mode. @param permissions Optional permissions. @return File number. **/ FILE_T open_physical_file (NODE_T * p, A68_REF ref_file, int flags, mode_t permissions) { A68_FILE *file; A68_REF ref_filename; char *filename; BOOL_T reading = (flags & ~O_BINARY) == A68_READ_ACCESS; BOOL_T writing = (flags & ~O_BINARY) == A68_WRITE_ACCESS; ABEND (reading == writing, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!IS_NIL (STRING (file))) { if (writing) { A68_REF z = * DEREF (A68_REF, &STRING (file)); A68_ARRAY *a; A68_TUPLE *t; GET_DESCRIPTOR (a, t, &z); UPB (t) = LWB (t) - 1; } /* Associated file */ TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p); reset_transput_buffer (TRANSPUT_BUFFER (file)); END_OF_FILE (file) = A68_FALSE; FILE_ENTRY (file) = -1; return (FD (file)); } else if (IS_NIL (IDENTIFICATION (file))) { /* No identification, so generate a unique identification. */ if (reading) { return (A68_NO_FILENO); } else { char tfilename[BUFFER_SIZE]; int len; if (!a68g_mkstemp (tfilename, flags, permissions)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NO_TEMP); exit_genie (p, A68_RUNTIME_ERROR); } FD (file) = open (tfilename, flags, permissions); len = 1 + (int) strlen (tfilename); IDENTIFICATION (file) = heap_generator (p, MODE (C_STRING), len); BLOCK_GC_HANDLE (&(IDENTIFICATION (file))); bufcpy (DEREF (char, &IDENTIFICATION (file)), tfilename, len); TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p); reset_transput_buffer (TRANSPUT_BUFFER (file)); END_OF_FILE (file) = A68_FALSE; TMP_FILE (file) = A68_TRUE; FILE_ENTRY (file) = store_file_entry (p, FD (file), tfilename, TMP_FILE (file)); return (FD (file)); } } else { /* Opening an identified file */ ref_filename = IDENTIFICATION (file); CHECK_REF (p, ref_filename, MODE (ROWS)); filename = DEREF (char, &ref_filename); if (OPEN_EXCLUSIVE (file)) { /* Establishing requires that the file does not exist */ if (flags == (A68_WRITE_ACCESS)) { flags |= O_EXCL; } OPEN_EXCLUSIVE (file) = A68_FALSE; } FD (file) = open (filename, flags, permissions); TRANSPUT_BUFFER (file) = get_unblocked_transput_buffer (p); reset_transput_buffer (TRANSPUT_BUFFER (file)); END_OF_FILE (file) = A68_FALSE; FILE_ENTRY (file) = store_file_entry (p, FD (file), filename, TMP_FILE (file)); return (FD (file)); } } /** @brief Call PROC (REF FILE) VOID during transput. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param z A68 routine to call **/ void genie_call_proc_ref_file_void (NODE_T * p, A68_REF ref_file, A68_PROCEDURE z) { ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; MOID_T *u = MODE (PROC_REF_FILE_VOID); PUSH_REF (p, ref_file); genie_call_procedure (p, MOID (&z), u, u, &z, pop_sp, pop_fp); stack_pointer = pop_sp; /* VOIDING */ } /* Unformatted transput */ /** @brief Hexadecimal value of digit. @param ch Digit. @return See brief description. **/ static int char_value (int ch) { switch (ch) { case '0': { return (0); } case '1': { return (1); } case '2': { return (2); } case '3': { return (3); } case '4': { return (4); } case '5': { return (5); } case '6': { return (6); } case '7': { return (7); } case '8': { return (8); } case '9': { return (9); } case 'A': case 'a': { return (10); } case 'B': case 'b': { return (11); } case 'C': case 'c': { return (12); } case 'D': case 'd': { return (13); } case 'E': case 'e': { return (14); } case 'F': case 'f': { return (15); } default: { return (-1); } } } /** @brief Own strtoul; some systems have no strtoul. @param str String representing an unsigned int denotation. @param end Points to first character after denotation. @param base Exponent base. @return Value of denotation in str. **/ unsigned a68g_strtoul (char *str, char **end, int base) { if (str == NO_TEXT || str[0] == NULL_CHAR) { (*end) = NO_TEXT; errno = EDOM; return (0); } else { int j, k = 0, start; char *q = str; unsigned mul = 1, sum = 0; while (IS_SPACE (q[k])) { k++; } if (q[k] == '+') { k++; } start = k; while (IS_XDIGIT (q[k])) { k++; } if (k == start) { if (end != NO_VAR) { *end = str; } errno = EDOM; return (0); } if (end != NO_VAR) { (*end) = &q[k]; } for (j = k - 1; j >= start; j--) { if (char_value (q[j]) >= base) { errno = EDOM; return (0); } else { unsigned add = (unsigned) ((unsigned) (char_value (q[j])) * mul); if (A68_MAX_UNT - sum >= add) { sum += add; mul *= (unsigned) base; } else { errno = ERANGE; return (0); } } } return (sum); } } /** @brief INT value of BITS denotation @param p Node in syntax tree. @param str String with BITS denotation. @return See brief description. **/ static unsigned bits_to_int (NODE_T * p, char *str) { int base = 0; unsigned bits = 0; char *radix = NO_TEXT, *end = NO_TEXT; RESET_ERRNO; base = (int) a68g_strtoul (str, &radix, 10); if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) { if (base < 2 || base > 16) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base); exit_genie (p, A68_RUNTIME_ERROR); } bits = a68g_strtoul (&(radix[1]), &end, base); if (end != NO_TEXT && end[0] == NULL_CHAR && errno == 0) { return (bits); } } diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (BITS)); exit_genie (p, A68_RUNTIME_ERROR); return (0); } /** @brief LONG BITS value of LONG BITS denotation @param p Node in syntax tree. @param z Multi-precision number. @param str String with LONG BITS denotation . @param m Mode of 'z'. **/ static void long_bits_to_long_int (NODE_T * p, MP_T * z, char *str, MOID_T * m) { int base = 0; char *radix = NO_TEXT; RESET_ERRNO; base = (int) a68g_strtoul (str, &radix, 10); if (radix != NO_TEXT && TO_UPPER (radix[0]) == TO_UPPER (RADIX_CHAR) && errno == 0) { int digits = DIGITS (m); ADDR_T pop_sp = stack_pointer; MP_T *v; MP_T *w; char *q = radix; STACK_MP (v, p, digits); STACK_MP (w, p, digits); while (q[0] != NULL_CHAR) { q++; } SET_MP_ZERO (z, digits); (void) set_mp_short (w, (MP_T) 1, 0, digits); if (base < 2 || base > 16) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, base); exit_genie (p, A68_RUNTIME_ERROR); } while ((--q) != radix) { int digit = char_value (q[0]); if (digit >= 0 && digit < base) { (void) mul_mp_digit (p, v, w, (MP_T) digit, digits); (void) add_mp (p, z, z, v, digits); } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m); exit_genie (p, A68_RUNTIME_ERROR); } (void) mul_mp_digit (p, w, w, (MP_T) base, digits); } check_long_bits_value (p, z, m); stack_pointer = pop_sp; } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, m); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief Convert string to required mode and store. @param p Node in syntax tree. @param m Mode to convert to. @param a String to convert. @param item Where to store result. @return Whether conversion is successful. **/ BOOL_T genie_string_to_value_internal (NODE_T * p, MOID_T * m, char *a, BYTE_T * item) { RESET_ERRNO; /* strto.. does not mind empty strings */ if (strlen (a) == 0) { return (A68_FALSE); } if (m == MODE (INT)) { A68_INT *z = (A68_INT *) item; char *end; VALUE (z) = (int) strtol (a, &end, 10); if (end[0] == NULL_CHAR && errno == 0) { STATUS (z) = INIT_MASK; return (A68_TRUE); } else { return (A68_FALSE); } } else if (m == MODE (REAL)) { A68_REAL *z = (A68_REAL *) item; char *end; VALUE (z) = strtod (a, &end); if (end[0] == NULL_CHAR && errno == 0) { STATUS (z) = INIT_MASK; return (A68_TRUE); } else { return (A68_FALSE); } } else if (m == MODE (LONG_INT) || m == MODE (LONGLONG_INT)) { int digits = DIGITS (m); MP_T *z = (MP_T *) item; if (string_to_mp (p, z, a, digits) == NO_MP) { return (A68_FALSE); } if (!check_mp_int (z, m)) { errno = ERANGE; return (A68_FALSE); } MP_STATUS (z) = (MP_T) INIT_MASK; return (A68_TRUE); } else if (m == MODE (LONG_REAL) || m == MODE (LONGLONG_REAL)) { int digits = DIGITS (m); MP_T *z = (MP_T *) item; if (string_to_mp (p, z, a, digits) == NO_MP) { return (A68_FALSE); } MP_STATUS (z) = (MP_T) INIT_MASK; return (A68_TRUE); } else if (m == MODE (BOOL)) { A68_BOOL *z = (A68_BOOL *) item; char q = a[0], flip = FLIP_CHAR, flop = FLOP_CHAR; if (q == flip || q == flop) { VALUE (z) = (BOOL_T) (q == flip); STATUS (z) = INIT_MASK; return (A68_TRUE); } else { return (A68_FALSE); } } else if (m == MODE (BITS)) { A68_BITS *z = (A68_BITS *) item; int status = A68_TRUE; if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) { /* [] BOOL denotation is "TTFFFFTFT ..." */ if (strlen (a) > (size_t) BITS_WIDTH) { errno = ERANGE; status = A68_FALSE; } else { int j = (int) strlen (a) - 1; unsigned k = 0x1; VALUE (z) = 0; for (; j >= 0; j--) { if (a[j] == FLIP_CHAR) { VALUE (z) += k; } else if (a[j] != FLOP_CHAR) { status = A68_FALSE; } k <<= 1; } } } else { /* BITS denotation is also allowed */ VALUE (z) = bits_to_int (p, a); } if (errno != 0 || status == A68_FALSE) { return (A68_FALSE); } STATUS (z) = INIT_MASK; return (A68_TRUE); } else if (m == MODE (LONG_BITS) || m == MODE (LONGLONG_BITS)) { int digits = DIGITS (m); int status = A68_TRUE; ADDR_T pop_sp = stack_pointer; MP_T *z = (MP_T *) item; if (a[0] == FLIP_CHAR || a[0] == FLOP_CHAR) { /* [] BOOL denotation is "TTFFFFTFT ..." */ if (strlen (a) > (size_t) BITS_WIDTH) { errno = ERANGE; status = A68_FALSE; } else { int j; MP_T *w; STACK_MP (w, p, digits); SET_MP_ZERO (z, digits); (void) set_mp_short (w, (MP_T) 1, 0, digits); for (j = (int) strlen (a) - 1; j >= 0; j--) { if (a[j] == FLIP_CHAR) { (void) add_mp (p, z, z, w, digits); } else if (a[j] != FLOP_CHAR) { status = A68_FALSE; } (void) mul_mp_digit (p, w, w, (MP_T) 2, digits); } } } else { /* BITS denotation is also allowed */ long_bits_to_long_int (p, z, a, m); } stack_pointer = pop_sp; if (errno != 0 || status == A68_FALSE) { return (A68_FALSE); } MP_STATUS (z) = (MP_T) INIT_MASK; return (A68_TRUE); } return (A68_FALSE); } /** @brief Convert string in input buffer to value of required mode. @param p Node in syntax tree. @param mode Mode to convert to. @param item Where to store result. @param ref_file Fat pointer to A68 file. **/ void genie_string_to_value (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { char *str = get_transput_buffer (INPUT_BUFFER); RESET_ERRNO; /* end string, just in case */ add_char_transput_buffer (p, INPUT_BUFFER, NULL_CHAR); if (mode == MODE (INT)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (REAL)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (BOOL)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (BITS)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { if (genie_string_to_value_internal (p, mode, str, item) == A68_FALSE) { value_error (p, mode, ref_file); } } else if (mode == MODE (CHAR)) { A68_CHAR *z = (A68_CHAR *) item; if (str[0] == NULL_CHAR) { /* value_error (p, mode, ref_file); */ VALUE (z) = NULL_CHAR; STATUS (z) = INIT_MASK; } else { int len = (int) strlen (str); if (len == 0 || len > 1) { value_error (p, mode, ref_file); } VALUE (z) = str[0]; STATUS (z) = INIT_MASK; } } else if (mode == MODE (STRING)) { A68_REF z; z = c_to_a_string (p, str, get_transput_buffer_index (INPUT_BUFFER) - 1); /* z = c_to_a_string (p, str, DEFAULT_WIDTH); */ *(A68_REF *) item = z; } if (errno != 0) { transput_error (p, ref_file, mode); } } /** @brief Read object from file. @param p Node in syntax tree. @param mode Mode to read. @param item Where to store result. @param ref_file Fat pointer to A68 file. **/ void genie_read_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); RESET_ERRNO; if (mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { scan_integer (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { scan_real (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == MODE (BOOL)) { scan_char (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == MODE (CHAR)) { scan_char (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == MODE (BITS) || mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { scan_bits (p, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (mode == MODE (STRING)) { char *term = DEREF (char, &TERMINATOR (f)); scan_string (p, term, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { genie_read_standard (p, MOID (q), &item[OFFSET (q)], ref_file); } } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode); exit_genie (p, A68_RUNTIME_ERROR); } genie_read_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), mode); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); genie_read_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } /** @brief PROC ([] SIMPLIN) VOID read @param p Node in syntax tree. **/ void genie_read (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_in (p); PUSH_REF (p, row); genie_read_file (p); } /** @brief Open for reading. @param p Node in syntax tree. @param ref_file File to open. **/ void open_for_reading (NODE_T * p, A68_REF ref_file) { A68_FILE *file = FILE_DEREF (&ref_file); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!GET (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if (IS_NIL (STRING (file))) { if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0)) == A68_NO_FILENO) { open_error (p, ref_file, "getting"); } } else { FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_TRUE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_TRUE; } if (!CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief PROC (REF FILE, [] SIMPLIN) VOID get @param p Node in syntax tree. **/ void genie_read_file (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLIN)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); open_for_reading (p, ref_file); /* Read */ if (elems <= 0) { return; } base_address = DEREF (BYTE_T, &ARRAY (arr)); elem_index = 0; for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & base_address[elem_index]; MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE]; if (mode == MODE (PROC_REF_FILE_VOID)) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == MODE (FORMAT)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (REF_SOUND)) { read_sound (p, ref_file, DEREF (A68_SOUND, (A68_REF *) item)); } else { if (END_OF_FILE (file)) { end_of_file_error (p, ref_file); } CHECK_REF (p, *(A68_REF *) item, mode); genie_read_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file); } elem_index += SIZE (MODE (SIMPLIN)); } } /** @brief Convert value to string. @param p Node in syntax tree. @param moid Mode to convert to. @param item Pointer to value. @param mod Format modifier. **/ void genie_value_to_string (NODE_T * p, MOID_T * moid, BYTE_T * item, int mod) { if (moid == MODE (INT)) { A68_INT *z = (A68_INT *) item; PUSH_UNION (p, MODE (INT)); PUSH_PRIMITIVE (p, VALUE (z), A68_INT); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (INT)))); if (mod == FORMAT_ITEM_G) { PUSH_PRIMITIVE (p, INT_WIDTH + 1, A68_INT); genie_whole (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, REAL_WIDTH + EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, EXP_WIDTH + 1, A68_INT); PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (LONG_INT)) { MP_T *z = (MP_T *) item; PUSH_UNION (p, MODE (LONG_INT)); PUSH (p, z, SIZE (MODE (LONG_INT))); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (LONG_INT)))); if (mod == FORMAT_ITEM_G) { PUSH_PRIMITIVE (p, LONG_WIDTH + 1, A68_INT); genie_whole (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, LONG_REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, LONG_EXP_WIDTH + 1, A68_INT); PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (LONGLONG_INT)) { MP_T *z = (MP_T *) item; PUSH_UNION (p, MODE (LONGLONG_INT)); PUSH (p, z, SIZE (MODE (LONGLONG_INT))); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (LONGLONG_INT)))); if (mod == FORMAT_ITEM_G) { PUSH_PRIMITIVE (p, LONGLONG_WIDTH + 1, A68_INT); genie_whole (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH + LONGLONG_EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, LONGLONG_EXP_WIDTH + 1, A68_INT); PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (REAL)) { A68_REAL *z = (A68_REAL *) item; PUSH_UNION (p, MODE (REAL)); PUSH_PRIMITIVE (p, VALUE (z), A68_REAL); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (REAL)))); PUSH_PRIMITIVE (p, REAL_WIDTH + EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, EXP_WIDTH + 1, A68_INT); if (mod == FORMAT_ITEM_G) { genie_float (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (LONG_REAL)) { MP_T *z = (MP_T *) item; PUSH_UNION (p, MODE (LONG_REAL)); PUSH (p, z, (int) SIZE (MODE (LONG_REAL))); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (LONG_REAL)))); PUSH_PRIMITIVE (p, LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, LONG_REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, LONG_EXP_WIDTH + 1, A68_INT); if (mod == FORMAT_ITEM_G) { genie_float (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (LONGLONG_REAL)) { MP_T *z = (MP_T *) item; PUSH_UNION (p, MODE (LONGLONG_REAL)); PUSH (p, z, (int) SIZE (MODE (LONGLONG_REAL))); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (LONGLONG_REAL)))); PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH + LONGLONG_EXP_WIDTH + 4, A68_INT); PUSH_PRIMITIVE (p, LONGLONG_REAL_WIDTH - 1, A68_INT); PUSH_PRIMITIVE (p, LONGLONG_EXP_WIDTH + 1, A68_INT); if (mod == FORMAT_ITEM_G) { genie_float (p); } else if (mod == FORMAT_ITEM_H) { PUSH_PRIMITIVE (p, 3, A68_INT); genie_real (p); } } else if (moid == MODE (BITS)) { A68_BITS *z = (A68_BITS *) item; char *str = stack_string (p, 8 + BITS_WIDTH); unsigned bit = 0x1; int j; for (j = 1; j < BITS_WIDTH; j++) { bit <<= 1; } for (j = 0; j < BITS_WIDTH; j++) { str[j] = (char) ((VALUE (z) & bit) ? FLIP_CHAR : FLOP_CHAR); bit >>= 1; } str[j] = NULL_CHAR; } else if (moid == MODE (LONG_BITS) || moid == MODE (LONGLONG_BITS)) { int bits = get_mp_bits_width (moid), word = get_mp_bits_words (moid); int cher = bits; char *str = stack_string (p, 8 + bits); ADDR_T pop_sp = stack_pointer; unsigned *row = stack_mp_bits (p, (MP_T *) item, moid); str[cher--] = NULL_CHAR; while (cher >= 0) { unsigned bit = 0x1; int j; for (j = 0; j < MP_BITS_BITS && cher >= 0; j++) { str[cher--] = (char) ((row[word - 1] & bit) ? FLIP_CHAR : FLOP_CHAR); bit <<= 1; } word--; } stack_pointer = pop_sp; } } /** @brief Print object to file. @param p Node in syntax tree. @param mode Mode of object to print. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ void genie_write_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { RESET_ERRNO; if (mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { genie_value_to_string (p, mode, item, FORMAT_ITEM_G); add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER); } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { genie_value_to_string (p, mode, item, FORMAT_ITEM_G); add_string_from_stack_transput_buffer (p, UNFORMATTED_BUFFER); } else if (mode == MODE (BOOL)) { A68_BOOL *z = (A68_BOOL *) item; char flipflop = (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR); add_char_transput_buffer (p, UNFORMATTED_BUFFER, flipflop); } else if (mode == MODE (CHAR)) { A68_CHAR *ch = (A68_CHAR *) item; add_char_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (ch)); } else if (mode == MODE (BITS) || mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { char *str = (char *) STACK_TOP; genie_value_to_string (p, mode, item, FORMAT_ITEM_G); add_string_transput_buffer (p, UNFORMATTED_BUFFER, str); } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { /* Handle these separately since this is faster than straightening */ add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item); } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; genie_write_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; genie_check_initialisation (p, elem, MOID (q)); genie_write_standard (p, MOID (q), elem, ref_file); } } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); BYTE_T *elem = &base_addr[elem_addr]; genie_check_initialisation (p, elem, SUB (deflexed)); genie_write_standard (p, SUB (deflexed), elem, ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { ABEND (IS_NIL (ref_file), "conversion error: ", error_specification ()); transput_error (p, ref_file, mode); } } /** @brief PROC ([] SIMPLOUT) VOID print, write @param p Node in syntax tree. **/ void genie_write (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_out (p); PUSH_REF (p, row); genie_write_file (p); } /** @brief Open for writing. @param p Node in syntax tree. @param ref_file File to open. **/ void open_for_writing (NODE_T * p, A68_REF ref_file) { A68_FILE *file = FILE_DEREF (&ref_file); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (!PUT (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if (IS_NIL (STRING (file))) { if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, A68_PROTECTION)) == A68_NO_FILENO) { open_error (p, ref_file, "putting"); } } else { FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, 0); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_TRUE; CHAR_MOOD (file) = A68_TRUE; } if (!CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief PROC (REF FILE, [] SIMPLOUT) VOID put @param p Node in syntax tree. **/ void genie_write_file (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLOUT)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); open_for_writing (p, ref_file); /* Write. */ if (elems <= 0) { return; } base_address = DEREF (BYTE_T, &ARRAY (arr)); elem_index = 0; for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & (base_address[elem_index]); MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE]; if (mode == MODE (PROC_REF_FILE_VOID)) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == MODE (FORMAT)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (SOUND)) { write_sound (p, ref_file, (A68_SOUND *) item); } else { reset_transput_buffer (UNFORMATTED_BUFFER); genie_write_standard (p, mode, item, ref_file); write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER); } elem_index += SIZE (MODE (SIMPLOUT)); } } /** @brief Read object binary from file. @param p Node in syntax tree. @param mode Mode to read. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void genie_read_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); RESET_ERRNO; if (mode == MODE (INT)) { A68_INT *z = (A68_INT *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { MP_T *z = (MP_T *) item; ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1); MP_STATUS (z) = (MP_T) INIT_MASK; } else if (mode == MODE (REAL)) { A68_REAL *z = (A68_REAL *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { MP_T *z = (MP_T *) item; ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1); MP_STATUS (z) = (MP_T) INIT_MASK; } else if (mode == MODE (BOOL)) { A68_BOOL *z = (A68_BOOL *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; } else if (mode == MODE (CHAR)) { A68_CHAR *z = (A68_CHAR *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; } else if (mode == MODE (BITS)) { A68_BITS *z = (A68_BITS *) item; ASSERT (io_read (FD (f), &(VALUE (z)), sizeof (VALUE (z))) != -1); STATUS (z) = INIT_MASK; } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { MP_T *z = (MP_T *) item; ASSERT (io_read (FD (f), z, (size_t) SIZE (mode)) != -1); MP_STATUS (z) = (MP_T) INIT_MASK; } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { int len, k; ASSERT (io_read (FD (f), &(len), sizeof (len)) != -1); reset_transput_buffer (UNFORMATTED_BUFFER); for (k = 0; k < len; k++) { A68_CHAR z; ASSERT (io_read (FD (f), &(VALUE (&z)), sizeof (VALUE (&z))) != -1); add_char_transput_buffer (p, UNFORMATTED_BUFFER, (char) VALUE (&z)); } *(A68_REF *) item = c_to_a_string (p, get_transput_buffer (UNFORMATTED_BUFFER), DEFAULT_WIDTH); } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; if (!(STATUS (z) | INIT_MASK) || VALUE (z) == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_VALUE, mode); exit_genie (p, A68_RUNTIME_ERROR); } genie_read_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { genie_read_bin_standard (p, MOID (q), &item[OFFSET (q)], ref_file); } } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); genie_read_bin_standard (p, SUB (deflexed), &base_addr[elem_addr], ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } /** @brief PROC ([] SIMPLIN) VOID read bin @param p Node in syntax tree. **/ void genie_read_bin (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_back (p); PUSH_REF (p, row); genie_read_bin_file (p); } /** @brief PROC (REF FILE, [] SIMPLIN) VOID get bin @param p Node in syntax tree. **/ void genie_read_bin_file (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLIN)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); ref_file = *(A68_REF *) STACK_TOP; CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!GET (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!BIN (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary getting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS | O_BINARY, 0)) == A68_NO_FILENO) { open_error (p, ref_file, "binary getting"); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_TRUE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_FALSE; } if (CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text"); exit_genie (p, A68_RUNTIME_ERROR); } /* Read */ if (elems <= 0) { return; } elem_index = 0; base_address = DEREF (BYTE_T, &ARRAY (arr)); for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & base_address[elem_index]; MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE]; if (mode == MODE (PROC_REF_FILE_VOID)) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == MODE (FORMAT)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (REF_SOUND)) { read_sound (p, ref_file, (A68_SOUND *) ADDRESS ((A68_REF *) item)); } else { if (END_OF_FILE (file)) { end_of_file_error (p, ref_file); } CHECK_REF (p, *(A68_REF *) item, mode); genie_read_bin_standard (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file); } elem_index += SIZE (MODE (SIMPLIN)); } } /** @brief Write object binary to file. @param p Node in syntax tree. @param mode Mode to write. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void genie_write_bin_standard (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { A68_FILE *f = FILE_DEREF (&ref_file); RESET_ERRNO; if (mode == MODE (INT)) { ASSERT (io_write (FD (f), &(VALUE ((A68_INT *) item)), sizeof (VALUE ((A68_INT *) item))) != -1); } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1); } else if (mode == MODE (REAL)) { ASSERT (io_write (FD (f), &(VALUE ((A68_REAL *) item)), sizeof (VALUE ((A68_REAL *) item))) != -1); } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1); } else if (mode == MODE (BOOL)) { ASSERT (io_write (FD (f), &(VALUE ((A68_BOOL *) item)), sizeof (VALUE ((A68_BOOL *) item))) != -1); } else if (mode == MODE (CHAR)) { ASSERT (io_write (FD (f), &(VALUE ((A68_CHAR *) item)), sizeof (VALUE ((A68_CHAR *) item))) != -1); } else if (mode == MODE (BITS)) { ASSERT (io_write (FD (f), &(VALUE ((A68_BITS *) item)), sizeof (VALUE ((A68_BITS *) item))) != -1); } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { ASSERT (io_write (FD (f), (MP_T *) item, (size_t) SIZE (mode)) != -1); } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { int len; reset_transput_buffer (UNFORMATTED_BUFFER); add_a_string_transput_buffer (p, UNFORMATTED_BUFFER, item); len = get_transput_buffer_index (UNFORMATTED_BUFFER); ASSERT (io_write (FD (f), &(len), sizeof (len)) != -1); WRITE (FD (f), get_transput_buffer (UNFORMATTED_BUFFER)); } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; genie_write_bin_standard (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; genie_check_initialisation (p, elem, MOID (q)); genie_write_bin_standard (p, MOID (q), elem, ref_file); } } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); BYTE_T *elem = &base_addr[elem_addr]; genie_check_initialisation (p, elem, SUB (deflexed)); genie_write_bin_standard (p, SUB (deflexed), elem, ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } /** @brief PROC ([] SIMPLOUT) VOID write bin, print bin @param p Node in syntax tree. **/ void genie_write_bin (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_back (p); PUSH_REF (p, row); genie_write_bin_file (p); } /** @brief PROC (REF FILE, [] SIMPLOUT) VOID put bin @param p Node in syntax tree. **/ void genie_write_bin_file (NODE_T * p) { A68_REF ref_file, row; A68_FILE *file; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLOUT)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); ref_file = *(A68_REF *) STACK_TOP; CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (!PUT (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!BIN (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "binary putting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS | O_BINARY, A68_PROTECTION)) == A68_NO_FILENO) { open_error (p, ref_file, "binary putting"); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_TRUE; CHAR_MOOD (file) = A68_FALSE; } if (CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "text"); exit_genie (p, A68_RUNTIME_ERROR); } if (elems <= 0) { return; } base_address = DEREF (BYTE_T, &ARRAY (arr)); elem_index = 0; for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & base_address[elem_index]; MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = (BYTE_T *) & base_address[elem_index + A68_UNION_SIZE]; if (mode == MODE (PROC_REF_FILE_VOID)) { genie_call_proc_ref_file_void (p, ref_file, *(A68_PROCEDURE *) item); } else if (mode == MODE (FORMAT)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (FORMAT)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (SOUND)) { write_sound (p, ref_file, (A68_SOUND *) item); } else { genie_write_bin_standard (p, mode, item, ref_file); } elem_index += SIZE (MODE (SIMPLOUT)); } } /* Next are formatting routines "whole", "fixed" and "float" for mode INT, LONG INT and LONG LONG INT, and REAL, LONG REAL and LONG LONG REAL. They are direct implementations of the routines described in the Revised Report, although those were only meant as a specification. The rest of Algol68G should only reference "genie_whole", "genie_fixed" or "genie_float" since internal routines like "sub_fixed" may leave the stack corrupted when called directly. */ /** @brief Generate a string of error chars. @param s String to store error chars. @param n Number of error chars. @return See brief description. **/ char *error_chars (char *s, int n) { int k = (n != 0 ? ABS (n) : 1); s[k] = NULL_CHAR; while (--k >= 0) { s[k] = ERROR_CHAR; } return (s); } /** @brief Convert temporary C string to A68 string. @param p Node in syntax tree. @param temp_string Temporary C string. @return See brief description. **/ A68_REF tmp_to_a68_string (NODE_T * p, char *temp_string) { A68_REF z; /* no compaction allowed since temp_string might be up for garbage collecting .. */ z = c_to_a_string (p, temp_string, DEFAULT_WIDTH); return (z); } /** @brief Add c to str, assuming that "str" is large enough. @param c Char to add before string. @param str String to add in front of. @return String. **/ static char *plusto (char c, char *str) { MOVE (&str[1], &str[0], (unsigned) (strlen (str) + 1)); str[0] = c; return (str); } /** @brief Add c to str, assuming that "str" is large enough. @param str String to add to. @param c Char to add. @param strwid Width of 'str'. @return String. **/ char *string_plusab_char (char *str, char c, int strwid) { char z[2]; z[0] = c; z[1] = NULL_CHAR; bufcat (str, z, strwid); return (str); } /** @brief Add leading spaces to str until length is width. @param str String to add in front of. @param width Required width of 'str'. @return String. **/ static char *leading_spaces (char *str, int width) { int j = width - (int) strlen (str); while (--j >= 0) { (void) plusto (BLANK_CHAR, str); } return (str); } /** @brief Convert int to char using a table. @param k Int to convert. @return Character. **/ static char digchar (int k) { char *s = "0123456789abcdef"; if (k >= 0 && k < (int) strlen (s)) { return (s[k]); } else { return (ERROR_CHAR); } } /** @brief Standard string for LONG INT. @param p Node in syntax tree. @param m Mp number. @param digits Digits. @param width Width. @return See brief description. **/ char *long_sub_whole (NODE_T * p, MP_T * m, int digits, int width) { ADDR_T pop_sp; char *s; MP_T *n; int len = 0; s = stack_string (p, 8 + width); s[0] = NULL_CHAR; pop_sp = stack_pointer; STACK_MP (n, p, digits); MOVE_MP (n, m, digits); do { if (len < width) { /* Sic transit gloria mundi */ int n_mod_10 = (int) MP_DIGIT (n, (int) (1 + MP_EXPONENT (n))) % 10; (void) plusto (digchar (n_mod_10), s); } len++; (void) over_mp_digit (p, n, n, (MP_T) 10, digits); } while (MP_DIGIT (n, 1) > 0); if (len > width) { (void) error_chars (s, width); } stack_pointer = pop_sp; return (s); } /** @brief Standard string for INT. @param p Node in syntax tree. @param n Value. @param width Width. @return See brief description. **/ char *sub_whole (NODE_T * p, int n, int width) { char *s = stack_string (p, 8 + width); int len = 0; s[0] = NULL_CHAR; do { if (len < width) { (void) plusto (digchar (n % 10), s); } len++; n /= 10; } while (n != 0); if (len > width) { (void) error_chars (s, width); } return (s); } /** @brief Formatted string for NUMBER. @param p Node in syntax tree. @return String. **/ char *whole (NODE_T * p) { int pop_sp, arg_sp; A68_INT width; MOID_T *mode; POP_OBJECT (p, &width, A68_INT); arg_sp = stack_pointer; DECREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER))); pop_sp = stack_pointer; mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP)); if (mode == MODE (INT)) { int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE))); int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0); int n = ABS (x); int size = (x < 0 ? 1 : (VALUE (&width) > 0 ? 1 : 0)); char *s; if (VALUE (&width) == 0) { int m = n; length = 0; while ((m /= 10, length++, m != 0)) { ; } } size += length; size = 8 + (size > VALUE (&width) ? size : VALUE (&width)); s = stack_string (p, size); bufcpy (s, sub_whole (p, n, length), size); if (length == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) { (void) error_chars (s, VALUE (&width)); } else { if (x < 0) { (void) plusto ('-', s); } else if (VALUE (&width) > 0) { (void) plusto ('+', s); } if (VALUE (&width) != 0) { (void) leading_spaces (s, ABS (VALUE (&width))); } } return (s); } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { int digits = DIGITS (mode); int length, size; char *s; MP_T *n = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE)); BOOL_T ltz; stack_pointer = arg_sp; /* We keep the mp where it's at */ if (MP_EXPONENT (n) >= (MP_T) digits) { int max_length = (mode == MODE (LONG_INT) ? LONG_INT_WIDTH : LONGLONG_INT_WIDTH); length = (VALUE (&width) == 0 ? max_length : VALUE (&width)); s = stack_string (p, 1 + length); (void) error_chars (s, length); return (s); } ltz = (BOOL_T) (MP_DIGIT (n, 1) < 0); length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0); size = (ltz ? 1 : (VALUE (&width) > 0 ? 1 : 0)); MP_DIGIT (n, 1) = ABS (MP_DIGIT (n, 1)); if (VALUE (&width) == 0) { MP_T *m; STACK_MP (m, p, digits); MOVE_MP (m, n, digits); length = 0; while ((over_mp_digit (p, m, m, (MP_T) 10, digits), length++, MP_DIGIT (m, 1) != 0)) { ; } } size += length; size = 8 + (size > VALUE (&width) ? size : VALUE (&width)); s = stack_string (p, size); bufcpy (s, long_sub_whole (p, n, digits, length), size); if (length == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) { (void) error_chars (s, VALUE (&width)); } else { if (ltz) { (void) plusto ('-', s); } else if (VALUE (&width) > 0) { (void) plusto ('+', s); } if (VALUE (&width) != 0) { (void) leading_spaces (s, ABS (VALUE (&width))); } } return (s); } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER))); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, 0, A68_INT); return (fixed (p)); } return (NO_TEXT); } /** @brief Fetch next digit from LONG. @param p Node in syntax tree. @param y Mp number. @param digits Digits. @return Next digit. **/ static char long_choose_dig (NODE_T * p, MP_T * y, int digits) { /* Assuming positive "y" */ int pop_sp = stack_pointer, c; MP_T *t; STACK_MP (t, p, digits); (void) mul_mp_digit (p, y, y, (MP_T) 10, digits); c = MP_EXPONENT (y) == 0 ? (int) MP_DIGIT (y, 1) : 0; if (c > 9) { c = 9; } (void) set_mp_short (t, (MP_T) c, 0, digits); (void) sub_mp (p, y, y, t, digits); /* Reset the stack to prevent overflow, there may be many digits */ stack_pointer = pop_sp; return (digchar (c)); } /** @brief Standard string for LONG. @param p Node in syntax tree. @param x Mp digit. @param digits Digits. @param width Width. @param after After. @return See brief description. **/ char *long_sub_fixed (NODE_T * p, MP_T * x, int digits, int width, int after) { int strwid = 8 + width; char *str = stack_string (p, strwid); int before = 0, j, len, pop_sp = stack_pointer; BOOL_T overflow; MP_T *y; MP_T *s; MP_T *t; STACK_MP (y, p, digits); STACK_MP (s, p, digits); STACK_MP (t, p, digits); (void) set_mp_short (t, (MP_T) (MP_RADIX / 10), -1, digits); (void) pow_mp_int (p, t, t, after, digits); (void) div_mp_digit (p, t, t, (MP_T) 2, digits); (void) add_mp (p, y, x, t, digits); (void) set_mp_short (s, (MP_T) 1, 0, digits); while ((sub_mp (p, t, y, s, digits), MP_DIGIT (t, 1) >= 0)) { before++; (void) mul_mp_digit (p, s, s, (MP_T) 10, digits); } (void) div_mp (p, y, y, s, digits); str[0] = NULL_CHAR; len = 0; overflow = A68_FALSE; for (j = 0; j < before && !overflow; j++) { if (!(overflow = (BOOL_T) (len >= width))) { (void) string_plusab_char (str, long_choose_dig (p, y, digits), strwid); len++; } } if (after > 0 && !(overflow = (BOOL_T) (len >= width))) { (void) string_plusab_char (str, POINT_CHAR, strwid); } for (j = 0; j < after && !overflow; j++) { if (!(overflow = (BOOL_T) (len >= width))) { (void) string_plusab_char (str, long_choose_dig (p, y, digits), strwid); len++; } } if (overflow || (int) strlen (str) > width) { (void) error_chars (str, width); } stack_pointer = pop_sp; return (str); } /** @brief Fetch next digit from REAL. @param y Value. @return Next digit. **/ static char choose_dig (double *y) { /* Assuming positive "y" */ int c = (int) (*y *= 10); if (c > 9) { c = 9; } *y -= c; return (digchar (c)); } /** @brief Standard string for REAL. @param p Node in syntax tree. @param x Value. @param width Width. @param after After. @return String. **/ char *sub_fixed (NODE_T * p, double x, int width, int after) { int strwid = 8 + width; char *str = stack_string (p, strwid); int before = 0, j, len, expo; BOOL_T overflow; double y, z; /* Round and scale */ z = y = x + 0.5 * ten_up (-after); expo = 0; while (z >= 1) { expo++; z /= 10; } before += expo; /* Trick to avoid overflow */ if (expo > 30) { expo -= 30; y /= ten_up (30); } /* Scale number */ y /= ten_up (expo); len = 0; /* Put digits, prevent garbage from overstretching precision */ overflow = A68_FALSE; for (j = 0; j < before && !overflow; j++) { if (!(overflow = (BOOL_T) (len >= width))) { char ch = (char) (len < REAL_WIDTH ? choose_dig (&y) : '0'); (void) string_plusab_char (str, ch, strwid); len++; } } if (after > 0 && !(overflow = (BOOL_T) (len >= width))) { (void) string_plusab_char (str, POINT_CHAR, strwid); } for (j = 0; j < after && !overflow; j++) { if (!(overflow = (BOOL_T) (len >= width))) { char ch = (char) (len < REAL_WIDTH ? choose_dig (&y) : '0'); (void) string_plusab_char (str, ch, strwid); len++; } } if (overflow || (int) strlen (str) > width) { (void) error_chars (str, width); } return (str); } /** @brief Formatted string for NUMBER. @param p Node in syntax tree. @return String. **/ char *fixed (NODE_T * p) { A68_INT width, after; MOID_T *mode; int pop_sp, arg_sp; POP_OBJECT (p, &after, A68_INT); POP_OBJECT (p, &width, A68_INT); arg_sp = stack_pointer; DECREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER))); mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP)); pop_sp = stack_pointer; if (mode == MODE (REAL)) { double x = VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE))); int length = ABS (VALUE (&width)) - (x < 0 || VALUE (&width) > 0 ? 1 : 0); char *s; CHECK_REAL_REPRESENTATION (p, x); stack_pointer = arg_sp; if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) { double y = ABS (x), z0, z1; if (VALUE (&width) == 0) { length = (VALUE (&after) == 0 ? 1 : 0); z0 = ten_up (-VALUE (&after)); z1 = ten_up (length); while (y + 0.5 * z0 > z1) { length++; z1 *= 10.0; } length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1); } s = stack_string (p, 8 + length); s = sub_fixed (p, y, length, VALUE (&after)); if (a68g_strchr (s, ERROR_CHAR) == NO_TEXT) { if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && y < 1.0) { (void) plusto ('0', s); } if (x < 0) { (void) plusto ('-', s); } else if (VALUE (&width) > 0) { (void) plusto ('+', s); } if (VALUE (&width) != 0) { (void) leading_spaces (s, ABS (VALUE (&width))); } return (s); } else if (VALUE (&after) > 0) { stack_pointer = arg_sp; PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after) - 1, A68_INT); return (fixed (p)); } else { return (error_chars (s, VALUE (&width))); } } else { s = stack_string (p, 8 + ABS (VALUE (&width))); return (error_chars (s, VALUE (&width))); } } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { int digits = DIGITS (mode); int length; BOOL_T ltz; char *s; MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE)); stack_pointer = arg_sp; ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0); MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1)); length = ABS (VALUE (&width)) - (ltz || VALUE (&width) > 0 ? 1 : 0); if (VALUE (&after) >= 0 && (length > VALUE (&after) || VALUE (&width) == 0)) { MP_T *z0; MP_T *z1; MP_T *t; STACK_MP (z0, p, digits); STACK_MP (z1, p, digits); STACK_MP (t, p, digits); if (VALUE (&width) == 0) { length = (VALUE (&after) == 0 ? 1 : 0); (void) set_mp_short (z0, (MP_T) (MP_RADIX / 10), -1, digits); (void) set_mp_short (z1, (MP_T) 10, 0, digits); (void) pow_mp_int (p, z0, z0, VALUE (&after), digits); (void) pow_mp_int (p, z1, z1, length, digits); while ((div_mp_digit (p, t, z0, (MP_T) 2, digits), add_mp (p, t, x, t, digits), sub_mp (p, t, t, z1, digits), MP_DIGIT (t, 1) > 0)) { length++; (void) mul_mp_digit (p, z1, z1, (MP_T) 10, digits); } length += (VALUE (&after) == 0 ? 0 : VALUE (&after) + 1); } s = stack_string (p, 8 + length); s = long_sub_fixed (p, x, digits, length, VALUE (&after)); if (a68g_strchr (s, ERROR_CHAR) == NO_TEXT) { if (length > (int) strlen (s) && (s[0] != NULL_CHAR ? s[0] == POINT_CHAR : A68_TRUE) && (MP_EXPONENT (x) < 0 || MP_DIGIT (x, 1) == 0)) { (void) plusto ('0', s); } if (ltz) { (void) plusto ('-', s); } else if (VALUE (&width) > 0) { (void) plusto ('+', s); } if (VALUE (&width) != 0) { (void) leading_spaces (s, ABS (VALUE (&width))); } return (s); } else if (VALUE (&after) > 0) { stack_pointer = arg_sp; MP_DIGIT (x, 1) = ltz ? -ABS (MP_DIGIT (x, 1)) : ABS (MP_DIGIT (x, 1)); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after) - 1, A68_INT); return (fixed (p)); } else { return (error_chars (s, VALUE (&width))); } } else { s = stack_string (p, 8 + ABS (VALUE (&width))); return (error_chars (s, VALUE (&width))); } } else if (mode == MODE (INT)) { int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE))); PUSH_UNION (p, MODE (REAL)); PUSH_PRIMITIVE (p, (double) x, A68_REAL); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (REAL)))); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); return (fixed (p)); } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { stack_pointer = pop_sp; if (mode == MODE (LONG_INT)) { VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONG_REAL); } else { VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONGLONG_REAL); } INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER))); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); return (fixed (p)); } return (NO_TEXT); } /** @brief Scale LONG for formatting. @param p Node in syntax tree. @param y Mp number. @param digits Digits. @param before Before. @param after After. @param q Int multiplier. **/ void long_standardise (NODE_T * p, MP_T * y, int digits, int before, int after, int *q) { int j, pop_sp = stack_pointer; MP_T *f; MP_T *g; MP_T *h; MP_T *t; STACK_MP (f, p, digits); STACK_MP (g, p, digits); STACK_MP (h, p, digits); STACK_MP (t, p, digits); (void) set_mp_short (g, (MP_T) 1, 0, digits); for (j = 0; j < before; j++) { (void) mul_mp_digit (p, g, g, (MP_T) 10, digits); } (void) div_mp_digit (p, h, g, (MP_T) 10, digits); /* Speed huge exponents */ if ((MP_EXPONENT (y) - MP_EXPONENT (g)) > 1) { (*q) += LOG_MP_BASE * ((int) MP_EXPONENT (y) - (int) MP_EXPONENT (g) - 1); MP_EXPONENT (y) = MP_EXPONENT (g) + 1; } while ((sub_mp (p, t, y, g, digits), MP_DIGIT (t, 1) >= 0)) { (void) div_mp_digit (p, y, y, (MP_T) 10, digits); (*q)++; } if (MP_DIGIT (y, 1) != 0) { /* Speed huge exponents */ if ((MP_EXPONENT (y) - MP_EXPONENT (h)) < -1) { (*q) -= LOG_MP_BASE * ((int) MP_EXPONENT (h) - (int) MP_EXPONENT (y) - 1); MP_EXPONENT (y) = MP_EXPONENT (h) - 1; } while ((sub_mp (p, t, y, h, digits), MP_DIGIT (t, 1) < 0)) { (void) mul_mp_digit (p, y, y, (MP_T) 10, digits); (*q)--; } } (void) set_mp_short (f, (MP_T) 1, 0, digits); for (j = 0; j < after; j++) { (void) div_mp_digit (p, f, f, (MP_T) 10, digits); } (void) div_mp_digit (p, t, f, (MP_T) 2, digits); (void) add_mp (p, t, y, t, digits); (void) sub_mp (p, t, t, g, digits); if (MP_DIGIT (t, 1) >= 0) { MOVE_MP (y, h, digits); (*q)++; } stack_pointer = pop_sp; } /** @brief Scale REAL for formatting. @param y Value. @param before Before. @param after After. @param p Int multiplier. **/ void standardise (double *y, int before, int after, int *p) { int j; double f, g = 1.0, h; for (j = 0; j < before; j++) { g *= 10.0; } h = g / 10.0; while (*y >= g) { *y *= 0.1; (*p)++; } if (*y != 0.0) { while (*y < h) { *y *= 10.0; (*p)--; } } f = 1.0; for (j = 0; j < after; j++) { f *= 0.1; } if (*y + 0.5 * f >= g) { *y = h; (*p)++; } } /** @brief Formatted string for NUMBER. @param p Node in syntax tree. @return String. **/ char *real (NODE_T * p) { int pop_sp, arg_sp; A68_INT width, after, expo, frmt; MOID_T *mode; /* POP arguments */ POP_OBJECT (p, &frmt, A68_INT); POP_OBJECT (p, &expo, A68_INT); POP_OBJECT (p, &after, A68_INT); POP_OBJECT (p, &width, A68_INT); arg_sp = stack_pointer; DECREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER))); mode = (MOID_T *) (VALUE ((A68_UNION *) STACK_TOP)); pop_sp = stack_pointer; if (mode == MODE (REAL)) { double x = VALUE ((A68_REAL *) (STACK_OFFSET (A68_UNION_SIZE))); int before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2; CHECK_REAL_REPRESENTATION (p, x); stack_pointer = arg_sp; #if defined HAVE_IEEE_754 if (NOT_A_REAL (x)) { char *s = stack_string (p, 8 + ABS (VALUE (&width))); return (error_chars (s, VALUE (&width))); } #endif /* */ if (SIGN (before) + SIGN (VALUE (&after)) > 0) { int strwid; char *s, *t1, *t2; double y = ABS (x); int q = 0; standardise (&y, before, VALUE (&after), &q); if (VALUE (&frmt) > 0) { while (q % VALUE (&frmt) != 0) { y *= 10; q--; if (VALUE (&after) > 0) { VALUE (&after)--; } } } else { double upb = ten_up (-VALUE (&frmt)), lwb = ten_up (-VALUE (&frmt) - 1); while (y < lwb) { y *= 10; q--; if (VALUE (&after) > 0) { VALUE (&after)--; } } while (y > upb) { y /= 10; q++; if (VALUE (&after) > 0) { VALUE (&after)++; } } } PUSH_UNION (p, MODE (REAL)); PUSH_PRIMITIVE (p, SIGN (x) * y, A68_REAL); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (REAL)))); PUSH_PRIMITIVE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); t1 = fixed (p); PUSH_UNION (p, MODE (INT)); PUSH_PRIMITIVE (p, q, A68_INT); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (INT)))); PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT); t2 = whole (p); strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2); s = stack_string (p, strwid); bufcpy (s, t1, strwid); (void) string_plusab_char (s, EXPONENT_CHAR, strwid); bufcat (s, t2, strwid); if (VALUE (&expo) == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) { stack_pointer = arg_sp; PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT); PUSH_PRIMITIVE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT); PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT); return (real (p)); } else { return (s); } } else { char *s = stack_string (p, 8 + ABS (VALUE (&width))); return (error_chars (s, VALUE (&width))); } } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { int digits = DIGITS (mode); int before; MP_T *x = (MP_T *) (STACK_OFFSET (A68_UNION_SIZE)); BOOL_T ltz = (BOOL_T) (MP_DIGIT (x, 1) < 0); stack_pointer = arg_sp; MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1)); before = ABS (VALUE (&width)) - ABS (VALUE (&expo)) - (VALUE (&after) != 0 ? VALUE (&after) + 1 : 0) - 2; if (SIGN (before) + SIGN (VALUE (&after)) > 0) { int strwid; char *s, *t1, *t2; MP_T *z; int q = 0; STACK_MP (z, p, digits); MOVE_MP (z, x, digits); long_standardise (p, z, digits, before, VALUE (&after), &q); if (VALUE (&frmt) > 0) { while (q % VALUE (&frmt) != 0) { (void) mul_mp_digit (p, z, z, (MP_T) 10, digits); q--; if (VALUE (&after) > 0) { VALUE (&after)--; } } } else { MP_T *dif, *lim; ADDR_T sp1 = stack_pointer; STACK_MP (dif, p, digits); STACK_MP (lim, p, digits); (void) mp_ten_up (p, lim, -VALUE (&frmt) - 1, digits); (void) sub_mp (p, dif, z, lim, digits); while (MP_DIGIT (dif, 1) < 0) { (void) mul_mp_digit (p, z, z, (MP_T) 10, digits); q--; if (VALUE (&after) > 0) { VALUE (&after)--; } (void) sub_mp (p, dif, z, lim, digits); } (void) mul_mp_digit (p, lim, lim, (MP_T) 10, digits); (void) sub_mp (p, dif, z, lim, digits); while (MP_DIGIT (dif, 1) > 0) { (void) div_mp_digit (p, z, z, (MP_T) 10, digits); q++; if (VALUE (&after) > 0) { VALUE (&after)++; } (void) sub_mp (p, dif, z, lim, digits); } stack_pointer = sp1; } PUSH_UNION (p, mode); MP_DIGIT (z, 1) = (ltz ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1)); PUSH (p, z, SIZE_MP (digits)); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE_MP (digits))); PUSH_PRIMITIVE (p, SIGN (VALUE (&width)) * (ABS (VALUE (&width)) - ABS (VALUE (&expo)) - 1), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); t1 = fixed (p); PUSH_UNION (p, MODE (INT)); PUSH_PRIMITIVE (p, q, A68_INT); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (INT)))); PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT); t2 = whole (p); strwid = 8 + (int) strlen (t1) + 1 + (int) strlen (t2); s = stack_string (p, strwid); bufcpy (s, t1, strwid); (void) string_plusab_char (s, EXPONENT_CHAR, strwid); bufcat (s, t2, strwid); if (VALUE (&expo) == 0 || a68g_strchr (s, ERROR_CHAR) != NO_TEXT) { stack_pointer = arg_sp; PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after) != 0 ? VALUE (&after) - 1 : 0, A68_INT); PUSH_PRIMITIVE (p, VALUE (&expo) > 0 ? VALUE (&expo) + 1 : VALUE (&expo) - 1, A68_INT); PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT); return (real (p)); } else { return (s); } } else { char *s = stack_string (p, 8 + ABS (VALUE (&width))); return (error_chars (s, VALUE (&width))); } } else if (mode == MODE (INT)) { int x = VALUE ((A68_INT *) (STACK_OFFSET (A68_UNION_SIZE))); PUSH_UNION (p, MODE (REAL)); PUSH_PRIMITIVE (p, (double) x, A68_REAL); INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER)) - (A68_UNION_SIZE + SIZE (MODE (REAL)))); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT); PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT); return (real (p)); } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { stack_pointer = pop_sp; if (mode == MODE (LONG_INT)) { VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONG_REAL); } else { VALUE ((A68_UNION *) STACK_TOP) = (void *) MODE (LONGLONG_REAL); } INCREMENT_STACK_POINTER (p, SIZE (MODE (NUMBER))); PUSH_PRIMITIVE (p, VALUE (&width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&after), A68_INT); PUSH_PRIMITIVE (p, VALUE (&expo), A68_INT); PUSH_PRIMITIVE (p, VALUE (&frmt), A68_INT); return (real (p)); } return (NO_TEXT); } /** @brief PROC (NUMBER, INT) STRING whole @param p Node in syntax tree. **/ void genie_whole (NODE_T * p) { int pop_sp = stack_pointer; A68_REF ref; char *str = whole (p); stack_pointer = pop_sp - SIZE (MODE (INT)) - SIZE (MODE (NUMBER)); ref = tmp_to_a68_string (p, str); PUSH_REF (p, ref); } /** @brief PROC (NUMBER, INT, INT) STRING fixed @param p Node in syntax tree. **/ void genie_fixed (NODE_T * p) { int pop_sp = stack_pointer; A68_REF ref; char *str = fixed (p); stack_pointer = pop_sp - 2 * SIZE (MODE (INT)) - SIZE (MODE (NUMBER)); ref = tmp_to_a68_string (p, str); PUSH_REF (p, ref); } /** @brief PROC (NUMBER, INT, INT, INT) STRING eng @param p Node in syntax tree. **/ void genie_real (NODE_T * p) { int pop_sp = stack_pointer; A68_REF ref; char *str = real (p); stack_pointer = pop_sp - 4 * SIZE (MODE (INT)) - SIZE (MODE (NUMBER)); ref = tmp_to_a68_string (p, str); PUSH_REF (p, ref); } /** @brief PROC (NUMBER, INT, INT, INT) STRING float @param p Node in syntax tree. **/ void genie_float (NODE_T * p) { PUSH_PRIMITIVE (p, 1, A68_INT); genie_real (p); } /* ALGOL68C routines */ /** @def A68C_TRANSPUT @brief Generate Algol68C routines readint, getint, etcetera. **/ #define A68C_TRANSPUT(n, m)\ void genie_get_##n (NODE_T * p) {\ A68_REF ref_file;\ ADDR_T pop_sp;\ BYTE_T *z;\ POP_REF (p, &ref_file);\ CHECK_REF (p, ref_file, MODE (REF_FILE));\ z = STACK_TOP;\ INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\ pop_sp = stack_pointer;\ open_for_reading (p, ref_file);\ genie_read_standard (p, MODE (m), z, ref_file);\ stack_pointer = pop_sp;}\ void genie_put_##n (NODE_T * p) {\ int size = SIZE (MODE (m)), sizf = SIZE (MODE (REF_FILE));\ A68_REF ref_file = * (A68_REF *) STACK_OFFSET (- (size + sizf));\ CHECK_REF (p, ref_file, MODE (REF_FILE));\ reset_transput_buffer (UNFORMATTED_BUFFER);\ open_for_writing (p, ref_file);\ genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\ write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\ DECREMENT_STACK_POINTER (p, size + sizf);}\ void genie_read_##n (NODE_T * p) {\ ADDR_T pop_sp;\ BYTE_T *z = STACK_TOP;\ INCREMENT_STACK_POINTER (p, SIZE (MODE (m)));\ pop_sp = stack_pointer;\ open_for_reading (p, stand_in);\ genie_read_standard (p, MODE (m), z, stand_in);\ stack_pointer = pop_sp;}\ void genie_print_##n (NODE_T * p) {\ int size = SIZE (MODE (m));\ reset_transput_buffer (UNFORMATTED_BUFFER);\ open_for_writing (p, stand_out);\ genie_write_standard (p, MODE (m), STACK_OFFSET (-size), stand_out);\ write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER);\ DECREMENT_STACK_POINTER (p, size);} A68C_TRANSPUT (int, INT) A68C_TRANSPUT (long_int, LONG_INT) A68C_TRANSPUT (longlong_int, LONGLONG_INT) A68C_TRANSPUT (real, REAL) A68C_TRANSPUT (long_real, LONG_REAL) A68C_TRANSPUT (longlong_real, LONGLONG_REAL) A68C_TRANSPUT (bits, BITS) A68C_TRANSPUT (long_bits, LONG_BITS) A68C_TRANSPUT (longlong_bits, LONGLONG_BITS) A68C_TRANSPUT (bool, BOOL) A68C_TRANSPUT (char, CHAR) A68C_TRANSPUT (string, STRING) #undef A68C_TRANSPUT #define A68C_TRANSPUT(n, s, m)\ void genie_get_##n (NODE_T * p) {\ A68_REF ref_file;\ POP_REF (p, &ref_file);\ CHECK_REF (p, ref_file, MODE (REF_FILE));\ PUSH_REF (p, ref_file);\ genie_get_##s (p);\ PUSH_REF (p, ref_file);\ genie_get_##s (p);}\ void genie_put_##n (NODE_T * p) {\ int size = SIZE (MODE (m)), sizf = SIZE (MODE (REF_FILE));\ A68_REF ref_file = * (A68_REF *) STACK_OFFSET (- (size + sizf));\ CHECK_REF (p, ref_file, MODE (REF_FILE));\ reset_transput_buffer (UNFORMATTED_BUFFER);\ open_for_writing (p, ref_file);\ genie_write_standard (p, MODE (m), STACK_OFFSET (-size), ref_file);\ write_purge_buffer (p, ref_file, UNFORMATTED_BUFFER);\ DECREMENT_STACK_POINTER (p, size + sizf);}\ void genie_read_##n (NODE_T * p) {\ genie_read_##s (p);\ genie_read_##s (p);}\ void genie_print_##n (NODE_T * p) {\ int size = SIZE (MODE (m));\ reset_transput_buffer (UNFORMATTED_BUFFER);\ open_for_writing (p, stand_out);\ genie_write_standard (p, MODE (m), STACK_OFFSET (-size), stand_out);\ write_purge_buffer (p, stand_out, UNFORMATTED_BUFFER);\ DECREMENT_STACK_POINTER (p, size);} A68C_TRANSPUT(complex, real, COMPLEX) A68C_TRANSPUT(long_complex, long_real, LONG_COMPLEX) A68C_TRANSPUT(longlong_complex, longlong_real, LONGLONG_COMPLEX) #undef A68C_TRANSPUT /** @brief PROC STRING read line @param p Node in syntax tree. **/ void genie_read_line (NODE_T * p) { #if defined HAVE_READLINE char * line = readline (""); if (line != NO_TEXT && (int) strlen (line) > 0) { add_history (line); } PUSH_REF (p, c_to_a_string (p, line, DEFAULT_WIDTH)); free (line); #else genie_read_string (p); genie_stand_in (p); genie_new_line (p); #endif } /* Transput library - Formatted transput In Algol68G, a value of mode FORMAT looks like a routine text. The value comprises a pointer to its environment in the stack, and a pointer where the format text is at in the syntax tree. */ #define INT_DIGITS "0123456789" #define BITS_DIGITS "0123456789abcdefABCDEF" #define INT_DIGITS_BLANK " 0123456789" #define BITS_DIGITS_BLANK " 0123456789abcdefABCDEF" #define SIGN_DIGITS " +-" /** @brief Handle format error event. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param diag Diagnostic text. **/ void format_error (NODE_T * p, A68_REF ref_file, char *diag) { A68_FILE *f = FILE_DEREF (&ref_file); A68_BOOL z; on_event_handler (p, FORMAT_ERROR_MENDED (f), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, diag); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief Initialise processing of pictures. @param p Node in syntax tree. **/ static void initialise_collitems (NODE_T * p) { /* Every picture has a counter that says whether it has not been used OR the number of times it can still be used. */ for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PICTURE)) { A68_COLLITEM *z = (A68_COLLITEM *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (p))); STATUS (z) = INIT_MASK; COUNT (z) = ITEM_NOT_USED; } /* Don't dive into f, g, n frames and collections */ if (!(IS (p, ENCLOSED_CLAUSE) || IS (p, COLLECTION))) { initialise_collitems (SUB (p)); } } } /** @brief Initialise processing of format text. @param p Node in syntax tree. @param ref_file File. @param fmt Format. @param embedded Whether embedded format. @param init Whether to initialise collitems. **/ static void open_format_frame (NODE_T * p, A68_REF ref_file, A68_FORMAT * fmt, BOOL_T embedded, BOOL_T init) { /* Open a new frame for the format text and save for return to embedding one */ A68_FILE *file = FILE_DEREF (&ref_file); NODE_T *dollar; A68_FORMAT *save; /* Integrity check */ if ((STATUS (fmt) & SKIP_FORMAT_MASK) || (BODY (fmt) == NO_NODE)) { format_error (p, ref_file, ERROR_FORMAT_UNDEFINED); } /* Ok, seems usable */ dollar = SUB (BODY (fmt)); OPEN_PROC_FRAME (dollar, ENVIRON (fmt)); INIT_STATIC_FRAME (dollar); /* Save old format */ save = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar))); *save = (embedded == EMBEDDED_FORMAT ? FORMAT (file) : nil_format); FORMAT (file) = *fmt; /* Reset all collitems */ if (init) { initialise_collitems (dollar); } } /** @brief Handle end-of-format event. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @return Whether format is embedded. **/ int end_of_format (NODE_T * p, A68_REF ref_file) { /* Format-items return immediately to the embedding format text. The outermost format text calls "on format end". */ A68_FILE *file = FILE_DEREF (&ref_file); NODE_T *dollar = SUB (BODY (&FORMAT (file))); A68_FORMAT *save = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar))); if (IS_NIL_FORMAT (save)) { /* Not embedded, outermost format: execute event routine */ A68_BOOL z; on_event_handler (p, FORMAT_END_MENDED (FILE_DEREF (&ref_file)), ref_file); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { /* Restart format */ frame_pointer = FRAME_POINTER (file); stack_pointer = STACK_POINTER (file); open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_TRUE); } return (NOT_EMBEDDED_FORMAT); } else { /* Embedded format, return to embedding format, cf. RR */ CLOSE_FRAME; FORMAT (file) = *save; return (EMBEDDED_FORMAT); } } /** @brief Return integral value of replicator. @param p Node in syntax tree. @param check Whether to check value of replicator. @return See brief description. **/ int get_replicator_value (NODE_T * p, BOOL_T check) { int z = 0; if (IS (p, STATIC_REPLICATOR)) { A68_INT u; if (genie_string_to_value_internal (p, MODE (INT), NSYMBOL (p), (BYTE_T *) & u) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); } z = VALUE (&u); } else if (IS (p, DYNAMIC_REPLICATOR)) { A68_INT u; EXECUTE_UNIT (NEXT_SUB (p)); POP_OBJECT (p, &u, A68_INT); z = VALUE (&u); } else if (IS (p, REPLICATOR)) { z = get_replicator_value (SUB (p), check); } /* Not conform RR as Andrew Herbert rightfully pointed out. if (check && z < 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INVALID_REPLICATOR); exit_genie (p, A68_RUNTIME_ERROR); } */ if (z < 0) { z = 0; } return (z); } /** @brief Return first available pattern. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @return See brief description. **/ static NODE_T *scan_format_pattern (NODE_T * p, A68_REF ref_file) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PICTURE_LIST)) { NODE_T *prio = scan_format_pattern (SUB (p), ref_file); if (prio != NO_NODE) { return (prio); } } if (IS (p, PICTURE)) { NODE_T *picture = SUB (p); A68_COLLITEM *collitem = (A68_COLLITEM *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (p))); if (COUNT (collitem) != 0) { if (IS (picture, A68_PATTERN)) { COUNT (collitem) = 0; /* This pattern is now done */ picture = SUB (picture); if (ATTRIBUTE (picture) != FORMAT_PATTERN) { return (picture); } else { NODE_T *pat; A68_FORMAT z; A68_FILE *file = FILE_DEREF (&ref_file); EXECUTE_UNIT (NEXT_SUB (picture)); POP_OBJECT (p, &z, A68_FORMAT); open_format_frame (p, ref_file, &z, EMBEDDED_FORMAT, A68_TRUE); pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file); if (pat != NO_NODE) { return (pat); } else { (void) end_of_format (p, ref_file); } } } else if (IS (picture, INSERTION)) { A68_FILE *file = FILE_DEREF (&ref_file); if (READ_MOOD (file)) { read_insertion (picture, ref_file); } else if (WRITE_MOOD (file)) { write_insertion (picture, ref_file, INSERTION_NORMAL); } else { ABEND (A68_TRUE, "undetermined mood for insertion", NO_TEXT); } COUNT (collitem) = 0; /* This insertion is now done */ } else if (IS (picture, REPLICATOR) || IS (picture, COLLECTION)) { BOOL_T go_on = A68_TRUE; NODE_T *a68g_select = NO_NODE; if (COUNT (collitem) == ITEM_NOT_USED) { if (IS (picture, REPLICATOR)) { COUNT (collitem) = get_replicator_value (SUB (p), A68_TRUE); go_on = (BOOL_T) (COUNT (collitem) > 0); FORWARD (picture); } else { COUNT (collitem) = 1; } initialise_collitems (NEXT_SUB (picture)); } else if (IS (picture, REPLICATOR)) { FORWARD (picture); } while (go_on) { /* Get format item from collection. If collection is done, but repitition is not, then re-initialise the collection and repeat */ a68g_select = scan_format_pattern (NEXT_SUB (picture), ref_file); if (a68g_select != NO_NODE) { return (a68g_select); } else { COUNT (collitem)--; go_on = (BOOL_T) (COUNT (collitem) > 0); if (go_on) { initialise_collitems (NEXT_SUB (picture)); } } } } } } } return (NO_NODE); } /** @brief Return first available pattern. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param mood Mode of operation. @return See brief description. **/ NODE_T *get_next_format_pattern (NODE_T * p, A68_REF ref_file, BOOL_T mood) { /* "mood" can be WANT_PATTERN: pattern needed by caller, so perform end-of-format if needed or SKIP_PATTERN: just emptying current pattern/collection/format. */ A68_FILE *file = FILE_DEREF (&ref_file); if (BODY (&FORMAT (file)) == NO_NODE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED); exit_genie (p, A68_RUNTIME_ERROR); return (NO_NODE); } else { NODE_T *pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file); if (pat == NO_NODE) { if (mood == WANT_PATTERN) { int z; do { z = end_of_format (p, ref_file); pat = scan_format_pattern (SUB (BODY (&FORMAT (file))), ref_file); } while (z == EMBEDDED_FORMAT && pat == NO_NODE); if (pat == NO_NODE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_EXHAUSTED); exit_genie (p, A68_RUNTIME_ERROR); } } } return (pat); } } /** @brief Diagnostic_node in case mode does not match picture. @param p Node in syntax tree. @param mode Mode of object read or written. @param att Attribute. **/ void pattern_error (NODE_T * p, MOID_T * mode, int att) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_CANNOT_TRANSPUT, mode, att); exit_genie (p, A68_RUNTIME_ERROR); } /** @brief Unite value at top of stack to NUMBER. @param p Node in syntax tree. @param mode Mode of value. @param item Pointer to value. **/ static void unite_to_number (NODE_T * p, MOID_T * mode, BYTE_T * item) { ADDR_T sp = stack_pointer; PUSH_UNION (p, mode); PUSH (p, item, (int) SIZE (mode)); stack_pointer = sp + SIZE (MODE (NUMBER)); } /** @brief Write a group of insertions. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param mood Mode of operation in case of error. **/ void write_insertion (NODE_T * p, A68_REF ref_file, unsigned mood) { for (; p != NO_NODE; FORWARD (p)) { write_insertion (SUB (p), ref_file, mood); if (IS (p, FORMAT_ITEM_L)) { add_char_transput_buffer (p, FORMATTED_BUFFER, NEWLINE_CHAR); write_purge_buffer (p, ref_file, FORMATTED_BUFFER); } else if (IS (p, FORMAT_ITEM_P)) { add_char_transput_buffer (p, FORMATTED_BUFFER, FORMFEED_CHAR); write_purge_buffer (p, ref_file, FORMATTED_BUFFER); } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) { add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } else if (IS (p, FORMAT_ITEM_Y)) { PUSH_REF (p, ref_file); PUSH_PRIMITIVE (p, -1, A68_INT); genie_set (p); } else if (IS (p, LITERAL)) { if (mood & INSERTION_NORMAL) { add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p)); } else if (mood & INSERTION_BLANK) { int j, k = (int) strlen (NSYMBOL (p)); for (j = 1; j <= k; j++) { add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } } } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) { for (j = 1; j <= k; j++) { write_insertion (NEXT (p), ref_file, mood); } } else { int pos = get_transput_buffer_index (FORMATTED_BUFFER); for (j = 1; j < (k - pos); j++) { add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } } return; } } } /** @brief Convert to other radix, binary up to hexadecimal. @param p Node in syntax tree. @param z Value to convert. @param radix Radix. @param width Width of converted number. @return Whether conversion is successful. **/ static BOOL_T convert_radix (NODE_T * p, unsigned z, int radix, int width) { static char *images = "0123456789abcdef"; if (width > 0 && (radix >= 2 && radix <= 16)) { int digit = (int) (z % (unsigned) radix); BOOL_T success = convert_radix (p, z / (unsigned) radix, radix, width - 1); add_char_transput_buffer (p, EDIT_BUFFER, images[digit]); return (success); } else { return ((BOOL_T) (z == 0)); } } /** @brief Convert to other radix, binary up to hexadecimal. @param p Node in syntax tree. @param u Mp number. @param radix Radix. @param width Width of converted number. @param m Mode of 'u'. @param v Work mp number. @param w Work mp number. @return Whether conversion is successful. **/ static BOOL_T convert_radix_mp (NODE_T * p, MP_T * u, int radix, int width, MOID_T * m, MP_T * v, MP_T * w) { static char *images = "0123456789abcdef"; if (width > 0 && (radix >= 2 && radix <= 16)) { int digit, digits = DIGITS (m); BOOL_T success; MOVE_MP (w, u, digits); (void) over_mp_digit (p, u, u, (MP_T) radix, digits); (void) mul_mp_digit (p, v, u, (MP_T) radix, digits); (void) sub_mp (p, v, w, v, digits); digit = (int) MP_DIGIT (v, 1); success = convert_radix_mp (p, u, radix, width - 1, m, v, w); add_char_transput_buffer (p, EDIT_BUFFER, images[digit]); return (success); } else { return ((BOOL_T) (MP_DIGIT (u, 1) == 0)); } } /** @brief Write string to file following current format. @param p Node in syntax tree. @param mode Mode of value. @param ref_file Fat pointer to A68 file. @param str String to write. **/ static void write_string_pattern (NODE_T * p, MOID_T * mode, A68_REF ref_file, char **str) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { write_insertion (SUB (p), ref_file, INSERTION_NORMAL); } else if (IS (p, FORMAT_ITEM_A)) { if ((*str)[0] != NULL_CHAR) { add_char_transput_buffer (p, FORMATTED_BUFFER, (*str)[0]); (*str)++; } else { value_error (p, mode, ref_file); } } else if (IS (p, FORMAT_ITEM_S)) { if ((*str)[0] != NULL_CHAR) { (*str)++; } else { value_error (p, mode, ref_file); } return; } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { write_string_pattern (NEXT (p), mode, ref_file, str); } return; } else { write_string_pattern (SUB (p), mode, ref_file, str); } } } /** @brief Scan c_pattern. @param p Node in syntax tree. @param right_align Conform C place holder. @param sign Conform C place holder. @param width Conform C place holder. @param after Conform C place holder. @param letter Conform C place holder. **/ void scan_c_pattern (NODE_T * p, BOOL_T * right_align, BOOL_T * sign, int *width, int *after, int *letter) { if (IS (p, FORMAT_ITEM_ESCAPE)) { FORWARD (p); } if (IS (p, FORMAT_ITEM_MINUS)) { *right_align = A68_FALSE; FORWARD (p); } else { *right_align = A68_TRUE; } if (IS (p, FORMAT_ITEM_PLUS)) { *sign = A68_TRUE; FORWARD (p); } else { *sign = A68_FALSE; } if (IS (p, REPLICATOR)) { *width = get_replicator_value (SUB (p), A68_TRUE); FORWARD (p); } if (IS (p, FORMAT_ITEM_POINT)) { FORWARD (p); } if (IS (p, REPLICATOR)) { *after = get_replicator_value (SUB (p), A68_TRUE); FORWARD (p); } *letter = ATTRIBUTE (p); } /** @brief Write appropriate insertion from a choice pattern. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param count Count to reach. **/ static void write_choice_pattern (NODE_T * p, A68_REF ref_file, int *count) { for (; p != NO_NODE; FORWARD (p)) { write_choice_pattern (SUB (p), ref_file, count); if (IS (p, PICTURE)) { (*count)--; if (*count == 0) { write_insertion (SUB (p), ref_file, INSERTION_NORMAL); } } } } /** @brief Write appropriate insertion from a boolean pattern. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param z BOOL value **/ static void write_boolean_pattern (NODE_T * p, A68_REF ref_file, BOOL_T z) { int k = (z ? 1 : 2); write_choice_pattern (p, ref_file, &k); } /** @brief Write value according to a general pattern. @param p Node in syntax tree. @param mode Mode of value. @param item Pointer to value. @param mod Format modifier. **/ static void write_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, int mod) { A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; int size; /* Push arguments */ unite_to_number (p, mode, item); EXECUTE_UNIT (NEXT_SUB (p)); POP_REF (p, &row); GET_DESCRIPTOR (arr, tup, &row); size = ROW_SIZE (tup); if (size > 0) { int i; BYTE_T *base_address = DEREF (BYTE_T, &ARRAY (arr)); for (i = LWB (tup); i <= UPB (tup); i++) { int addr = INDEX_1_DIM (arr, tup, i); int arg = VALUE ((A68_INT *) & (base_address[addr])); PUSH_PRIMITIVE (p, arg, A68_INT); } } /* Make a string */ if (mod == FORMAT_ITEM_G) { switch (size) { case 1: { genie_whole (p); break; } case 2: { genie_fixed (p); break; } case 3: { genie_float (p); break; } default: { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); break; } } } else if (mod == FORMAT_ITEM_H) { int def_expo = 0, def_mult; A68_INT a_width, a_after, a_expo, a_mult; STATUS (&a_width) = INIT_MASK; VALUE (&a_width) = 0; STATUS (&a_after) = INIT_MASK; VALUE (&a_after) = 0; STATUS (&a_expo) = INIT_MASK; VALUE (&a_expo) = 0; STATUS (&a_mult) = INIT_MASK; VALUE (&a_mult) = 0; /* * Set default values */ if (mode == MODE (REAL) || mode == MODE (INT)) { def_expo = EXP_WIDTH + 1; } else if (mode == MODE (LONG_REAL) || mode == MODE (LONG_INT)) { def_expo = LONG_EXP_WIDTH + 1; } else if (mode == MODE (LONGLONG_REAL) || mode == MODE (LONGLONG_INT)) { def_expo = LONGLONG_EXP_WIDTH + 1; } def_mult = 3; /* * Pop user values */ switch (size) { case 1: { POP_OBJECT (p, &a_after, A68_INT); VALUE (&a_width) = VALUE (&a_after) + def_expo + 4; VALUE (&a_expo) = def_expo; VALUE (&a_mult) = def_mult; break; } case 2: { POP_OBJECT (p, &a_mult, A68_INT); POP_OBJECT (p, &a_after, A68_INT); VALUE (&a_width) = VALUE (&a_after) + def_expo + 4; VALUE (&a_expo) = def_expo; break; } case 3: { POP_OBJECT (p, &a_mult, A68_INT); POP_OBJECT (p, &a_after, A68_INT); POP_OBJECT (p, &a_width, A68_INT); VALUE (&a_expo) = def_expo; break; } case 4: { POP_OBJECT (p, &a_mult, A68_INT); POP_OBJECT (p, &a_expo, A68_INT); POP_OBJECT (p, &a_after, A68_INT); POP_OBJECT (p, &a_width, A68_INT); break; } default: { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FORMAT_INTS_REQUIRED, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); break; } } PUSH_PRIMITIVE (p, VALUE (&a_width), A68_INT); PUSH_PRIMITIVE (p, VALUE (&a_after), A68_INT); PUSH_PRIMITIVE (p, VALUE (&a_expo), A68_INT); PUSH_PRIMITIVE (p, VALUE (&a_mult), A68_INT); genie_real (p); } add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } /** @brief Write %[-][+][w][.][d]s/d/i/f/e/b/o/x formats. @param p Node in syntax tree. @param mode Mode of value. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void write_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { BOOL_T right_align, sign; int width, after, letter; ADDR_T pop_sp = stack_pointer; char *str = NO_TEXT; if (IS (p, CHAR_C_PATTERN)) { A68_CHAR *z = (A68_CHAR *) item; char q[2]; q[0] = (char) VALUE (z); q[1] = NULL_CHAR; str = (char *) &q; width = (int) strlen (str); scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); } else if (IS (p, STRING_C_PATTERN)) { str = (char *) item; width = (int) strlen (str); scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); } else if (IS (p, INTEGRAL_C_PATTERN)) { width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); unite_to_number (p, mode, item); PUSH_PRIMITIVE (p, (sign ? width : -width), A68_INT); str = whole (p); } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { int att = ATTRIBUTE (p), expval = 0, expo = 0; if (att == FLOAT_C_PATTERN || att == GENERAL_C_PATTERN) { int digits = 0; if (mode == MODE (REAL) || mode == MODE (INT)) { width = REAL_WIDTH + EXP_WIDTH + 4; after = REAL_WIDTH - 1; expo = EXP_WIDTH + 1; } else if (mode == MODE (LONG_REAL) || mode == MODE (LONG_INT)) { width = LONG_REAL_WIDTH + LONG_EXP_WIDTH + 4; after = LONG_REAL_WIDTH - 1; expo = LONG_EXP_WIDTH + 1; } else if (mode == MODE (LONGLONG_REAL) || mode == MODE (LONGLONG_INT)) { width = LONGLONG_REAL_WIDTH + LONGLONG_EXP_WIDTH + 4; after = LONGLONG_REAL_WIDTH - 1; expo = LONGLONG_EXP_WIDTH + 1; } scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter); if (digits == 0 && after > 0) { width = after + expo + 4; } else if (digits > 0) { width = digits; } unite_to_number (p, mode, item); PUSH_PRIMITIVE (p, (sign ? width : -width), A68_INT); PUSH_PRIMITIVE (p, after, A68_INT); PUSH_PRIMITIVE (p, expo, A68_INT); PUSH_PRIMITIVE (p, 1, A68_INT); str = real (p); stack_pointer = pop_sp; } if (att == GENERAL_C_PATTERN) { char *expch = strchr (str, EXPONENT_CHAR); if (expch != NO_TEXT) { expval = (int) strtol (&(expch[1]), NO_VAR, 10); } } if ((att == FIXED_C_PATTERN) || (att == GENERAL_C_PATTERN && (expval > -4 && expval <= after))) { int digits = 0; if (mode == MODE (REAL) || mode == MODE (INT)) { width = REAL_WIDTH + 2; after = REAL_WIDTH - 1; } else if (mode == MODE (LONG_REAL) || mode == MODE (LONG_INT)) { width = LONG_REAL_WIDTH + 2; after = LONG_REAL_WIDTH - 1; } else if (mode == MODE (LONGLONG_REAL) || mode == MODE (LONGLONG_INT)) { width = LONGLONG_REAL_WIDTH + 2; after = LONGLONG_REAL_WIDTH - 1; } scan_c_pattern (SUB (p), &right_align, &sign, &digits, &after, &letter); if (digits == 0 && after > 0) { width = after + 2; } else if (digits > 0) { width = digits; } unite_to_number (p, mode, item); PUSH_PRIMITIVE (p, (sign ? width : -width), A68_INT); PUSH_PRIMITIVE (p, after, A68_INT); str = fixed (p); stack_pointer = pop_sp; } } else if (IS (p, BITS_C_PATTERN)) { int radix = 10, nibble = 1; width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (letter == FORMAT_ITEM_B) { radix = 2; nibble = 1; } else if (letter == FORMAT_ITEM_O) { radix = 8; nibble = 3; } else if (letter == FORMAT_ITEM_X) { radix = 16; nibble = 4; } if (width == 0) { if (mode == MODE (BITS)) { width = (int) ceil ((double) BITS_WIDTH / (double) nibble); } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { width = (int) ceil ((double) get_mp_bits_width (mode) / (double) nibble); } } if (mode == MODE (BITS)) { A68_BITS *z = (A68_BITS *) item; reset_transput_buffer (EDIT_BUFFER); if (!convert_radix (p, VALUE (z), radix, width)) { errno = EDOM; value_error (p, mode, ref_file); } str = get_transput_buffer (EDIT_BUFFER); } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { int digits = DIGITS (mode); MP_T *u = (MP_T *) item; MP_T *v; MP_T *w; STACK_MP (v, p, digits); STACK_MP (w, p, digits); reset_transput_buffer (EDIT_BUFFER); if (!convert_radix_mp (p, u, radix, width, mode, v, w)) { errno = EDOM; value_error (p, mode, ref_file); } str = get_transput_buffer (EDIT_BUFFER); } } /* Did the conversion succeed? */ if (a68g_strchr (str, ERROR_CHAR) != NO_TEXT) { value_error (p, mode, ref_file); (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width); } else { /* Align and output */ if (width == 0) { add_string_transput_buffer (p, FORMATTED_BUFFER, str); } else { if (right_align == A68_TRUE) { int blanks = width - (int) strlen (str); if (blanks >= 0) { while (blanks--) { add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } add_string_transput_buffer (p, FORMATTED_BUFFER, str); } else { value_error (p, mode, ref_file); (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width); } } else { int blanks; while (str[0] == BLANK_CHAR) { str++; } blanks = width - (int) strlen (str); if (blanks >= 0) { add_string_transput_buffer (p, FORMATTED_BUFFER, str); while (blanks--) { add_char_transput_buffer (p, FORMATTED_BUFFER, BLANK_CHAR); } } else { value_error (p, mode, ref_file); (void) error_chars (get_transput_buffer (FORMATTED_BUFFER), width); } } } } } /** @brief Read one char from file. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @return See brief description. **/ static char read_single_char (NODE_T * p, A68_REF ref_file) { A68_FILE *file = FILE_DEREF (&ref_file); int ch = char_scanner (file); if (ch == EOF_CHAR) { end_of_file_error (p, ref_file); } return ((char) ch); } /** @brief Scan n chars from file to input buffer. @param p Node in syntax tree. @param n Chars to scan. @param m Mode being scanned. @param ref_file Fat pointer to A68 file. **/ static void scan_n_chars (NODE_T * p, int n, MOID_T * m, A68_REF ref_file) { int k; (void) m; for (k = 0; k < n; k++) { int ch = read_single_char (p, ref_file); add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); } } /** @brief Read %[-][+][w][.][d]s/d/i/f/e/b/o/x formats. @param p Node in syntax tree. @param mode Mode of value. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void read_c_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { BOOL_T right_align, sign; int width, after, letter; ADDR_T pop_sp = stack_pointer; reset_transput_buffer (INPUT_BUFFER); if (IS (p, CHAR_C_PATTERN)) { width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (width == 0) { genie_read_standard (p, mode, item, ref_file); } else { scan_n_chars (p, width, mode, ref_file); if (width > 1 && right_align == A68_FALSE) { for (; width > 1; width--) { (void) pop_char_transput_buffer (INPUT_BUFFER); } } genie_string_to_value (p, mode, item, ref_file); } } else if (IS (p, STRING_C_PATTERN)) { width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (width == 0) { genie_read_standard (p, mode, item, ref_file); } else { scan_n_chars (p, width, mode, ref_file); genie_string_to_value (p, mode, item, ref_file); } } else if (IS (p, INTEGRAL_C_PATTERN)) { if (mode != MODE (INT) && mode != MODE (LONG_INT) && mode != MODE (LONGLONG_INT)) { pattern_error (p, mode, ATTRIBUTE (p)); } else { width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (width == 0) { genie_read_standard (p, mode, item, ref_file); } else { scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file); genie_string_to_value (p, mode, item, ref_file); } } } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { if (mode != MODE (REAL) && mode != MODE (LONG_REAL) && mode != MODE (LONGLONG_REAL)) { pattern_error (p, mode, ATTRIBUTE (p)); } else { width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (width == 0) { genie_read_standard (p, mode, item, ref_file); } else { scan_n_chars (p, (sign != 0) ? width + 1 : width, mode, ref_file); genie_string_to_value (p, mode, item, ref_file); } } } else if (IS (p, BITS_C_PATTERN)) { if (mode != MODE (BITS) && mode != MODE (LONG_BITS) && mode != MODE (LONGLONG_BITS)) { pattern_error (p, mode, ATTRIBUTE (p)); } else { int radix = 10; char *str; width = 0; scan_c_pattern (SUB (p), &right_align, &sign, &width, &after, &letter); if (letter == FORMAT_ITEM_B) { radix = 2; } else if (letter == FORMAT_ITEM_O) { radix = 8; } else if (letter == FORMAT_ITEM_X) { radix = 16; } str = get_transput_buffer (INPUT_BUFFER); if (width == 0) { A68_FILE *file = FILE_DEREF (&ref_file); int ch; ASSERT (snprintf (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0); set_transput_buffer_index (INPUT_BUFFER, (int) strlen (str)); ch = char_scanner (file); while (ch != EOF_CHAR && (IS_SPACE (ch) || IS_NL_FF (ch))) { if (IS_NL_FF (ch)) { skip_nl_ff (p, &ch, ref_file); } else { ch = char_scanner (file); } } while (ch != EOF_CHAR && IS_XDIGIT (ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); ch = char_scanner (file); } unchar_scanner (p, file, (char) ch); } else { ASSERT (snprintf (str, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0); set_transput_buffer_index (INPUT_BUFFER, (int) strlen (str)); scan_n_chars (p, width, mode, ref_file); } genie_string_to_value (p, mode, item, ref_file); } } stack_pointer = pop_sp; } /* INTEGRAL, REAL, COMPLEX and BITS patterns */ /** @brief Count Z and D frames in a mould. @param p Node in syntax tree. @param z Counting integer. **/ static void count_zd_frames (NODE_T * p, int *z) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, FORMAT_ITEM_D) || IS (p, FORMAT_ITEM_Z)) { (*z)++; } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { count_zd_frames (NEXT (p), z); } return; } else { count_zd_frames (SUB (p), z); } } } /** @brief Get sign from sign mould. @param p Node in syntax tree. @return Position of sign in tree or NULL. **/ static NODE_T *get_sign (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { NODE_T *q = get_sign (SUB (p)); if (q != NO_NODE) { return (q); } else if (IS (p, FORMAT_ITEM_PLUS) || IS (p, FORMAT_ITEM_MINUS)) { return (p); } } return (NO_NODE); } /** @brief Shift sign through Z frames until non-zero digit or D frame. @param p Node in syntax tree. @param q String to propagate sign through. **/ static void shift_sign (NODE_T * p, char **q) { for (; p != NO_NODE && (*q) != NO_TEXT; FORWARD (p)) { shift_sign (SUB (p), q); if (IS (p, FORMAT_ITEM_Z)) { if (((*q)[0] == '+' || (*q)[0] == '-') && (*q)[1] == '0') { char ch = (*q)[0]; (*q)[0] = (*q)[1]; (*q)[1] = ch; (*q)++; } } else if (IS (p, FORMAT_ITEM_D)) { (*q) = NO_TEXT; } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { shift_sign (NEXT (p), q); } return; } } } /** @brief Pad trailing blanks to integral until desired width. @param p Node in syntax tree. @param n Number of zeroes to pad. **/ static void put_zeroes_to_integral (NODE_T * p, int n) { for (; n > 0; n--) { add_char_transput_buffer (p, EDIT_BUFFER, '0'); } } /** @brief Pad a sign to integral representation. @param p Node in syntax tree. @param sign Sign. **/ static void put_sign_to_integral (NODE_T * p, int sign) { NODE_T *sign_node = get_sign (SUB (p)); if (IS (sign_node, FORMAT_ITEM_PLUS)) { add_char_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? '+' : '-')); } else { add_char_transput_buffer (p, EDIT_BUFFER, (char) (sign >= 0 ? BLANK_CHAR : '-')); } } /** @brief Write point, exponent or plus-i-times symbol. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @param att Attribute. @param sym Symbol to print when matched. **/ static void write_pie_frame (NODE_T * p, A68_REF ref_file, int att, int sym) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { write_insertion (p, ref_file, INSERTION_NORMAL); } else if (IS (p, att)) { write_pie_frame (SUB (p), ref_file, att, sym); return; } else if (IS (p, sym)) { add_string_transput_buffer (p, FORMATTED_BUFFER, NSYMBOL (p)); } else if (IS (p, FORMAT_ITEM_S)) { return; } } } /** @brief Write sign when appropriate. @param p Node in syntax tree. @param q String to write. **/ static void write_mould_put_sign (NODE_T * p, char **q) { if ((*q)[0] == '+' || (*q)[0] == '-' || (*q)[0] == BLANK_CHAR) { add_char_transput_buffer (p, FORMATTED_BUFFER, (*q)[0]); (*q)++; } } /** @brief Write character according to a mould. @param p Node in syntax tree. @param ch Character to write. @param q Pointer in mould. **/ static void add_char_mould (NODE_T *p, char ch, char **q) { if (ch != NULL_CHAR) { add_char_transput_buffer (p, FORMATTED_BUFFER, ch); (*q)++; } } /** @brief Write string according to a mould. @param p Node in syntax tree. @param ref_file File descriptor. @param type Type of mould. @param q Pointer in mould. @param mood Mode of operation. **/ static void write_mould (NODE_T * p, A68_REF ref_file, int type, char **q, unsigned *mood) { for (; p != NO_NODE; FORWARD (p)) { /* Insertions are inserted straight away. Note that we can suppress them using "mood", which is not standard A68 */ if (IS (p, INSERTION)) { write_insertion (SUB (p), ref_file, *mood); } else { write_mould (SUB (p), ref_file, type, q, mood); /* Z frames print blanks until first non-zero digits comes */ if (IS (p, FORMAT_ITEM_Z)) { write_mould_put_sign (p, q); if ((*q)[0] == '0') { if (*mood & DIGIT_BLANK) { add_char_mould (p, BLANK_CHAR, q); *mood = (*mood & ~INSERTION_NORMAL) | INSERTION_BLANK; } else if (*mood & DIGIT_NORMAL) { add_char_mould (p, '0', q); *mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL); } } else { add_char_mould (p, (*q)[0], q); *mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL); } } /* D frames print a digit */ else if (IS (p, FORMAT_ITEM_D)) { write_mould_put_sign (p, q); add_char_mould (p, (*q)[0], q); *mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL); } /* Suppressible frames */ else if (IS (p, FORMAT_ITEM_S)) { /* Suppressible frames are ignored in a sign-mould */ if (type == SIGN_MOULD) { write_mould (NEXT (p), ref_file, type, q, mood); } else if (type == INTEGRAL_MOULD) { if ((*q)[0] != NULL_CHAR) { (*q)++; } } return; } /* Replicator */ else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { write_mould (NEXT (p), ref_file, type, q, mood); } return; } } } } /** @brief Write INT value using int pattern. @param p Node in syntax tree. @param mode Mode of value. @param root Root mode. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void write_integral_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file) { RESET_ERRNO; if (!(mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT))) { pattern_error (p, root, ATTRIBUTE (p)); } else { ADDR_T old_stack_pointer = stack_pointer; char *str; int width = 0, sign = 0; unsigned mood; /* Dive into the pattern if needed */ if (IS (p, INTEGRAL_PATTERN)) { p = SUB (p); } /* Find width */ count_zd_frames (p, &width); /* Make string */ reset_transput_buffer (EDIT_BUFFER); if (mode == MODE (INT)) { A68_INT *z = (A68_INT *) item; sign = SIGN (VALUE (z)); str = sub_whole (p, ABS (VALUE (z)), width); } else if (mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { MP_T *z = (MP_T *) item; sign = SIGN (z[2]); z[2] = ABS (z[2]); str = long_sub_whole (p, z, DIGITS (mode), width); } /* Edit string and output */ if (a68g_strchr (str, ERROR_CHAR) != NO_TEXT) { value_error (p, root, ref_file); } if (IS (p, SIGN_MOULD)) { put_sign_to_integral (p, sign); } else if (sign < 0) { value_sign_error (p, root, ref_file); } put_zeroes_to_integral (p, width - (int) strlen (str)); add_string_transput_buffer (p, EDIT_BUFFER, str); str = get_transput_buffer (EDIT_BUFFER); mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL); if (IS (p, SIGN_MOULD)) { if (str[0] == '+' || str[0] == '-') { shift_sign (SUB (p), &str); } str = get_transput_buffer (EDIT_BUFFER); write_mould (SUB (p), ref_file, SIGN_MOULD, &str, &mood); FORWARD (p); } if (IS (p, INTEGRAL_MOULD)) { /* This *should* be the case */ write_mould (SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood); } stack_pointer = old_stack_pointer; } } /** @brief Write REAL value using real pattern. @param p Node in syntax tree. @param mode Mode of value. @param root Root mode. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void write_real_pattern (NODE_T * p, MOID_T * mode, MOID_T * root, BYTE_T * item, A68_REF ref_file) { RESET_ERRNO; if (!(mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL) || mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT))) { pattern_error (p, root, ATTRIBUTE (p)); } else { ADDR_T old_stack_pointer = stack_pointer; int sign_digits, stag_digits = 0, frac_digits = 0, expo_digits = 0; int mant_length, sign = 0, exp_value; NODE_T *q, *sign_mould = NO_NODE, *stag_mould = NO_NODE, *point_frame = NO_NODE, *frac_mould = NO_NODE, *e_frame = NO_NODE, *expo_mould = NO_NODE; char *str = NO_TEXT, *stag_str = NO_TEXT, *frac_str = NO_TEXT; unsigned mood; /* Dive into pattern */ q = ((IS (p, REAL_PATTERN)) ? SUB (p) : p); /* Dissect pattern and establish widths */ if (q != NO_NODE && IS (q, SIGN_MOULD)) { sign_mould = q; count_zd_frames (SUB (sign_mould), &stag_digits); FORWARD (q); } sign_digits = stag_digits; if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { stag_mould = q; count_zd_frames (SUB (stag_mould), &stag_digits); FORWARD (q); } if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) { point_frame = q; FORWARD (q); } if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { frac_mould = q; count_zd_frames (SUB (frac_mould), &frac_digits); FORWARD (q); } if (q != NO_NODE && IS (q, EXPONENT_FRAME)) { e_frame = SUB (q); expo_mould = NEXT_SUB (q); q = expo_mould; if (IS (q, SIGN_MOULD)) { count_zd_frames (SUB (q), &expo_digits); FORWARD (q); } if (IS (q, INTEGRAL_MOULD)) { count_zd_frames (SUB (q), &expo_digits); } } /* Make string representation */ if (point_frame == NO_NODE) { mant_length = stag_digits; } else { mant_length = 1 + stag_digits + frac_digits; } if (mode == MODE (REAL) || mode == MODE (INT)) { double x; if (mode == MODE (REAL)) { x = VALUE ((A68_REAL *) item); } else { x = (double) VALUE ((A68_INT *) item); } #if defined HAVE_IEEE_754 if (NOT_A_REAL (x)) { char *s = stack_string (p, 8 + mant_length); (void) error_chars (s, mant_length); add_string_transput_buffer (p, FORMATTED_BUFFER, s); stack_pointer = old_stack_pointer; return; } #endif exp_value = 0; sign = SIGN (x); if (sign_mould != NO_NODE) { put_sign_to_integral (sign_mould, sign); } x = ABS (x); if (expo_mould != NO_NODE) { standardise (&x, stag_digits, frac_digits, &exp_value); } str = sub_fixed (p, x, mant_length, frac_digits); } else if (mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { ADDR_T old_stack_pointer2 = stack_pointer; int digits = DIGITS (mode); MP_T *x; STACK_MP (x, p, digits); MOVE_MP (x, (MP_T *) item, digits); exp_value = 0; sign = SIGN (x[2]); if (sign_mould != NO_NODE) { put_sign_to_integral (sign_mould, sign); } x[2] = ABS (x[2]); if (expo_mould != NO_NODE) { long_standardise (p, x, DIGITS (mode), stag_digits, frac_digits, &exp_value); } str = long_sub_fixed (p, x, DIGITS (mode), mant_length, frac_digits); stack_pointer = old_stack_pointer2; } /* Edit and output the string */ if (a68g_strchr (str, ERROR_CHAR) != NO_TEXT) { value_error (p, root, ref_file); } reset_transput_buffer (STRING_BUFFER); add_string_transput_buffer (p, STRING_BUFFER, str); stag_str = get_transput_buffer (STRING_BUFFER); if (a68g_strchr (stag_str, ERROR_CHAR) != NO_TEXT) { value_error (p, root, ref_file); } str = a68g_strchr (stag_str, POINT_CHAR); if (str != NO_TEXT) { frac_str = &str[1]; str[0] = NULL_CHAR; } else { frac_str = NO_TEXT; } /* Stagnant part */ reset_transput_buffer (EDIT_BUFFER); if (sign_mould != NO_NODE) { put_sign_to_integral (sign_mould, sign); } else if (sign < 0) { value_sign_error (sign_mould, root, ref_file); } put_zeroes_to_integral (p, stag_digits - (int) strlen (stag_str)); add_string_transput_buffer (p, EDIT_BUFFER, stag_str); stag_str = get_transput_buffer (EDIT_BUFFER); mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL); if (sign_mould != NO_NODE) { if (stag_str[0] == '+' || stag_str[0] == '-') { shift_sign (SUB (p), &stag_str); } stag_str = get_transput_buffer (EDIT_BUFFER); write_mould (SUB (sign_mould), ref_file, SIGN_MOULD, &stag_str, &mood); } if (stag_mould != NO_NODE) { write_mould (SUB (stag_mould), ref_file, INTEGRAL_MOULD, &stag_str, &mood); } /* Point frame */ if (point_frame != NO_NODE) { write_pie_frame (point_frame, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT); } /* Fraction */ if (frac_mould != NO_NODE) { reset_transput_buffer (EDIT_BUFFER); add_string_transput_buffer (p, EDIT_BUFFER, frac_str); frac_str = get_transput_buffer (EDIT_BUFFER); mood = (unsigned) (DIGIT_NORMAL | INSERTION_NORMAL); write_mould (SUB (frac_mould), ref_file, INTEGRAL_MOULD, &frac_str, &mood); } /* Exponent */ if (expo_mould != NO_NODE) { A68_INT z; STATUS (&z) = INIT_MASK; VALUE (&z) = exp_value; if (e_frame != NO_NODE) { write_pie_frame (e_frame, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E); } write_integral_pattern (expo_mould, MODE (INT), root, (BYTE_T *) & z, ref_file); } stack_pointer = old_stack_pointer; } } /** @brief Write COMPLEX value using complex pattern. @param p Node in syntax tree. @param comp Mode of complex number. @param root Root mode. @param re Pointer to real part. @param im Pointer to imaginary part. @param ref_file Fat pointer to A68 file. **/ static void write_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * root, BYTE_T * re, BYTE_T * im, A68_REF ref_file) { NODE_T *reel, *plus_i_times, *imag; RESET_ERRNO; /* Dissect pattern */ reel = SUB (p); plus_i_times = NEXT (reel); imag = NEXT (plus_i_times); /* Write pattern */ write_real_pattern (reel, comp, root, re, ref_file); write_pie_frame (plus_i_times, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I); write_real_pattern (imag, comp, root, im, ref_file); } /** @brief Write BITS value using bits pattern. @param p Node in syntax tree. @param mode Mode of value. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void write_bits_pattern (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { if (mode == MODE (BITS)) { int width = 0, radix; unsigned mood; A68_BITS *z = (A68_BITS *) item; char *str; /* Establish width and radix */ count_zd_frames (SUB (p), &width); radix = get_replicator_value (SUB_SUB (p), A68_TRUE); if (radix < 2 || radix > 16) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix); exit_genie (p, A68_RUNTIME_ERROR); } /* Generate string of correct width */ reset_transput_buffer (EDIT_BUFFER); if (!convert_radix (p, VALUE (z), radix, width)) { errno = EDOM; value_error (p, mode, ref_file); } /* Output the edited string */ mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL); str = get_transput_buffer (EDIT_BUFFER); write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood); } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { ADDR_T pop_sp = stack_pointer; int width = 0, radix, digits = DIGITS (mode); unsigned mood; MP_T *u = (MP_T *) item; MP_T *v; MP_T *w; char *str; STACK_MP (v, p, digits); STACK_MP (w, p, digits); /* Establish width and radix */ count_zd_frames (SUB (p), &width); radix = get_replicator_value (SUB_SUB (p), A68_TRUE); if (radix < 2 || radix > 16) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix); exit_genie (p, A68_RUNTIME_ERROR); } /* Generate string of correct width */ reset_transput_buffer (EDIT_BUFFER); if (!convert_radix_mp (p, u, radix, width, mode, v, w)) { errno = EDOM; value_error (p, mode, ref_file); } /* Output the edited string */ mood = (unsigned) (DIGIT_BLANK | INSERTION_NORMAL); str = get_transput_buffer (EDIT_BUFFER); write_mould (NEXT_SUB (p), ref_file, INTEGRAL_MOULD, &str, &mood); stack_pointer = pop_sp; } } /** @brief Write value to file. @param p Node in syntax tree. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void genie_write_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file) { if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) { genie_value_to_string (p, MODE (REAL), item, ATTRIBUTE (SUB (p))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { write_number_generic (p, MODE (REAL), item, ATTRIBUTE (SUB (p))); } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { write_c_pattern (p, MODE (REAL), item, ref_file); } else if (IS (p, REAL_PATTERN)) { write_real_pattern (p, MODE (REAL), MODE (REAL), item, ref_file); } else if (IS (p, COMPLEX_PATTERN)) { A68_REAL im; STATUS (&im) = INIT_MASK; VALUE (&im) = 0.0; write_complex_pattern (p, MODE (REAL), MODE (COMPLEX), (BYTE_T *) item, (BYTE_T *) & im, ref_file); } else { pattern_error (p, MODE (REAL), ATTRIBUTE (p)); } } /** @brief Write value to file. @param p Node in syntax tree. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void genie_write_long_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file) { if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) { genie_value_to_string (p, MODE (LONG_REAL), item, ATTRIBUTE (SUB (p))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { write_number_generic (p, MODE (LONG_REAL), item, ATTRIBUTE (SUB (p))); } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { write_c_pattern (p, MODE (LONG_REAL), item, ref_file); } else if (IS (p, REAL_PATTERN)) { write_real_pattern (p, MODE (LONG_REAL), MODE (LONG_REAL), item, ref_file); } else if (IS (p, COMPLEX_PATTERN)) { ADDR_T old_stack_pointer = stack_pointer; MP_T *z; STACK_MP (z, p, DIGITS (MODE (LONG_REAL))); SET_MP_ZERO (z, DIGITS (MODE (LONG_REAL))); z[0] = (MP_T) INIT_MASK; write_complex_pattern (p, MODE (LONG_REAL), MODE (LONG_COMPLEX), item, (BYTE_T *) z, ref_file); stack_pointer = old_stack_pointer; } else { pattern_error (p, MODE (LONG_REAL), ATTRIBUTE (p)); } } /** @brief Write value to file. @param p Node in syntax tree. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void genie_write_longlong_real_format (NODE_T * p, BYTE_T * item, A68_REF ref_file) { if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) { genie_value_to_string (p, MODE (LONGLONG_REAL), item, ATTRIBUTE (SUB (p))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { write_number_generic (p, MODE (LONGLONG_REAL), item, ATTRIBUTE (SUB (p))); } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { write_c_pattern (p, MODE (LONGLONG_REAL), item, ref_file); } else if (IS (p, REAL_PATTERN)) { write_real_pattern (p, MODE (LONGLONG_REAL), MODE (LONGLONG_REAL), item, ref_file); } else if (IS (p, COMPLEX_PATTERN)) { ADDR_T old_stack_pointer = stack_pointer; MP_T *z; STACK_MP (z, p, DIGITS (MODE (LONGLONG_REAL))); SET_MP_ZERO (z, DIGITS (MODE (LONGLONG_REAL))); z[0] = (MP_T) INIT_MASK; write_complex_pattern (p, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), item, (BYTE_T *) z, ref_file); stack_pointer = old_stack_pointer; } else { pattern_error (p, MODE (LONGLONG_REAL), ATTRIBUTE (p)); } } /** @brief Write value to file. @param p Node in syntax tree. @param mode Mode of value. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void genie_write_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { RESET_ERRNO; if (mode == MODE (INT)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) { write_number_generic (pat, MODE (INT), item, ATTRIBUTE (SUB (pat))); } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) { write_c_pattern (pat, MODE (INT), item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { write_integral_pattern (pat, MODE (INT), MODE (INT), item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, MODE (INT), MODE (INT), item, ref_file); } else if (IS (pat, COMPLEX_PATTERN)) { A68_REAL re, im; STATUS (&re) = INIT_MASK; VALUE (&re) = (double) VALUE ((A68_INT *) item); STATUS (&im) = INIT_MASK; VALUE (&im) = 0.0; write_complex_pattern (pat, MODE (REAL), MODE (COMPLEX), (BYTE_T *) & re, (BYTE_T *) & im, ref_file); } else if (IS (pat, CHOICE_PATTERN)) { int k = VALUE ((A68_INT *) item); write_choice_pattern (NEXT_SUB (pat), ref_file, &k); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (LONG_INT)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) { write_number_generic (pat, MODE (LONG_INT), item, ATTRIBUTE (SUB (pat))); } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) { write_c_pattern (pat, MODE (LONG_INT), item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { write_integral_pattern (pat, MODE (LONG_INT), MODE (LONG_INT), item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, MODE (LONG_INT), MODE (LONG_INT), item, ref_file); } else if (IS (pat, COMPLEX_PATTERN)) { ADDR_T old_stack_pointer = stack_pointer; MP_T *z; STACK_MP (z, p, DIGITS (mode)); SET_MP_ZERO (z, DIGITS (mode)); z[0] = (MP_T) INIT_MASK; write_complex_pattern (pat, MODE (LONG_REAL), MODE (LONG_COMPLEX), item, (BYTE_T *) z, ref_file); stack_pointer = old_stack_pointer; } else if (IS (pat, CHOICE_PATTERN)) { int k = mp_to_int (p, (MP_T *) item, DIGITS (mode)); write_choice_pattern (NEXT_SUB (pat), ref_file, &k); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (LONGLONG_INT)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (pat))); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) { write_number_generic (pat, MODE (LONGLONG_INT), item, ATTRIBUTE (SUB (pat))); } else if (IS (pat, INTEGRAL_C_PATTERN) || IS (pat, FIXED_C_PATTERN) || IS (pat, FLOAT_C_PATTERN) || IS (pat, GENERAL_C_PATTERN)) { write_c_pattern (pat, MODE (LONGLONG_INT), item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { write_integral_pattern (pat, MODE (LONGLONG_INT), MODE (LONGLONG_INT), item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, MODE (INT), MODE (INT), item, ref_file); } else if (IS (pat, REAL_PATTERN)) { write_real_pattern (pat, MODE (LONGLONG_INT), MODE (LONGLONG_INT), item, ref_file); } else if (IS (pat, COMPLEX_PATTERN)) { ADDR_T old_stack_pointer = stack_pointer; MP_T *z; STACK_MP (z, p, DIGITS (MODE (LONGLONG_REAL))); SET_MP_ZERO (z, DIGITS (mode)); z[0] = (MP_T) INIT_MASK; write_complex_pattern (pat, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), item, (BYTE_T *) z, ref_file); stack_pointer = old_stack_pointer; } else if (IS (pat, CHOICE_PATTERN)) { int k = mp_to_int (p, (MP_T *) item, DIGITS (mode)); write_choice_pattern (NEXT_SUB (pat), ref_file, &k); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (REAL)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); genie_write_real_format (pat, item, ref_file); } else if (mode == MODE (LONG_REAL)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); genie_write_long_real_format (pat, item, ref_file); } else if (mode == MODE (LONGLONG_REAL)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); genie_write_longlong_real_format (pat, item, ref_file); } else if (mode == MODE (COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { write_complex_pattern (pat, MODE (REAL), MODE (COMPLEX), &item[0], &item[SIZE (MODE (REAL))], ref_file); } else { /* Try writing as two REAL values */ genie_write_real_format (pat, item, ref_file); genie_write_standard_format (p, MODE (REAL), &item[SIZE (MODE (REAL))], ref_file); } } else if (mode == MODE (LONG_COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { write_complex_pattern (pat, MODE (LONG_REAL), MODE (LONG_COMPLEX), &item[0], &item[SIZE (MODE (LONG_REAL))], ref_file); } else { /* Try writing as two LONG REAL values */ genie_write_long_real_format (pat, item, ref_file); genie_write_standard_format (p, MODE (LONG_REAL), &item[SIZE (MODE (LONG_REAL))], ref_file); } } else if (mode == MODE (LONGLONG_COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { write_complex_pattern (pat, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX), &item[0], &item[SIZE (MODE (LONGLONG_REAL))], ref_file); } else { /* Try writing as two LONG LONG REAL values */ genie_write_longlong_real_format (pat, item, ref_file); genie_write_standard_format (p, MODE (LONGLONG_REAL), &item[SIZE (MODE (LONGLONG_REAL))], ref_file); } } else if (mode == MODE (BOOL)) { A68_BOOL *z = (A68_BOOL *) item; NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { add_char_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR)); } else if (IS (pat, BOOLEAN_PATTERN)) { if (NEXT_SUB (pat) == NO_NODE) { add_char_transput_buffer (p, FORMATTED_BUFFER, (char) (VALUE (z) == A68_TRUE ? FLIP_CHAR : FLOP_CHAR)); } else { write_boolean_pattern (pat, ref_file, (BOOL_T) (VALUE (z) == A68_TRUE)); } } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (BITS)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { char *str = (char *) STACK_TOP; genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p))); add_string_transput_buffer (p, FORMATTED_BUFFER, str); } else if (IS (pat, BITS_PATTERN)) { write_bits_pattern (pat, MODE (BITS), item, ref_file); } else if (IS (pat, BITS_C_PATTERN)) { write_c_pattern (pat, MODE (BITS), item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { char *str = (char *) STACK_TOP; genie_value_to_string (p, mode, item, ATTRIBUTE (SUB (p))); add_string_transput_buffer (p, FORMATTED_BUFFER, str); } else if (IS (pat, BITS_PATTERN)) { write_bits_pattern (pat, mode, item, ref_file); } else if (IS (pat, BITS_C_PATTERN)) { write_c_pattern (pat, mode, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (CHAR)) { A68_CHAR *z = (A68_CHAR *) item; NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { add_char_transput_buffer (p, FORMATTED_BUFFER, (char) VALUE (z)); } else if (IS (pat, STRING_PATTERN)) { char *q = get_transput_buffer (EDIT_BUFFER); reset_transput_buffer (EDIT_BUFFER); add_char_transput_buffer (p, EDIT_BUFFER, (char) VALUE (z)); write_string_pattern (pat, mode, ref_file, &q); if (q[0] != NULL_CHAR) { value_error (p, mode, ref_file); } } else if (IS (pat, STRING_C_PATTERN)) { write_c_pattern (pat, mode, (BYTE_T *) z, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { /* Handle these separately instead of printing [] CHAR */ A68_REF row = *(A68_REF *) item; NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { PUSH_REF (p, row); add_string_from_stack_transput_buffer (p, FORMATTED_BUFFER); } else if (IS (pat, STRING_PATTERN)) { char *q; PUSH_REF (p, row); reset_transput_buffer (EDIT_BUFFER); add_string_from_stack_transput_buffer (p, EDIT_BUFFER); q = get_transput_buffer (EDIT_BUFFER); write_string_pattern (pat, mode, ref_file, &q); if (q[0] != NULL_CHAR) { value_error (p, mode, ref_file); } } else if (IS (pat, STRING_C_PATTERN)) { char *q; PUSH_REF (p, row); reset_transput_buffer (EDIT_BUFFER); add_string_from_stack_transput_buffer (p, EDIT_BUFFER); q = get_transput_buffer (EDIT_BUFFER); write_c_pattern (pat, mode, (BYTE_T *) q, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; genie_write_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; genie_check_initialisation (p, elem, MOID (q)); genie_write_standard_format (p, MOID (q), elem, ref_file); } } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); BYTE_T *elem = &base_addr[elem_addr]; genie_check_initialisation (p, elem, SUB (deflexed)); genie_write_standard_format (p, SUB (deflexed), elem, ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } /** @brief At end of write purge all insertions. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. **/ static void purge_format_write (NODE_T * p, A68_REF ref_file) { /* Problem here is shutting down embedded formats */ BOOL_T go_on; do { A68_FILE *file; NODE_T *dollar, *pat; A68_FORMAT *old_fmt; while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) { format_error (p, ref_file, ERROR_FORMAT_PICTURES); } file = FILE_DEREF (&ref_file); dollar = SUB (BODY (&FORMAT (file))); old_fmt = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar))); go_on = (BOOL_T) ! IS_NIL_FORMAT (old_fmt); if (go_on) { /* Pop embedded format and proceed */ (void) end_of_format (p, ref_file); } } while (go_on); } /** @brief PROC ([] SIMPLOUT) VOID print f, write f @param p Node in syntax tree. **/ void genie_write_format (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_out (p); PUSH_REF (p, row); genie_write_file_format (p); } /** @brief PROC (REF FILE, [] SIMPLOUT) VOID put f @param p Node in syntax tree. **/ void genie_write_file_format (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index, formats; ADDR_T save_frame_pointer, save_stack_pointer; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLOUT)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (READ_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "read"); exit_genie (p, A68_RUNTIME_ERROR); } if (!PUT (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "putting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if (IS_NIL (STRING (file))) { if ((FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, A68_PROTECTION)) == A68_NO_FILENO) { open_error (p, ref_file, "putting"); } } else { FD (file) = open_physical_file (p, ref_file, A68_WRITE_ACCESS, 0); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_FALSE; WRITE_MOOD (file) = A68_TRUE; CHAR_MOOD (file) = A68_TRUE; } if (!CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } /* Save stack state since formats have frames */ save_frame_pointer = FRAME_POINTER (file); save_stack_pointer = STACK_POINTER (file); FRAME_POINTER (file) = frame_pointer; STACK_POINTER (file) = stack_pointer; /* Process [] SIMPLOUT */ if (BODY (&FORMAT (file)) != NO_NODE) { open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE); } if (elems <= 0) { return; } formats = 0; base_address = DEREF (BYTE_T, &ARRAY (arr)); elem_index = 0; for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & (base_address[elem_index]); MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = &(base_address[elem_index + A68_UNION_SIZE]); if (mode == MODE (FORMAT)) { /* Forget about eventual active formats and set up new one */ if (formats > 0) { purge_format_write (p, ref_file); } formats++; frame_pointer = FRAME_POINTER (file); stack_pointer = STACK_POINTER (file); open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE); } else if (mode == MODE (PROC_REF_FILE_VOID)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (PROC_REF_FILE_VOID)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (SOUND)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (SOUND)); exit_genie (p, A68_RUNTIME_ERROR); } else { genie_write_standard_format (p, mode, item, ref_file); } elem_index += SIZE (MODE (SIMPLOUT)); } /* Empty the format to purge insertions */ purge_format_write (p, ref_file); BODY (&FORMAT (file)) = NO_NODE; /* Dump the buffer */ write_purge_buffer (p, ref_file, FORMATTED_BUFFER); /* Forget about active formats */ frame_pointer = FRAME_POINTER (file); stack_pointer = STACK_POINTER (file); FRAME_POINTER (file) = save_frame_pointer; STACK_POINTER (file) = save_stack_pointer; } /** @brief Give a value error in case a character is not among expected ones. @param p Node in syntax tree. @param m Mode of value read or written. @param ref_file Fat pointer to A68 file. @param items Expected characters. @param ch Actual character. @return Whether character is expected. **/ static BOOL_T expect (NODE_T * p, MOID_T * m, A68_REF ref_file, const char *items, char ch) { if (a68g_strchr ((char *) items, ch) == NO_TEXT) { value_error (p, m, ref_file); return (A68_FALSE); } else { return (A68_TRUE); } } /** @brief Read a group of insertions. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. **/ void read_insertion (NODE_T * p, A68_REF ref_file) { /* Algol68G does not check whether the insertions are textually there. It just skips them. This because we blank literals in sign moulds before the sign is put, which is non-standard Algol68, but convenient. */ A68_FILE *file = FILE_DEREF (&ref_file); for (; p != NO_NODE; FORWARD (p)) { read_insertion (SUB (p), ref_file); if (IS (p, FORMAT_ITEM_L)) { BOOL_T go_on = (BOOL_T) ! END_OF_FILE (file); while (go_on) { int ch = read_single_char (p, ref_file); go_on = (BOOL_T) ((ch != NEWLINE_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file)); } } else if (IS (p, FORMAT_ITEM_P)) { BOOL_T go_on = (BOOL_T) ! END_OF_FILE (file); while (go_on) { int ch = read_single_char (p, ref_file); go_on = (BOOL_T) ((ch != FORMFEED_CHAR) && (ch != EOF_CHAR) && !END_OF_FILE (file)); } } else if (IS (p, FORMAT_ITEM_X) || IS (p, FORMAT_ITEM_Q)) { if (!END_OF_FILE (file)) { (void) read_single_char (p, ref_file); } } else if (IS (p, FORMAT_ITEM_Y)) { PUSH_REF (p, ref_file); PUSH_PRIMITIVE (p, -1, A68_INT); genie_set (p); } else if (IS (p, LITERAL)) { /* Skip characters, but don't check the literal. */ int len = (int) strlen (NSYMBOL (p)); while (len-- && !END_OF_FILE (file)) { (void) read_single_char (p, ref_file); } } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); if (ATTRIBUTE (SUB_NEXT (p)) != FORMAT_ITEM_K) { for (j = 1; j <= k; j++) { read_insertion (NEXT (p), ref_file); } } else { int pos = get_transput_buffer_index (INPUT_BUFFER); for (j = 1; j < (k - pos); j++) { if (!END_OF_FILE (file)) { (void) read_single_char (p, ref_file); } } } return; /* Don't delete this! */ } } } /** @brief Read string from file according current format. @param p Node in syntax tree. @param m Mode being read. @param ref_file Fat pointer to A68 file. **/ static void read_string_pattern (NODE_T * p, MOID_T * m, A68_REF ref_file) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { read_insertion (SUB (p), ref_file); } else if (IS (p, FORMAT_ITEM_A)) { scan_n_chars (p, 1, m, ref_file); } else if (IS (p, FORMAT_ITEM_S)) { add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR); return; } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { read_string_pattern (NEXT (p), m, ref_file); } return; } else { read_string_pattern (SUB (p), m, ref_file); } } } /** @brief Traverse choice pattern. @param p Node in syntax tree. @param str String to match. @param len Length to match. @param count Counts literals. @param matches Matching literals. @param first_match First matching literal. @param full_match Whether match is complete (beyond 'len'). **/ static void traverse_choice_pattern (NODE_T * p, char *str, int len, int *count, int *matches, int *first_match, BOOL_T * full_match) { for (; p != NO_NODE; FORWARD (p)) { traverse_choice_pattern (SUB (p), str, len, count, matches, first_match, full_match); if (IS (p, LITERAL)) { (*count)++; if (strncmp (NSYMBOL (p), str, (size_t) len) == 0) { (*matches)++; (*full_match) = (BOOL_T) ((*full_match) | (strcmp (NSYMBOL (p), str) == 0)); if (*first_match == 0 && *full_match) { *first_match = *count; } } } } } /** @brief Read appropriate insertion from a choice pattern. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. @return Length of longest match. **/ static int read_choice_pattern (NODE_T * p, A68_REF ref_file) { /* This implementation does not have the RR peculiarity that longest matching literal must be first, in case of non-unique first chars. */ A68_FILE *file = FILE_DEREF (&ref_file); BOOL_T cont = A68_TRUE; int longest_match = 0, longest_match_len = 0; while (cont) { int ch = char_scanner (file); if (!END_OF_FILE (file)) { int len, count = 0, matches = 0, first_match = 0; BOOL_T full_match = A68_FALSE; add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); len = get_transput_buffer_index (INPUT_BUFFER); traverse_choice_pattern (p, get_transput_buffer (INPUT_BUFFER), len, &count, &matches, &first_match, &full_match); if (full_match && matches == 1 && first_match > 0) { return (first_match); } else if (full_match && matches > 1 && first_match > 0) { longest_match = first_match; longest_match_len = len; } else if (matches == 0) { cont = A68_FALSE; } } else { cont = A68_FALSE; } } if (longest_match > 0) { /* Push back look-ahead chars */ if (get_transput_buffer_index (INPUT_BUFFER) > 0) { char *z = get_transput_buffer (INPUT_BUFFER); END_OF_FILE (file) = A68_FALSE; add_string_transput_buffer (p, TRANSPUT_BUFFER (file), &z[longest_match_len]); } return (longest_match); } else { value_error (p, MODE (INT), ref_file); return (0); } } /** @brief Read value according to a general-pattern. @param p Node in syntax tree. @param mode Mode of value. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void read_number_generic (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { A68_REF row; EXECUTE_UNIT (NEXT_SUB (p)); /* RR says to ignore parameters just calculated, so we will */ POP_REF (p, &row); genie_read_standard (p, mode, item, ref_file); } /* INTEGRAL, REAL, COMPLEX and BITS patterns */ /** @brief Read sign-mould according current format. @param p Node in syntax tree. @param m Mode of value. @param ref_file Fat pointer to A68 file. @param sign Value of sign (-1, 0, 1). **/ static void read_sign_mould (NODE_T * p, MOID_T * m, A68_REF ref_file, int *sign) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { read_insertion (SUB (p), ref_file); } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { read_sign_mould (NEXT (p), m, ref_file, sign); } return; /* Leave this! */ } else { switch (ATTRIBUTE (p)) { case FORMAT_ITEM_Z: case FORMAT_ITEM_D: case FORMAT_ITEM_S: case FORMAT_ITEM_PLUS: case FORMAT_ITEM_MINUS: { int ch = read_single_char (p, ref_file); /* When a sign has been read, digits are expected */ if (*sign != 0) { if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); } else { add_char_transput_buffer (p, INPUT_BUFFER, '0'); } /* When a sign has not been read, a sign is expected. If there is a digit in stead of a sign, the digit is accepted and '+' is assumed; RR demands a space to preceed the digit, Algol68G does not */ } else { if (a68g_strchr (SIGN_DIGITS, ch) != NO_TEXT) { if (ch == '+') { *sign = 1; } else if (ch == '-') { *sign = -1; } else if (ch == BLANK_CHAR) { /* * skip. */ ; } } else if (expect (p, m, ref_file, INT_DIGITS, (char) ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); *sign = 1; } } break; } default: { read_sign_mould (SUB (p), m, ref_file, sign); break; } } } } } /** @brief Read mould according current format. @param p Node in syntax tree. @param m Mode of value. @param ref_file Fat pointer to A68 file. **/ static void read_integral_mould (NODE_T * p, MOID_T * m, A68_REF ref_file) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { read_insertion (SUB (p), ref_file); } else if (IS (p, REPLICATOR)) { int j, k = get_replicator_value (SUB (p), A68_TRUE); for (j = 1; j <= k; j++) { read_integral_mould (NEXT (p), m, ref_file); } return; /* Leave this! */ } else if (IS (p, FORMAT_ITEM_Z)) { int ch = read_single_char (p, ref_file); const char *digits = (m == MODE (BITS) || m == MODE (LONG_BITS) || m == MODE (LONGLONG_BITS)) ? BITS_DIGITS_BLANK : INT_DIGITS_BLANK; if (expect (p, m, ref_file, digits, (char) ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ((ch == BLANK_CHAR) ? '0' : ch)); } else { add_char_transput_buffer (p, INPUT_BUFFER, '0'); } } else if (IS (p, FORMAT_ITEM_D)) { int ch = read_single_char (p, ref_file); const char *digits = (m == MODE (BITS) || m == MODE (LONG_BITS) || m == MODE (LONGLONG_BITS)) ? BITS_DIGITS : INT_DIGITS; if (expect (p, m, ref_file, digits, (char) ch)) { add_char_transput_buffer (p, INPUT_BUFFER, (char) ch); } else { add_char_transput_buffer (p, INPUT_BUFFER, '0'); } } else if (IS (p, FORMAT_ITEM_S)) { add_char_transput_buffer (p, INPUT_BUFFER, '0'); } else { read_integral_mould (SUB (p), m, ref_file); } } } /** @brief Read mould according current format. @param p Node in syntax tree. @param m Mode of value. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void read_integral_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file) { NODE_T *q = SUB (p); if (q != NO_NODE && IS (q, SIGN_MOULD)) { int sign = 0; char *z; add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR); read_sign_mould (SUB (q), m, ref_file, &sign); z = get_transput_buffer (INPUT_BUFFER); z[0] = (char) ((sign == -1) ? '-' : '+'); FORWARD (q); } if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { read_integral_mould (SUB (q), m, ref_file); } genie_string_to_value (p, m, item, ref_file); } /** @brief Read point, exponent or i-frame. @param p Node in syntax tree. @param m Mode of value. @param ref_file Fat pointer to A68 file. @param att Frame attribute. @param item Format item. @param ch Representation of 'item'. **/ static void read_pie_frame (NODE_T * p, MOID_T * m, A68_REF ref_file, int att, int item, char ch) { /* Widen ch to a stringlet */ char sym[3]; sym[0] = ch; sym[1] = (char) TO_LOWER (ch); sym[2] = NULL_CHAR; /* Now read the frame */ for (; p != NO_NODE; FORWARD (p)) { if (IS (p, INSERTION)) { read_insertion (p, ref_file); } else if (IS (p, att)) { read_pie_frame (SUB (p), m, ref_file, att, item, ch); return; } else if (IS (p, FORMAT_ITEM_S)) { add_char_transput_buffer (p, INPUT_BUFFER, sym[0]); return; } else if (IS (p, item)) { int ch0 = read_single_char (p, ref_file); if (expect (p, m, ref_file, sym, (char) ch0)) { add_char_transput_buffer (p, INPUT_BUFFER, sym[0]); } else { add_char_transput_buffer (p, INPUT_BUFFER, sym[0]); } } } } /** @brief Read REAL value using real pattern. @param p Node in syntax tree. @param m Mode of value. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void read_real_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file) { /* Dive into pattern */ NODE_T *q = (IS (p, REAL_PATTERN)) ? SUB (p) : p; /* Dissect pattern */ if (q != NO_NODE && IS (q, SIGN_MOULD)) { int sign = 0; char *z; add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR); read_sign_mould (SUB (q), m, ref_file, &sign); z = get_transput_buffer (INPUT_BUFFER); z[0] = (char) ((sign == -1) ? '-' : '+'); FORWARD (q); } if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { read_integral_mould (SUB (q), m, ref_file); FORWARD (q); } if (q != NO_NODE && IS (q, FORMAT_POINT_FRAME)) { read_pie_frame (SUB (q), m, ref_file, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, POINT_CHAR); FORWARD (q); } if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { read_integral_mould (SUB (q), m, ref_file); FORWARD (q); } if (q != NO_NODE && IS (q, EXPONENT_FRAME)) { read_pie_frame (SUB (q), m, ref_file, FORMAT_E_FRAME, FORMAT_ITEM_E, EXPONENT_CHAR); q = NEXT_SUB (q); if (q != NO_NODE && IS (q, SIGN_MOULD)) { int k, sign = 0; char *z; add_char_transput_buffer (p, INPUT_BUFFER, BLANK_CHAR); k = get_transput_buffer_index (INPUT_BUFFER); read_sign_mould (SUB (q), m, ref_file, &sign); z = get_transput_buffer (INPUT_BUFFER); z[k - 1] = (char) ((sign == -1) ? '-' : '+'); FORWARD (q); } if (q != NO_NODE && IS (q, INTEGRAL_MOULD)) { read_integral_mould (SUB (q), m, ref_file); FORWARD (q); } } genie_string_to_value (p, m, item, ref_file); } /** @brief Read COMPLEX value using complex pattern. @param p Node in syntax tree. @param comp Mode of complex value. @param m Mode of value fields. @param re Pointer to real part. @param im Pointer to imaginary part. @param ref_file Fat pointer to A68 file. **/ static void read_complex_pattern (NODE_T * p, MOID_T * comp, MOID_T * m, BYTE_T * re, BYTE_T * im, A68_REF ref_file) { NODE_T *reel, *plus_i_times, *imag; /* Dissect pattern */ reel = SUB (p); plus_i_times = NEXT (reel); imag = NEXT (plus_i_times); /* Read pattern */ read_real_pattern (reel, m, re, ref_file); reset_transput_buffer (INPUT_BUFFER); read_pie_frame (plus_i_times, comp, ref_file, FORMAT_I_FRAME, FORMAT_ITEM_I, 'I'); reset_transput_buffer (INPUT_BUFFER); read_real_pattern (imag, m, im, ref_file); } /** @brief Read BITS value according pattern. @param p Node in syntax tree. @param m Mode of value. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void read_bits_pattern (NODE_T * p, MOID_T * m, BYTE_T * item, A68_REF ref_file) { int radix; char *z; radix = get_replicator_value (SUB_SUB (p), A68_TRUE); if (radix < 2 || radix > 16) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_RADIX, radix); exit_genie (p, A68_RUNTIME_ERROR); } z = get_transput_buffer (INPUT_BUFFER); ASSERT (snprintf (z, (size_t) TRANSPUT_BUFFER_SIZE, "%dr", radix) >= 0); set_transput_buffer_index (INPUT_BUFFER, (int) strlen (z)); read_integral_mould (NEXT_SUB (p), m, ref_file); genie_string_to_value (p, m, item, ref_file); } /** @brief Read object with from file and store. @param p Node in syntax tree. @param mode Mode of value. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void genie_read_real_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { read_number_generic (p, mode, item, ref_file); } else if (IS (p, FIXED_C_PATTERN) || IS (p, FLOAT_C_PATTERN) || IS (p, GENERAL_C_PATTERN)) { read_c_pattern (p, mode, item, ref_file); } else if (IS (p, REAL_PATTERN)) { read_real_pattern (p, mode, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (p)); } } /** @brief Read object with from file and store. @param p Node in syntax tree. @param mode Mode of value. @param item Pointer to value. @param ref_file Fat pointer to A68 file. **/ static void genie_read_standard_format (NODE_T * p, MOID_T * mode, BYTE_T * item, A68_REF ref_file) { RESET_ERRNO; reset_transput_buffer (INPUT_BUFFER); if (mode == MODE (INT) || mode == MODE (LONG_INT) || mode == MODE (LONGLONG_INT)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_read_standard (pat, mode, item, ref_file); } else if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) != NO_NODE) { read_number_generic (pat, mode, item, ref_file); } else if (IS (pat, INTEGRAL_C_PATTERN)) { read_c_pattern (pat, mode, item, ref_file); } else if (IS (pat, INTEGRAL_PATTERN)) { read_integral_pattern (pat, mode, item, ref_file); } else if (IS (pat, CHOICE_PATTERN)) { int k = read_choice_pattern (pat, ref_file); if (mode == MODE (INT)) { A68_INT *z = (A68_INT *) item; VALUE (z) = k; STATUS (z) = (STATUS_MASK) ((VALUE (z) > 0) ? INIT_MASK : NULL_MASK); } else { MP_T *z = (MP_T *) item; if (k > 0) { (void) int_to_mp (p, z, k, DIGITS (mode)); z[0] = (MP_T) INIT_MASK; } else { z[0] = (MP_T) NULL_MASK; } } } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (REAL) || mode == MODE (LONG_REAL) || mode == MODE (LONGLONG_REAL)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); genie_read_real_format (pat, mode, item, ref_file); } else if (mode == MODE (COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { read_complex_pattern (pat, mode, MODE (REAL), item, &item[SIZE (MODE (REAL))], ref_file); } else { /* Try reading as two REAL values */ genie_read_real_format (pat, MODE (REAL), item, ref_file); genie_read_standard_format (p, MODE (REAL), &item[SIZE (MODE (REAL))], ref_file); } } else if (mode == MODE (LONG_COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { read_complex_pattern (pat, mode, MODE (LONG_REAL), item, &item[SIZE (MODE (LONG_REAL))], ref_file); } else { /* Try reading as two LONG REAL values */ genie_read_real_format (pat, MODE (LONG_REAL), item, ref_file); genie_read_standard_format (p, MODE (LONG_REAL), &item[SIZE (MODE (LONG_REAL))], ref_file); } } else if (mode == MODE (LONGLONG_COMPLEX)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, COMPLEX_PATTERN)) { read_complex_pattern (pat, mode, MODE (LONGLONG_REAL), item, &item[SIZE (MODE (LONGLONG_REAL))], ref_file); } else { /* Try reading as two LONG LONG REAL values */ genie_read_real_format (pat, MODE (LONGLONG_REAL), item, ref_file); genie_read_standard_format (p, MODE (LONGLONG_REAL), &item[SIZE (MODE (LONGLONG_REAL))], ref_file); } } else if (mode == MODE (BOOL)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else if (IS (pat, BOOLEAN_PATTERN)) { if (NEXT_SUB (pat) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else { A68_BOOL *z = (A68_BOOL *) item; int k = read_choice_pattern (pat, ref_file); if (k == 1 || k == 2) { VALUE (z) = (BOOL_T) ((k == 1) ? A68_TRUE : A68_FALSE); STATUS (z) = INIT_MASK; } else { STATUS (z) = NULL_MASK; } } } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (BITS) || mode == MODE (LONG_BITS) || mode == MODE (LONGLONG_BITS)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else if (IS (pat, BITS_PATTERN)) { read_bits_pattern (pat, mode, item, ref_file); } else if (IS (pat, BITS_C_PATTERN)) { read_c_pattern (pat, mode, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (CHAR)) { NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else if (IS (pat, STRING_PATTERN)) { read_string_pattern (pat, MODE (CHAR), ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (IS (pat, CHAR_C_PATTERN)) { read_c_pattern (pat, mode, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (mode == MODE (ROW_CHAR) || mode == MODE (STRING)) { /* Handle these separately instead of reading [] CHAR */ NODE_T *pat = get_next_format_pattern (p, ref_file, WANT_PATTERN); if (IS (pat, GENERAL_PATTERN) && NEXT_SUB (pat) == NO_NODE) { genie_read_standard (p, mode, item, ref_file); } else if (IS (pat, STRING_PATTERN)) { read_string_pattern (pat, mode, ref_file); genie_string_to_value (p, mode, item, ref_file); } else if (IS (pat, STRING_C_PATTERN)) { read_c_pattern (pat, mode, item, ref_file); } else { pattern_error (p, mode, ATTRIBUTE (pat)); } } else if (IS (mode, UNION_SYMBOL)) { A68_UNION *z = (A68_UNION *) item; genie_read_standard_format (p, (MOID_T *) (VALUE (z)), &item[A68_UNION_SIZE], ref_file); } else if (IS (mode, STRUCT_SYMBOL)) { PACK_T *q = PACK (mode); for (; q != NO_PACK; FORWARD (q)) { BYTE_T *elem = &item[OFFSET (q)]; genie_read_standard_format (p, MOID (q), elem, ref_file); } } else if (IS (mode, ROW_SYMBOL) || IS (mode, FLEX_SYMBOL)) { MOID_T *deflexed = DEFLEX (mode); A68_ARRAY *arr; A68_TUPLE *tup; CHECK_INIT (p, INITIALISED ((A68_REF *) item), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, (A68_REF *) item); if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = ROW_ELEMENT (arr, a68g_index); BYTE_T *elem = &base_addr[elem_addr]; genie_read_standard_format (p, SUB (deflexed), elem, ref_file); done = increment_internal_index (tup, DIM (arr)); } } } if (errno != 0) { transput_error (p, ref_file, mode); } } /** @brief At end of read purge all insertions. @param p Node in syntax tree. @param ref_file Fat pointer to A68 file. **/ static void purge_format_read (NODE_T * p, A68_REF ref_file) { BOOL_T go_on; do { A68_FILE *file; NODE_T *dollar, *pat; A68_FORMAT *old_fmt; /* while (get_next_format_pattern (p, ref_file, SKIP_PATTERN) != NO_NODE) { ; } */ while ((pat = get_next_format_pattern (p, ref_file, SKIP_PATTERN)) != NO_NODE) { format_error (p, ref_file, ERROR_FORMAT_PICTURES); } file = FILE_DEREF (&ref_file); dollar = SUB (BODY (&FORMAT (file))); old_fmt = (A68_FORMAT *) FRAME_LOCAL (frame_pointer, OFFSET (TAX (dollar))); go_on = (BOOL_T) ! IS_NIL_FORMAT (old_fmt); if (go_on) { /* Pop embedded format and proceed */ (void) end_of_format (p, ref_file); } } while (go_on); } /** @brief PROC ([] SIMPLIN) VOID read f @param p Node in syntax tree. **/ void genie_read_format (NODE_T * p) { A68_REF row; POP_REF (p, &row); genie_stand_in (p); PUSH_REF (p, row); genie_read_file_format (p); } /** @brief PROC (REF FILE, [] SIMPLIN) VOID get f @param p Node in syntax tree. **/ void genie_read_file_format (NODE_T * p) { A68_REF ref_file; A68_FILE *file; A68_REF row; A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *base_address; int elems, k, elem_index, formats; ADDR_T save_frame_pointer, save_stack_pointer; POP_REF (p, &row); CHECK_REF (p, row, MODE (ROW_SIMPLIN)); GET_DESCRIPTOR (arr, tup, &row); elems = ROW_SIZE (tup); POP_REF (p, &ref_file); CHECK_REF (p, ref_file, MODE (REF_FILE)); file = FILE_DEREF (&ref_file); CHECK_INIT (p, INITIALISED (file), MODE (FILE)); if (!OPENED (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_NOT_OPEN); exit_genie (p, A68_RUNTIME_ERROR); } if (DRAW_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "draw"); exit_genie (p, A68_RUNTIME_ERROR); } if (WRITE_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "write"); exit_genie (p, A68_RUNTIME_ERROR); } if (!GET (&CHANNEL (file))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CHANNEL_DOES_NOT_ALLOW, "getting"); exit_genie (p, A68_RUNTIME_ERROR); } if (!READ_MOOD (file) && !WRITE_MOOD (file)) { if (IS_NIL (STRING (file))) { if ((FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0)) == A68_NO_FILENO) { open_error (p, ref_file, "getting"); } } else { FD (file) = open_physical_file (p, ref_file, A68_READ_ACCESS, 0); } DRAW_MOOD (file) = A68_FALSE; READ_MOOD (file) = A68_TRUE; WRITE_MOOD (file) = A68_FALSE; CHAR_MOOD (file) = A68_TRUE; } if (!CHAR_MOOD (file)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_WRONG_MOOD, "binary"); exit_genie (p, A68_RUNTIME_ERROR); } /* Save stack state since formats have frames */ save_frame_pointer = FRAME_POINTER (file); save_stack_pointer = STACK_POINTER (file); FRAME_POINTER (file) = frame_pointer; STACK_POINTER (file) = stack_pointer; /* Process [] SIMPLIN */ if (BODY (&FORMAT (file)) != NO_NODE) { open_format_frame (p, ref_file, &FORMAT (file), NOT_EMBEDDED_FORMAT, A68_FALSE); } if (elems <= 0) { return; } formats = 0; base_address = DEREF (BYTE_T, &ARRAY (arr)); elem_index = 0; for (k = 0; k < elems; k++) { A68_UNION *z = (A68_UNION *) & (base_address[elem_index]); MOID_T *mode = (MOID_T *) (VALUE (z)); BYTE_T *item = (BYTE_T *) & (base_address[elem_index + A68_UNION_SIZE]); if (mode == MODE (FORMAT)) { /* Forget about eventual active formats and set up new one */ if (formats > 0) { purge_format_read (p, ref_file); } formats++; frame_pointer = FRAME_POINTER (file); stack_pointer = STACK_POINTER (file); open_format_frame (p, ref_file, (A68_FORMAT *) item, NOT_EMBEDDED_FORMAT, A68_TRUE); } else if (mode == MODE (PROC_REF_FILE_VOID)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (PROC_REF_FILE_VOID)); exit_genie (p, A68_RUNTIME_ERROR); } else if (mode == MODE (REF_SOUND)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNDEFINED_TRANSPUT, MODE (REF_SOUND)); exit_genie (p, A68_RUNTIME_ERROR); } else { CHECK_REF (p, *(A68_REF *) item, mode); genie_read_standard_format (p, SUB (mode), ADDRESS ((A68_REF *) item), ref_file); } elem_index += SIZE (MODE (SIMPLIN)); } /* Empty the format to purge insertions */ purge_format_read (p, ref_file); BODY (&FORMAT (file)) = NO_NODE; /* Forget about active formats */ frame_pointer = FRAME_POINTER (file); stack_pointer = STACK_POINTER (file); FRAME_POINTER (file) = save_frame_pointer; STACK_POINTER (file) = save_stack_pointer; } /*********************/ /* Numerical library */ /*********************/ /* Note that the interpreter has its own routines for these simple tasks that often are optimised to work with values pushed on the stack, and that perform runtime checks. These functions are not mangled to fit below routines. */ /** @brief Sqrt (x^2 + y^2) that does not needlessly overflow. @param x X. @param y Y. @return See brief description. **/ double a68g_hypot (double x, double y) { double xabs = ABS (x), yabs = ABS (y); double min, max; if (xabs < yabs) { min = xabs; max = yabs; } else { min = yabs; max = xabs; } if (min == 0.0) { return (max); } else { double u = min / max; return (max * sqrt (1.0 + u * u)); } } /** @brief Log (1 + x) with anti-cancellation for IEEE 754. @param x X. @return See brief description. **/ double a68g_log1p (double x) { volatile double y; y = 1 + x; return log (y) - ((y - 1) - x) / y; /* cancel errors with IEEE arithmetic */ } /** @brief OP ROUND = (REAL) INT **/ int a68g_round (double x) { if (x >= 0) { return ((int) (x + 0.5)); } else { return ((int) (x - 0.5)); } } /** PROC exp = (REAL) REAL **/ double a68g_exp (double x) { if (x < log (DBL_MIN)) { return (0.0); } else { return (exp (x)); } } /** @brief PROC atan2 (REAL, REAL) REAL **/ double a68g_atan2 (double x, double y) { if (x == 0.0 && y == 0.0) { errno = EDOM; return (0.0); } else { BOOL_T flip = (BOOL_T) (y < 0.0); double z; y = ABS (y); if (x == 0.0) { z = A68_PI / 2.0; } else { BOOL_T flop = (BOOL_T) (x < 0.0); x = ABS (x); z = atan (y / x); if (flop) { z = A68_PI - z; } } if (flip) { z = -z; } return (z); } } /** @brief PROC asinh = (REAL) REAL **/ double a68g_asinh (double x) { double a = ABS (x), s = (x < 0.0 ? -1.0 : 1.0); if (a > 1.0 / sqrt (DBL_EPSILON)) { return (s * (log (a) + log (2.0))); } else if (a > 2.0) { return (s * log (2.0 * a + 1.0 / (a + sqrt (a * a + 1.0)))); } else if (a > sqrt (DBL_EPSILON)) { double a2 = a * a; return (s * a68g_log1p (a + a2 / (1.0 + sqrt (1.0 + a2)))); } else { return (x); } } /** @brief PROC acosh = (REAL) REAL **/ double a68g_acosh (double x) { if (x > 1.0 / sqrt (DBL_EPSILON)) { return (log (x) + log (2.0)); } else if (x > 2.0) { return (log (2.0 * x - 1.0 / (sqrt (x * x - 1.0) + x))); } else if (x > 1.0) { double t = x - 1.0; return (a68g_log1p (t + sqrt (2.0 * t + t * t))); } else if (x == 1.0) { return (0.0); } else { errno = EDOM; return (0.0); } } /** @brief PROC atanh = (REAL) REAL **/ double a68g_atanh (double x) { double a = ABS (x); double s = (double) (x < 0 ? -1 : 1); if (a >= 1.0) { errno = EDOM; return (0.0); } else if (a >= 0.5) { return (s * 0.5 * a68g_log1p (2 * a / (1.0 - a))); } else if (a > DBL_EPSILON) { return (s * 0.5 * a68g_log1p (2.0 * a + 2.0 * a * a / (1.0 - a))); } else { return (x); } } /** @brief OP ** = (REAL, REAL) REAL **/ double a68g_pow_real (double x, double y) { return (exp (y * log (x))); } /** @brief OP ** = (REAL, INT) REAL **/ double a68g_pow_real_int (double x, int n) { switch (n) { case 2: return (x * x); case 3: return (x * x * x); case 4: {double y = x * x; return (y * y);} case 5: {double y = x * x; return (x * y * y);} case 6: {double y = x * x * x; return (y * y);} default: { int expo = 1, m = (int) labs (n); BOOL_T cont = (m > 0); double mult = x, prod = 1; while (cont) { if ((m & expo) != 0) { prod *= mult; } expo *= 2; cont = (expo <= m); if (cont) { mult *= mult; } } return (n < 0 ? 1 / prod : prod); } } } /** @brief OP / = (COMPLEX, COMPLEX) COMPLEX **/ void a68g_div_complex (A68_REAL * z, A68_REAL * x, A68_REAL * y) { if (RE (y) == 0 && IM (y) == 0) { RE (z) = 0.0; IM (z) = 0.0; errno = EDOM; } else if (fabs (RE (y)) >= fabs (IM (y))) { double r = IM (y) / RE (y), den = RE (y) + r * IM (y); STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; RE (z) = (RE (x) + r * IM (x)) / den; IM (z) = (IM (x) - r * RE (x)) / den; } else { double r = RE (y) / IM (y), den = IM (y) + r * RE (y); STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; RE (z) = (RE (x) * r + IM (x)) / den; IM (z) = (IM (x) * r - RE (x)) / den; } } /** @brief PROC csqrt = (COMPLEX) COMPLEX **/ void a68g_sqrt_complex (A68_REAL * z, A68_REAL * x) { STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; if (RE (x) == 0.0 && IM (x) == 0.0) { RE (z) = 0.0; IM (z) = 0.0; } else { double re = fabs (RE (x)), im = fabs (IM (x)), w; if (re >= im) { double t = im / re; w = sqrt (re) * sqrt (0.5 * (1.0 + sqrt (1.0 + t * t))); } else { double t = re / im; w = sqrt (im) * sqrt (0.5 * (t + sqrt (1.0 + t * t))); } if (RE (x) >= 0.0) { RE (z) = w; IM (z) = IM (x) / (2.0 * w); } else { double ai = IM (x); double vi = (ai >= 0.0 ? w : -w); RE (z) = ai / (2.0 * vi); IM (z) = vi; } } } /** @brief PROC cexp = (COMPLEX) COMPLEX **/ void a68g_exp_complex (A68_REAL * z, A68_REAL * x) { double r = exp (RE (x)); STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; RE (z) = r * cos (IM (x)); IM (z) = r * sin (IM (x)); } /** @brief PROC cln = (COMPLEX) COMPLEX **/ void a68g_ln_complex (A68_REAL * z, A68_REAL * x) { STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; RE (z) = log (a68g_abs_complex (x)); IM (z) = a68g_arg_complex (x); } /** @brief PROC csin = (COMPLEX) COMPLEX **/ void a68g_sin_complex (A68_REAL * z, A68_REAL * x) { STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; if (IM (x) == 0) { RE (z) = sin (RE (x)); IM (z) = 0; } else { RE (z) = sin (RE (x)) * cosh (IM (x)); IM (z) = cos (RE (x)) * sinh (IM (x)); } } /** @brief PROC ccos = (COMPLEX) COMPLEX **/ void a68g_cos_complex (A68_REAL * z, A68_REAL * x) { STATUS_RE (z) = INIT_MASK; STATUS_IM (z) = INIT_MASK; if (IM (x) == 0) { RE (z) = cos (RE (x)); IM (z) = 0; } else { RE (z) = cos (RE (x)) * cosh (IM (x)); IM (z) = sin (RE (x)) * sinh (-IM (x)); } } /** @brief PROC ctan = (COMPLEX) COMPLEX **/ void a68g_tan_complex (A68_REAL * z, A68_REAL * x) { A68_COMPLEX u, v; STATUS_RE (u) = INIT_MASK; STATUS_IM (u) = INIT_MASK; STATUS_RE (v) = INIT_MASK; STATUS_IM (v) = INIT_MASK; if (IM (x) == 0) { RE (u) = sin (RE (x)); IM (u) = 0; RE (v) = cos (RE (x)); IM (v) = 0; } else { RE (u) = sin (RE (x)) * cosh (IM (x)); IM (u) = cos (RE (x)) * sinh (IM (x)); RE (v) = cos (RE (x)) * cosh (IM (x)); IM (v) = sin (RE (x)) * sinh (-IM (x)); } a68g_div_complex (z, u, v); } /** @brief PROC casin = (COMPLEX) COMPLEX **/ void a68g_arcsin_complex (A68_REAL * z, A68_REAL * x) { double r = RE (x), i = IM (x); if (i == 0) { RE (z) = asin (r); IM (z) = 0; } else { double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i); double a = 0.5 * (u + v), b = 0.5 * (u - v); RE (z) = asin (b); IM (z) = log (a + sqrt (a * a - 1)); } } /** @brief PROC cacos = (COMPLEX) COMPLEX **/ void a68g_arccos_complex (A68_REAL * z, A68_REAL * x) { double r = RE (x), i = IM (x); if (i == 0) { RE (z) = acos (r); IM (z) = 0; } else { double u = a68g_hypot (r + 1, i), v = a68g_hypot (r - 1, i); double a = 0.5 * (u + v), b = 0.5 * (u - v); RE (z) = acos (b); IM (z) = -log (a + sqrt (a * a - 1)); } } /** @brief PROC catan = (COMPLEX) COMPLEX **/ void a68g_arctan_complex (A68_REAL * z, A68_REAL * x) { double r = RE (x), i = IM (x); if (i == 0) { RE (z) = atan (r); IM (z) = 0; } else { double a = a68g_hypot (r, i + 1), b = a68g_hypot (r, i - 1); RE (z) = 0.5 * atan (2 * r / (1 - r * r - i * i)); IM (z) = 0.5 * log (a / b); } } /* Operators for ROWS */ /** @brief OP ELEMS = (ROWS) INT @param p Position in syntax tree. **/ void genie_monad_elems (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); GET_DESCRIPTOR (x, t, &z); PUSH_PRIMITIVE (p, get_row_size (t, DIM (x)), A68_INT); } /** @brief OP LWB = (ROWS) INT @param p Position in syntax tree. **/ void genie_monad_lwb (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); GET_DESCRIPTOR (x, t, &z); PUSH_PRIMITIVE (p, LWB (t), A68_INT); } /** @brief OP UPB = (ROWS) INT @param p Position in syntax tree. **/ void genie_monad_upb (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); GET_DESCRIPTOR (x, t, &z); PUSH_PRIMITIVE (p, UPB (t), A68_INT); } /** @brief OP ELEMS = (INT, ROWS) INT @param p Position in syntax tree. **/ void genie_dyad_elems (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t, *u; A68_INT k; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (x, t, &z); if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k)); exit_genie (p, A68_RUNTIME_ERROR); } u = &(t[VALUE (&k) - 1]); PUSH_PRIMITIVE (p, ROW_SIZE (u), A68_INT); } /** @brief OP LWB = (INT, ROWS) INT @param p Position in syntax tree. **/ void genie_dyad_lwb (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t; A68_INT k; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (x, t, &z); if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, LWB (&(t[VALUE (&k) - 1])), A68_INT); } /** @brief OP UPB = (INT, ROWS) INT @param p Position in syntax tree. **/ void genie_dyad_upb (NODE_T * p) { A68_REF z; A68_ARRAY *x; A68_TUPLE *t; A68_INT k; POP_REF (p, &z); /* Decrease pointer since a UNION is on the stack */ DECREMENT_STACK_POINTER (p, A68_UNION_SIZE); CHECK_REF (p, z, MODE (ROWS)); POP_OBJECT (p, &k, A68_INT); GET_DESCRIPTOR (x, t, &z); if (VALUE (&k) < 1 || VALUE (&k) > DIM (x)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INVALID_DIMENSION, (int) VALUE (&k)); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_PRIMITIVE (p, UPB (&(t[VALUE (&k) - 1])), A68_INT); } /* Implements SOUND values. */ #define MAX_BYTES 4 #define A68_LITTLE_ENDIAN A68_TRUE #define A68_BIG_ENDIAN A68_FALSE /* From public Microsoft RIFF documentation */ #define WAVE_FORMAT_UNKNOWN (0x0000) #define WAVE_FORMAT_PCM (0x0001) #define WAVE_FORMAT_ADPCM (0x0002) #define WAVE_FORMAT_IEEE_FLOAT (0x0003) #define WAVE_FORMAT_IBM_FORMAT_CVSD (0x0005) #define WAVE_FORMAT_ALAW (0x0006) #define WAVE_FORMAT_MULAW (0x0007) #define WAVE_FORMAT_OKI_ADPCM (0x0010) #define WAVE_FORMAT_DVI_ADPCM (0x0011) #define WAVE_FORMAT_MEDIASPACE_ADPCM (0x0012) #define WAVE_FORMAT_SIERRA_ADPCM (0x0013) #define WAVE_FORMAT_G723_ADPCM (0X0014) #define WAVE_FORMAT_DIGISTD (0x0015) #define WAVE_FORMAT_DIGIFIX (0x0016) #define WAVE_FORMAT_YAMAHA_ADPCM (0x0020) #define WAVE_FORMAT_SONARC (0x0021) #define WAVE_FORMAT_DSPGROUP_TRUESPEECH (0x0022) #define WAVE_FORMAT_ECHOSCI1 (0x0023) #define WAVE_FORMAT_AUDIOFILE_AF36 (0x0024) #define WAVE_FORMAT_APTX (0x0025) #define WAVE_FORMAT_AUDIOFILE_AF10 (0x0026) #define WAVE_FORMAT_DOLBY_AC2 (0x0030) #define WAVE_FORMAT_GSM610 (0x0031) #define WAVE_FORMAT_ANTEX_ADPCME (0x0033) #define WAVE_FORMAT_CONTROL_RES_VQLPC (0x0034) #define WAVE_FORMAT_DIGIREAL (0x0035) #define WAVE_FORMAT_DIGIADPCM (0x0036) #define WAVE_FORMAT_CONTROL_RES_CR10 (0x0037) #define WAVE_FORMAT_NMS_VBXADPCM (0x0038) #define WAVE_FORMAT_ROCKWELL_ADPCM (0x003b) #define WAVE_FORMAT_ROCKWELL_DIGITALK (0x003c) #define WAVE_FORMAT_G721_ADPCM (0x0040) #define WAVE_FORMAT_G728_CELP (0x0041) #define WAVE_FORMAT_MPEG (0x0050) #define WAVE_FORMAT_MPEGLAYER3 (0x0055) #define WAVE_FORMAT_G726_ADPCM (0x0064) #define WAVE_FORMAT_G722_ADPCM (0x0065) #define WAVE_FORMAT_IBM_FORMAT_MULAW (0x0101) #define WAVE_FORMAT_IBM_FORMAT_ALAW (0x0102) #define WAVE_FORMAT_IBM_FORMAT_ADPCM (0x0103) #define WAVE_FORMAT_CREATIVE_ADPCM (0x0200) #define WAVE_FORMAT_FM_TOWNS_SND (0x0300) #define WAVE_FORMAT_OLIGSM (0x1000) #define WAVE_FORMAT_OLIADPCM (0x1001) #define WAVE_FORMAT_OLICELP (0x1002) #define WAVE_FORMAT_OLISBC (0x1003) #define WAVE_FORMAT_OLIOPR (0x1004) #define WAVE_FORMAT_EXTENSIBLE (0xfffe) static unsigned pow256[] = { 1, 256, 65536, 16777216 }; /** @brief Test bits per sample. @param p Node in syntax tree. @param bps Bits per second. **/ static void test_bits_per_sample (NODE_T * p, unsigned bps) { if (bps <= 0 || bps > 24) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "unsupported number of bits per sample"); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief Code string into big-endian unsigned. @param p Node in syntax tree. @param s String to code. @param n Chars to code. **/ static unsigned code_string (NODE_T * p, char *s, int n) { unsigned v; int k, m; if (n > MAX_BYTES) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "too long word length"); exit_genie (p, A68_RUNTIME_ERROR); } for (k = 0, m = n - 1, v = 0; k < n; k++, m--) { v += ((unsigned) s[k]) * pow256[m]; } return (v); } /** @brief Code unsigned into string. @param p Node in syntax tree. @param n Value to code. **/ static char *code_unsigned (NODE_T * p, unsigned n) { static char text[MAX_BYTES + 1]; int k; (void) p; for (k = 0; k < MAX_BYTES; k++) { char ch = (char) (n % 0x100); if (ch == NULL_CHAR) { ch = BLANK_CHAR; } else if (ch < BLANK_CHAR) { ch = '?'; } text[MAX_BYTES - k - 1] = ch; n >>= 8; } text[MAX_BYTES] = NULL_CHAR; return (text); } /** @brief WAVE format category @param n Category number. **/ static char *format_category (unsigned n) { switch (n) { case WAVE_FORMAT_UNKNOWN: { return ("WAVE_FORMAT_UNKNOWN"); } case WAVE_FORMAT_PCM: { return ("WAVE_FORMAT_PCM "); } case WAVE_FORMAT_ADPCM: { return ("WAVE_FORMAT_ADPCM"); } case WAVE_FORMAT_IEEE_FLOAT: { return ("WAVE_FORMAT_IEEE_FLOAT"); } case WAVE_FORMAT_IBM_FORMAT_CVSD: { return ("WAVE_FORMAT_IBM_FORMAT_CVSD"); } case WAVE_FORMAT_ALAW: { return ("WAVE_FORMAT_ALAW"); } case WAVE_FORMAT_MULAW: { return ("WAVE_FORMAT_MULAW"); } case WAVE_FORMAT_OKI_ADPCM: { return ("WAVE_FORMAT_OKI_ADPCM"); } case WAVE_FORMAT_DVI_ADPCM: { return ("WAVE_FORMAT_DVI_ADPCM"); } case WAVE_FORMAT_MEDIASPACE_ADPCM: { return ("WAVE_FORMAT_MEDIASPACE_ADPCM"); } case WAVE_FORMAT_SIERRA_ADPCM: { return ("WAVE_FORMAT_SIERRA_ADPCM"); } case WAVE_FORMAT_G723_ADPCM: { return ("WAVE_FORMAT_G723_ADPCM"); } case WAVE_FORMAT_DIGISTD: { return ("WAVE_FORMAT_DIGISTD"); } case WAVE_FORMAT_DIGIFIX: { return ("WAVE_FORMAT_DIGIFIX"); } case WAVE_FORMAT_YAMAHA_ADPCM: { return ("WAVE_FORMAT_YAMAHA_ADPCM"); } case WAVE_FORMAT_SONARC: { return ("WAVE_FORMAT_SONARC"); } case WAVE_FORMAT_DSPGROUP_TRUESPEECH: { return ("WAVE_FORMAT_DSPGROUP_TRUESPEECH"); } case WAVE_FORMAT_ECHOSCI1: { return ("WAVE_FORMAT_ECHOSCI1"); } case WAVE_FORMAT_AUDIOFILE_AF36: { return ("WAVE_FORMAT_AUDIOFILE_AF36"); } case WAVE_FORMAT_APTX: { return ("WAVE_FORMAT_APTX"); } case WAVE_FORMAT_AUDIOFILE_AF10: { return ("WAVE_FORMAT_AUDIOFILE_AF10"); } case WAVE_FORMAT_DOLBY_AC2: { return ("WAVE_FORMAT_DOLBY_AC2"); } case WAVE_FORMAT_GSM610: { return ("WAVE_FORMAT_GSM610 "); } case WAVE_FORMAT_ANTEX_ADPCME: { return ("WAVE_FORMAT_ANTEX_ADPCME"); } case WAVE_FORMAT_CONTROL_RES_VQLPC: { return ("WAVE_FORMAT_CONTROL_RES_VQLPC"); } case WAVE_FORMAT_DIGIREAL: { return ("WAVE_FORMAT_DIGIREAL"); } case WAVE_FORMAT_DIGIADPCM: { return ("WAVE_FORMAT_DIGIADPCM"); } case WAVE_FORMAT_CONTROL_RES_CR10: { return ("WAVE_FORMAT_CONTROL_RES_CR10"); } case WAVE_FORMAT_NMS_VBXADPCM: { return ("WAVE_FORMAT_NMS_VBXADPCM"); } case WAVE_FORMAT_ROCKWELL_ADPCM: { return ("WAVE_FORMAT_ROCKWELL_ADPCM"); } case WAVE_FORMAT_ROCKWELL_DIGITALK: { return ("WAVE_FORMAT_ROCKWELL_DIGITALK"); } case WAVE_FORMAT_G721_ADPCM: { return ("WAVE_FORMAT_G721_ADPCM"); } case WAVE_FORMAT_G728_CELP: { return ("WAVE_FORMAT_G728_CELP"); } case WAVE_FORMAT_MPEG: { return ("WAVE_FORMAT_MPEG"); } case WAVE_FORMAT_MPEGLAYER3: { return ("WAVE_FORMAT_MPEGLAYER3"); } case WAVE_FORMAT_G726_ADPCM: { return ("WAVE_FORMAT_G726_ADPCM"); } case WAVE_FORMAT_G722_ADPCM: { return ("WAVE_FORMAT_G722_ADPCM"); } case WAVE_FORMAT_IBM_FORMAT_MULAW: { return ("WAVE_FORMAT_IBM_FORMAT_MULAW"); } case WAVE_FORMAT_IBM_FORMAT_ALAW: { return ("WAVE_FORMAT_IBM_FORMAT_ALAW"); } case WAVE_FORMAT_IBM_FORMAT_ADPCM: { return ("WAVE_FORMAT_IBM_FORMAT_ADPCM"); } case WAVE_FORMAT_CREATIVE_ADPCM: { return ("WAVE_FORMAT_CREATIVE_ADPCM"); } case WAVE_FORMAT_FM_TOWNS_SND: { return ("WAVE_FORMAT_FM_TOWNS_SND"); } case WAVE_FORMAT_OLIGSM: { return ("WAVE_FORMAT_OLIGSM"); } case WAVE_FORMAT_OLIADPCM: { return ("WAVE_FORMAT_OLIADPCM"); } case WAVE_FORMAT_OLICELP: { return ("WAVE_FORMAT_OLICELP"); } case WAVE_FORMAT_OLISBC: { return ("WAVE_FORMAT_OLISBC"); } case WAVE_FORMAT_OLIOPR: { return ("WAVE_FORMAT_OLIOPR"); } case WAVE_FORMAT_EXTENSIBLE: { return ("WAVE_FORMAT_EXTENSIBLE"); } default: { return ("other"); } } } /** @brief Read RIFF item. @param p Node in syntax tree. @param fd File number. @param n Word length. @param little Whether little-endian. **/ static unsigned read_riff_item (NODE_T * p, FILE_T fd, int n, BOOL_T little) { unsigned v, z; int k, m, r; if (n > MAX_BYTES) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "too long word length"); exit_genie (p, A68_RUNTIME_ERROR); } if (little) { for (k = 0, m = 0, v = 0; k < n; k++, m++) { z = 0; r = (int) io_read (fd, &z, (size_t) 1); if (r != 1 || errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while reading file"); exit_genie (p, A68_RUNTIME_ERROR); } v += z * pow256[m]; } } else { for (k = 0, m = n - 1, v = 0; k < n; k++, m--) { z = 0; r = (int) io_read (fd, &z, (size_t) 1); if (r != 1 || errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while reading file"); exit_genie (p, A68_RUNTIME_ERROR); } v += z * pow256[m]; } } return (v); } /** @brief Read sound from file. @param p Node in syntax tree. @param ref_file Pointer to file. @param w Sound object. **/ void read_sound (NODE_T * p, A68_REF ref_file, A68_SOUND * w) { A68_FILE *f = FILE_DEREF (&ref_file); int r; unsigned fmt_cat; unsigned blockalign, byterate, chunksize, subchunk2size, z; BOOL_T data_read = A68_FALSE; if (read_riff_item (p, FD (f), 4, A68_BIG_ENDIAN) != code_string (p, "RIFF", 4)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "file format is not RIFF"); exit_genie (p, A68_RUNTIME_ERROR); } chunksize = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); if ((z = read_riff_item (p, FD (f), 4, A68_BIG_ENDIAN)) != code_string (p, "WAVE", 4)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, MODE (SOUND), "file format is not \"WAVE\" but", code_unsigned (p, z)); exit_genie (p, A68_RUNTIME_ERROR); } /* Now read chunks */ while (data_read == A68_FALSE) { z = read_riff_item (p, FD (f), 4, A68_BIG_ENDIAN); if (z == code_string (p, "fmt ", 4)) { /* Read fmt chunk */ int k, skip; z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); skip = (int) z - 0x10; /* Bytes to skip in extended wave format */ fmt_cat = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN); if (fmt_cat != WAVE_FORMAT_PCM) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, MODE (SOUND), "category is not WAVE_FORMAT_PCM but", format_category (fmt_cat)); exit_genie (p, A68_RUNTIME_ERROR); } NUM_CHANNELS (w) = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN); SAMPLE_RATE (w) = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); byterate = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); blockalign = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN); BITS_PER_SAMPLE (w) = read_riff_item (p, FD (f), 2, A68_LITTLE_ENDIAN); test_bits_per_sample (p, BITS_PER_SAMPLE (w)); for (k = 0; k < skip; k++) { z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN); } } else if (z == code_string (p, "LIST", 4)) { /* Skip a LIST chunk */ int k, skip; z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); skip = (int) z; for (k = 0; k < skip; k++) { z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN); } } else if (z == code_string (p, "cue ", 4)) { /* Skip a cue chunk */ int k, skip; z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); skip = (int) z; for (k = 0; k < skip; k++) { z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN); } } else if (z == code_string (p, "fact", 4)) { /* Skip a fact chunk */ int k, skip; z = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); skip = (int) z; for (k = 0; k < skip; k++) { z = read_riff_item (p, FD (f), 1, A68_LITTLE_ENDIAN); } } else if (z == code_string (p, "data", 4)) { /* Read data chunk */ subchunk2size = read_riff_item (p, FD (f), 4, A68_LITTLE_ENDIAN); NUM_SAMPLES (w) = subchunk2size / NUM_CHANNELS (w) / (unsigned) A68_SOUND_BYTES (w); DATA (w) = heap_generator (p, MODE (SOUND_DATA), (int) subchunk2size); r = (int) io_read (FD (f), ADDRESS (&(DATA (w))), subchunk2size); if (r != (int) subchunk2size) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "cannot read all of the data"); exit_genie (p, A68_RUNTIME_ERROR); } data_read = A68_TRUE; } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL_STRING, MODE (SOUND), "chunk is", code_unsigned (p, z)); exit_genie (p, A68_RUNTIME_ERROR); } } STATUS (w) = INIT_MASK; } /** @brief Write RIFF item. @param p Node in syntax tree. @param fd File number. @param z Item. @param n Number of chars. @param little Whether little endian. **/ void write_riff_item (NODE_T * p, FILE_T fd, unsigned z, int n, BOOL_T little) { int k, r; unsigned char y[MAX_BYTES]; if (n > MAX_BYTES) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "too long word length"); exit_genie (p, A68_RUNTIME_ERROR); } for (k = 0; k < n; k++) { y[k] = (unsigned char) (z & 0xff); z >>= 8; } if (little) { for (k = 0; k < n; k++) { ASSERT (io_write (fd, &(y[k]), 1) != -1); } } else { for (k = n - 1; k >= 0; k--) { r = (int) io_write (fd, &(y[k]), 1); if (r != 1) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while writing file"); exit_genie (p, A68_RUNTIME_ERROR); } } } } /** @brief Write sound to file. @param p Node in syntax tree. @param ref_file Pointer to file. @param w Sound object. **/ void write_sound (NODE_T * p, A68_REF ref_file, A68_SOUND * w) { A68_FILE *f = FILE_DEREF (&ref_file); int r; unsigned blockalign = NUM_CHANNELS (w) * (unsigned) (A68_SOUND_BYTES (w)); unsigned byterate = SAMPLE_RATE (w) * blockalign; unsigned subchunk2size = NUM_SAMPLES (w) * blockalign; unsigned chunksize = 4 + (8 + 16) + (8 + subchunk2size); write_riff_item (p, FD (f), code_string (p, "RIFF", 4), 4, A68_BIG_ENDIAN); write_riff_item (p, FD (f), chunksize, 4, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), code_string (p, "WAVE", 4), 4, A68_BIG_ENDIAN); write_riff_item (p, FD (f), code_string (p, "fmt ", 4), 4, A68_BIG_ENDIAN); write_riff_item (p, FD (f), 16, 4, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), 1, 2, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), NUM_CHANNELS (w), 2, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), SAMPLE_RATE (w), 4, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), byterate, 4, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), blockalign, 2, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), BITS_PER_SAMPLE (w), 2, A68_LITTLE_ENDIAN); write_riff_item (p, FD (f), code_string (p, "data", 4), 4, A68_BIG_ENDIAN); write_riff_item (p, FD (f), subchunk2size, 4, A68_LITTLE_ENDIAN); if (IS_NIL (DATA (w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sound has no data"); exit_genie (p, A68_RUNTIME_ERROR); } r = (int) io_write (FD (f), ADDRESS (&(DATA (w))), subchunk2size); if (r != (int) subchunk2size) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "error while writing file"); exit_genie (p, A68_RUNTIME_ERROR); } } /** @brief PROC new sound = (INT bits, INT sample rate, INT channels, INT samples) SOUND @param p Node in syntax tree. **/ void genie_new_sound (NODE_T * p) { A68_INT num_channels, sample_rate, bits_per_sample, num_samples; A68_SOUND w; POP_OBJECT (p, &num_samples, A68_INT); POP_OBJECT (p, &num_channels, A68_INT); POP_OBJECT (p, &sample_rate, A68_INT); POP_OBJECT (p, &bits_per_sample, A68_INT); NUM_SAMPLES (&w) = (unsigned) (VALUE (&num_samples)); NUM_CHANNELS (&w) = (unsigned) (VALUE (&num_channels)); SAMPLE_RATE (&w) = (unsigned) (VALUE (&sample_rate)); BITS_PER_SAMPLE (&w) = (unsigned) (VALUE (&bits_per_sample)); test_bits_per_sample (p, BITS_PER_SAMPLE (&w)); DATA_SIZE (&w) = (unsigned) A68_SOUND_DATA_SIZE (&w); DATA (&w) = heap_generator (p, MODE (SOUND_DATA), (int) DATA_SIZE (&w)); STATUS (&w) = INIT_MASK; PUSH_OBJECT (p, w, A68_SOUND); } /** @brief PROC get sound = (SOUND w, INT channel, sample) INT @param p Node in syntax tree. **/ void genie_get_sound (NODE_T * p) { A68_INT channel, sample; A68_SOUND w; int addr, k, n, z, m; BYTE_T *d; POP_OBJECT (p, &sample, A68_INT); POP_OBJECT (p, &channel, A68_INT); POP_OBJECT (p, &w, A68_SOUND); if (!(VALUE (&channel) >= 1 && VALUE (&channel) <= (int) NUM_CHANNELS (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "channel index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (!(VALUE (&sample) >= 1 && VALUE (&sample) <= (int) NUM_SAMPLES (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sample index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (IS_NIL (DATA (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sound has no data"); exit_genie (p, A68_RUNTIME_ERROR); } n = A68_SOUND_BYTES (&w); addr = ((VALUE (&sample) - 1) * (int) (NUM_CHANNELS (&w)) + (VALUE (&channel) - 1)) * n; ABEND (addr < 0 || addr >= (int) DATA_SIZE (&w), ERROR_INTERNAL_CONSISTENCY, NO_TEXT); d = &(ADDRESS (&(DATA (&w)))[addr]); /* Convert from little-endian, irrespective from the platform we work on */ for (k = 0, z = 0, m = 0; k < n; k++) { z += ((int) (d[k]) * (int) (pow256[k])); m = k; } PUSH_PRIMITIVE (p, (d[m] & 0x80 ? (n == 4 ? z : z - (int) pow256[m + 1]) : z), A68_INT); } /** @brief PROC set sound = (SOUND w, INT channel, sample, value) VOID @param p Node in syntax tree. **/ void genie_set_sound (NODE_T * p) { A68_INT channel, sample, value; int addr, k, n, z; BYTE_T *d; A68_SOUND w; POP_OBJECT (p, &value, A68_INT); POP_OBJECT (p, &sample, A68_INT); POP_OBJECT (p, &channel, A68_INT); POP_OBJECT (p, &w, A68_SOUND); if (!(VALUE (&channel) >= 1 && VALUE (&channel) <= (int) NUM_CHANNELS (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "channel index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (!(VALUE (&sample) >= 1 && VALUE (&sample) <= (int) NUM_SAMPLES (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sample index out of range"); exit_genie (p, A68_RUNTIME_ERROR); } if (IS_NIL (DATA (&w))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_SOUND_INTERNAL, MODE (SOUND), "sound has no data"); exit_genie (p, A68_RUNTIME_ERROR); } n = A68_SOUND_BYTES (&w); addr = ((VALUE (&sample) - 1) * (int) (NUM_CHANNELS (&w)) + (VALUE (&channel) - 1)) * n; ABEND (addr < 0 || addr >= (int) DATA_SIZE (&w), ERROR_INTERNAL_CONSISTENCY, NO_TEXT); d = &(ADDRESS (&(DATA (&w)))[addr]); /* Convert to little-endian */ for (k = 0, z = VALUE (&value); k < n; k++) { d[k] = (BYTE_T) (z & 0xff); z >>= 8; } } /** @brief OP SOUND = (SOUND) INT @param p Node in syntax tree. **/ void genie_sound_samples (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_PRIMITIVE (p, (int) (NUM_SAMPLES (&w)), A68_INT); } /** @brief OP RATE = (SOUND) INT @param p Node in syntax tree. **/ void genie_sound_rate (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_PRIMITIVE (p, (int) (SAMPLE_RATE (&w)), A68_INT); } /** @brief OP CHANNELS = (SOUND) INT @param p Node in syntax tree. **/ void genie_sound_channels (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_PRIMITIVE (p, (int) (NUM_CHANNELS (&w)), A68_INT); } /** @brief OP RESOLUTION = (SOUND) INT @param p Node in syntax tree. **/ void genie_sound_resolution (NODE_T * p) { A68_SOUND w; POP_OBJECT (p, &w, A68_SOUND); PUSH_PRIMITIVE (p, (int) (BITS_PER_SAMPLE (&w)), A68_INT); } /** Unix extensions to A68G */ #define MAX_RESTART 256 BOOL_T halt_typing; static int chars_in_tty_line; char output_line[BUFFER_SIZE], edit_line[BUFFER_SIZE], input_line[BUFFER_SIZE]; /** @brief Initialise output to STDOUT. **/ void init_tty (void) { chars_in_tty_line = 0; halt_typing = A68_FALSE; change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_FALSE); } /** @brief Terminate current line on STDOUT. **/ void io_close_tty_line (void) { if (chars_in_tty_line > 0) { io_write_string (STDOUT_FILENO, NEWLINE_STRING); } } /** @brief Get a char from STDIN. @return See brief description. **/ char get_stdin_char (void) { ssize_t j; char ch[4]; RESET_ERRNO; j = io_read_conv (STDIN_FILENO, &(ch[0]), 1); ABEND (j < 0, "cannot read char from stdin", NO_TEXT); return ((char) (j == 1 ? ch[0] : EOF_CHAR)); } /** @brief Read string from STDIN, until NEWLINE_STRING. @param prompt Prompt string. @return Input line buffer. **/ char *read_string_from_tty (char *prompt) { #if defined HAVE_READLINE char * line = readline (prompt); if (line != NO_TEXT && (int) strlen (line) > 0) { add_history (line); } bufcpy (input_line, line, BUFFER_SIZE); chars_in_tty_line = (int) strlen (input_line); free (line); return (input_line); #else int ch, k = 0, n; if (prompt != NO_TEXT) { io_close_tty_line (); io_write_string (STDOUT_FILENO, prompt); } ch = get_stdin_char (); while (ch != NEWLINE_CHAR && k < BUFFER_SIZE - 1) { if (ch == EOF_CHAR) { input_line[0] = EOF_CHAR; input_line[1] = NULL_CHAR; chars_in_tty_line = 1; return (input_line); } else { input_line[k++] = (char) ch; ch = get_stdin_char (); } } input_line[k] = NULL_CHAR; n = (int) strlen (input_line); chars_in_tty_line = (ch == NEWLINE_CHAR ? 0 : (n > 0 ? n : 1)); return (input_line); #endif } /** @brief Write string to file. @param f File number. @param z String to write. **/ void io_write_string (FILE_T f, const char *z) { ssize_t j; RESET_ERRNO; if (f != STDOUT_FILENO && f != STDERR_FILENO) { /* Writing to file */ j = io_write_conv (f, z, strlen (z)); ABEND (j < 0, "cannot write", NO_TEXT); } else { /* Writing to TTY */ int first, k; /* Write parts until end-of-string */ first = 0; do { k = first; /* How far can we get? */ while (z[k] != NULL_CHAR && z[k] != NEWLINE_CHAR) { k++; } if (k > first) { /* Write these characters */ int n = k - first; j = io_write_conv (f, &(z[first]), (size_t) n); ABEND (j < 0, "cannot write", NO_TEXT); chars_in_tty_line += n; } if (z[k] == NEWLINE_CHAR) { /* Pretty-print newline */ k++; first = k; j = io_write_conv (f, NEWLINE_STRING, 1); ABEND (j < 0, "cannot write", NO_TEXT); chars_in_tty_line = 0; } } while (z[k] != NULL_CHAR); } } /** @brief Read bytes from file into buffer. @param fd File descriptor, must be open. @param buf Character buffer, size must be >= n. @param n Maximum number of bytes to read. @return Number of bytes read or -1 in case of error. **/ ssize_t io_read (FILE_T fd, void *buf, size_t n) { size_t to_do = n; int restarts = 0; char *z = (char *) buf; while (to_do > 0) { #if defined HAVE_WIN32 int bytes_read; #else ssize_t bytes_read; #endif RESET_ERRNO; 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) { break; /* EOF_CHAR */ } to_do -= (size_t) bytes_read; z += bytes_read; } return ((ssize_t) n - (ssize_t) to_do); /* return >= 0 */ } /** @brief Writes n bytes from buffer to file. @param fd File descriptor, must be open. @param buf Character buffer, size must be >= n. @param n Maximum number of bytes to write. @return N or -1 in case of error. **/ ssize_t io_write (FILE_T fd, const void *buf, size_t n) { size_t to_do = n; int restarts = 0; char *z = (char *) buf; while (to_do > 0) { ssize_t bytes_written; RESET_ERRNO; bytes_written = write (fd, z, to_do); if (bytes_written <= 0) { if (errno == EINTR) { /* interrupt, retry */ bytes_written = 0; if (restarts++ > MAX_RESTART) { return (-1); } } else { /* write error */ return (-1); } } to_do -= (size_t) bytes_written; z += bytes_written; } return ((ssize_t) n); } /** @brief Read bytes from file into buffer. @param fd File descriptor, must be open. @param buf Character buffer, size must be >= n. @param n Maximum number of bytes to read. @return Number of bytes read or -1 in case of error. **/ ssize_t io_read_conv (FILE_T fd, void *buf, size_t n) { size_t to_do = n; int restarts = 0; char *z = (char *) buf; while (to_do > 0) { #if defined HAVE_WIN32 int bytes_read; #else ssize_t bytes_read; #endif RESET_ERRNO; 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) { break; /* EOF_CHAR */ } to_do -= (size_t) bytes_read; z += bytes_read; } return ((ssize_t) n - (ssize_t) to_do); } /** @brief Writes n bytes from buffer to file. @param fd File descriptor, must be open. @param buf Character buffer, size must be >= n. @param n Maximum number of bytes to write. @return N or -1 in case of error. **/ ssize_t io_write_conv (FILE_T fd, const void *buf, size_t n) { size_t to_do = n; int restarts = 0; char *z = (char *) buf; while (to_do > 0) { ssize_t bytes_written; RESET_ERRNO; bytes_written = write (fd, z, to_do); if (bytes_written <= 0) { if (errno == EINTR) { /* interrupt, retry */ bytes_written = 0; if (restarts++ > MAX_RESTART) { return (-1); } } else { /* write error */ return (-1); } } to_do -= (size_t) bytes_written; z += bytes_written; } return ((ssize_t) n); } /* This code implements some UNIX/Linux/BSD related routines. In part contributed by Sian Leitch. */ #define VECTOR_SIZE 512 #define FD_READ 0 #define FD_WRITE 1 extern A68_REF tmp_to_a68_string (NODE_T *, char *); extern A68_CHANNEL stand_in_channel, stand_out_channel, stand_draw_channel, stand_back_channel, stand_error_channel; #if defined HAVE_DIRENT_H /** @brief PROC (STRING) [] STRING directory @param p Node in syntax tree. **/ void genie_directory (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); PUSH_PRIMITIVE (p, A68_MAX_INT, A68_INT); } else { char *dir_name = a_to_c_string (p, buffer, name); A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; int k, n = 0; A68_REF *base; DIR *dir; struct dirent *entry; dir = opendir (dir_name); if (dir == NULL) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } do { entry = readdir (dir); if (errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } if (entry != NULL) { n++; } } while (entry != NULL); rewinddir (dir); if (errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } z = heap_generator (p, MODE (ROW_STRING), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_STRING), n * SIZE (MODE (STRING))); DIM (&arr) = 1; MOID (&arr) = MODE (STRING); ELEM_SIZE (&arr) = SIZE (MODE (STRING)); SLICE_OFFSET (&arr) = 0; FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = n; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &z); base = DEREF (A68_REF, &row); for (k = 0; k < n; k++) { entry = readdir (dir); if (errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } base[k] = c_to_a_string (p, D_NAME (entry), DEFAULT_WIDTH); } if (closedir (dir) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } PUSH_REF (p, z); free (buffer); } } #endif /** @brief PROC [] INT utc time @param p Node in syntax tree. **/ void genie_utctime (NODE_T * p) { time_t dt; if (time (&dt) == (time_t) - 1) { (void) empty_row (p, MODE (ROW_INT)); } else { A68_REF row; ADDR_T sp = stack_pointer; struct tm *tod = gmtime (&dt); PUSH_PRIMITIVE (p, TM_YEAR (tod) + 1900, A68_INT); PUSH_PRIMITIVE (p, TM_MON (tod) + 1, A68_INT); PUSH_PRIMITIVE (p, TM_MDAY (tod), A68_INT); PUSH_PRIMITIVE (p, TM_HOUR (tod), A68_INT); PUSH_PRIMITIVE (p, TM_MIN (tod), A68_INT); PUSH_PRIMITIVE (p, TM_SEC (tod), A68_INT); PUSH_PRIMITIVE (p, TM_WDAY (tod) + 1, A68_INT); PUSH_PRIMITIVE (p, TM_ISDST (tod), A68_INT); row = genie_make_row (p, MODE (INT), 8, sp); stack_pointer = sp; PUSH_REF (p, row); } } /** @brief PROC [] INT local time @param p Node in syntax tree. **/ void genie_localtime (NODE_T * p) { time_t dt; if (time (&dt) == (time_t) - 1) { (void) empty_row (p, MODE (ROW_INT)); } else { A68_REF row; ADDR_T sp = stack_pointer; struct tm *tod = localtime (&dt); PUSH_PRIMITIVE (p, TM_YEAR (tod) + 1900, A68_INT); PUSH_PRIMITIVE (p, TM_MON (tod) + 1, A68_INT); PUSH_PRIMITIVE (p, TM_MDAY (tod), A68_INT); PUSH_PRIMITIVE (p, TM_HOUR (tod), A68_INT); PUSH_PRIMITIVE (p, TM_MIN (tod), A68_INT); PUSH_PRIMITIVE (p, TM_SEC (tod), A68_INT); PUSH_PRIMITIVE (p, TM_WDAY (tod) + 1, A68_INT); PUSH_PRIMITIVE (p, TM_ISDST (tod), A68_INT); row = genie_make_row (p, MODE (INT), 8, sp); stack_pointer = sp; PUSH_REF (p, row); } } /** @brief PROC INT rows @param p Node in syntax tree. **/ void genie_rows (NODE_T * p) { RESET_ERRNO; PUSH_PRIMITIVE (p, term_heigth, A68_INT); } /** @brief PROC INT columns @param p Node in syntax tree. **/ void genie_columns (NODE_T * p) { RESET_ERRNO; PUSH_PRIMITIVE (p, term_width, A68_INT); } /** @brief PROC INT argc @param p Node in syntax tree. **/ void genie_argc (NODE_T * p) { RESET_ERRNO; PUSH_PRIMITIVE (p, global_argc, A68_INT); } /** @brief PROC (INT) STRING argv @param p Node in syntax tree. **/ void genie_argv (NODE_T * p) { A68_INT a68g_index; RESET_ERRNO; POP_OBJECT (p, &a68g_index, A68_INT); if (VALUE (&a68g_index) >= 1 && VALUE (&a68g_index) <= global_argc) { char *q = global_argv[VALUE (&a68g_index) - 1]; int n = (int) strlen (q); /* Allow for spaces ending in # to have A68 comment syntax with '#!' */ while (n > 0 && (IS_SPACE(q[n - 1]) || q[n - 1] == '#')) { q[--n] = NULL_CHAR; } PUSH_REF (p, c_to_a_string (p, q, DEFAULT_WIDTH)); } else { PUSH_REF (p, empty_string (p)); } } /** @brief PROC STRING pwd @param p Node in syntax tree. **/ void genie_pwd (NODE_T * p) { size_t size = BUFFER_SIZE; char *buffer = NO_TEXT; BOOL_T cont = A68_TRUE; RESET_ERRNO; while (cont) { buffer = (char *) malloc (size); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } if (getcwd (buffer, size) == buffer) { cont = A68_FALSE; } else { free (buffer); cont = (BOOL_T) (errno == 0); size *= 2; } } if (buffer != NO_TEXT && errno == 0) { PUSH_REF (p, c_to_a_string (p, buffer, DEFAULT_WIDTH)); free (buffer); } else { PUSH_REF (p, empty_string (p)); } } /** @brief PROC (STRING) INT cd @param p Node in syntax tree. **/ void genie_cd (NODE_T * p) { A68_REF dir; char *buffer; RESET_ERRNO; POP_REF (p, &dir); CHECK_INIT (p, INITIALISED (&dir), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, dir))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { int rc = chdir (a_to_c_string (p, buffer, dir)); if (rc == 0) { PUSH_PRIMITIVE (p, chdir (a_to_c_string (p, buffer, dir)), A68_INT); } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FILE_ACCESS); exit_genie (p, A68_RUNTIME_ERROR); } free (buffer); } } /** @brief PROC (STRING) BITS @param p Node in syntax tree. **/ void genie_file_mode (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (unsigned) (ST_MODE (&status)), A68_BITS); } else { PUSH_PRIMITIVE (p, 0x0, A68_BITS); } free (buffer); } } /** @brief PROC (STRING) BOOL file is block device @param p Node in syntax tree. **/ void genie_file_is_block_device (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISBLK (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } /** @brief PROC (STRING) BOOL file is char device @param p Node in syntax tree. **/ void genie_file_is_char_device (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISCHR (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } /** @brief PROC (STRING) BOOL file is directory @param p Node in syntax tree. **/ void genie_file_is_directory (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISDIR (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } /** @brief PROC (STRING) BOOL file is regular @param p Node in syntax tree. **/ void genie_file_is_regular (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISREG (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } #if defined __S_IFIFO /** @brief PROC (STRING) BOOL file is fifo @param p Node in syntax tree. **/ void genie_file_is_fifo (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISFIFO (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } #endif #if defined S_ISLNK /** @brief PROC (STRING) BOOL file is link @param p Node in syntax tree. **/ void genie_file_is_link (NODE_T * p) { A68_REF name; char *buffer; RESET_ERRNO; POP_REF (p, &name); CHECK_INIT (p, INITIALISED (&name), MODE (STRING)); buffer = (char *) malloc ((size_t) (1 + a68_string_size (p, name))); if (buffer == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } else { struct stat status; if (stat (a_to_c_string (p, buffer, name), &status) == 0) { PUSH_PRIMITIVE (p, (BOOL_T) (S_ISLNK (ST_MODE (&status)) != 0 ? A68_TRUE : A68_FALSE), A68_BOOL); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } free (buffer); } } #endif /** @brief Convert [] STRING row to char *vec[]. @param p Node in syntax tree. @param vec String vector. @param row [] STRING **/ static void convert_string_vector (NODE_T * p, char *vec[], A68_REF row) { BYTE_T *z = ADDRESS (&row); A68_ARRAY *arr = (A68_ARRAY *) & z[0]; A68_TUPLE *tup = (A68_TUPLE *) & z[SIZE_AL (A68_ARRAY)]; int k = 0; if (get_row_size (tup, DIM (arr)) > 0) { BYTE_T *base_addr = DEREF (BYTE_T, &ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T a68g_index = calculate_internal_index (tup, DIM (arr)); ADDR_T elem_addr = (a68g_index + SLICE_OFFSET (arr)) * ELEM_SIZE (arr) + FIELD_OFFSET (arr); BYTE_T *elem = &base_addr[elem_addr]; int size = a68_string_size (p, *(A68_REF *) elem); CHECK_INIT (p, INITIALISED ((A68_REF *) elem), MODE (STRING)); vec[k] = (char *) get_heap_space ((size_t) (1 + size)); ASSERT (a_to_c_string (p, vec[k], *(A68_REF *) elem) != NO_TEXT); if (k == VECTOR_SIZE - 1) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_TOO_MANY_ARGUMENTS); exit_genie (p, A68_RUNTIME_ERROR); } if (strlen (vec[k]) > 0) { k++; } done = increment_internal_index (tup, DIM (arr)); } } vec[k] = NO_TEXT; } /** @brief Free char *vec[]. @param vec String vector. **/ static void free_vector (char *vec[]) { int k = 0; while (vec[k] != NO_TEXT) { free (vec[k]); k++; } } /** @brief Reset error number. @param p Node in syntax tree. **/ void genie_reset_errno (NODE_T * p) { (void) *p; RESET_ERRNO; } /** @brief Error number. @param p Node in syntax tree. **/ void genie_errno (NODE_T * p) { PUSH_PRIMITIVE (p, errno, A68_INT); } /** @brief PROC strerror = (INT) STRING @param p Node in syntax tree. **/ void genie_strerror (NODE_T * p) { A68_INT i; POP_OBJECT (p, &i, A68_INT); PUSH_REF (p, c_to_a_string (p, strerror (VALUE (&i)), DEFAULT_WIDTH)); } /** @brief Set up file for usage in pipe. @param p Node in syntax tree. @param z Pointer to file. @param fd File number. @param chan Channel. @param r_mood Read mood. @param w_mood Write mood. @param pid Pid. **/ static void set_up_file (NODE_T * p, A68_REF * z, int fd, A68_CHANNEL chan, BOOL_T r_mood, BOOL_T w_mood, int pid) { A68_FILE *f; *z = heap_generator (p, MODE (REF_FILE), SIZE (MODE (FILE))); f = FILE_DEREF (z); STATUS (f) = (STATUS_MASK) ((pid < 0) ? 0 : INIT_MASK); IDENTIFICATION (f) = nil_ref; TERMINATOR (f) = nil_ref; CHANNEL (f) = chan; FD (f) = fd; STREAM (&DEVICE (f)) = NO_STREAM; OPENED (f) = A68_TRUE; OPEN_EXCLUSIVE (f) = A68_FALSE; READ_MOOD (f) = r_mood; WRITE_MOOD (f) = w_mood; CHAR_MOOD (f) = A68_TRUE; DRAW_MOOD (f) = A68_FALSE; FORMAT (f) = nil_format; TRANSPUT_BUFFER (f) = get_unblocked_transput_buffer (p); STRING (f) = nil_ref; reset_transput_buffer (TRANSPUT_BUFFER (f)); set_default_event_procedures (f); } /** @brief Create and push a pipe. @param p Node in syntax tree. @param fd_r Read file number. @param fd_w Write file number. @param pid Pid. **/ static void genie_mkpipe (NODE_T * p, int fd_r, int fd_w, int pid) { A68_REF r, w; RESET_ERRNO; /* Set up pipe */ set_up_file (p, &r, fd_r, stand_in_channel, A68_TRUE, A68_FALSE, pid); set_up_file (p, &w, fd_w, stand_out_channel, A68_FALSE, A68_TRUE, pid); /* push pipe */ PUSH_REF (p, r); PUSH_REF (p, w); PUSH_PRIMITIVE (p, pid, A68_INT); } /** @brief Push an environment string. @param p Node in syntax tree. **/ void genie_getenv (NODE_T * p) { A68_REF a_env; char *val, *z, *z_env; RESET_ERRNO; POP_REF (p, &a_env); CHECK_INIT (p, INITIALISED (&a_env), MODE (STRING)); z_env = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_env))); z = a_to_c_string (p, z_env, a_env); val = getenv (z); if (val == NO_TEXT) { a_env = empty_string (p); } else { a_env = tmp_to_a68_string (p, val); } PUSH_REF (p, a_env); } /** @brief PROC fork = INT @param p Node in syntax tree. **/ void genie_fork (NODE_T * p) { #if defined HAVE_WIN32 PUSH_PRIMITIVE (p, -1, A68_INT); #else int pid; RESET_ERRNO; pid = (int) fork (); PUSH_PRIMITIVE (p, pid, A68_INT); #endif } /** @brief PROC execve = (STRING, [] STRING, [] STRING) INT @param p Node in syntax tree. **/ void genie_execve (NODE_T * p) { int ret; A68_REF a_prog, a_args, a_env; char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE]; RESET_ERRNO; /* Pop parameters */ POP_REF (p, &a_env); POP_REF (p, &a_args); POP_REF (p, &a_prog); /* Convert strings and hasta el infinito */ prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog))); ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT); convert_string_vector (p, argv, a_args); convert_string_vector (p, envp, a_env); if (argv[0] == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT); exit_genie (p, A68_RUNTIME_ERROR); } #if defined HAVE_WIN32 ret = execve (prog, (const char * const *) argv, (const char * const *) envp); #else ret = execve (prog, argv, envp); #endif /* execve only returns if it fails */ free_vector (argv); free_vector (envp); free (prog); PUSH_PRIMITIVE (p, ret, A68_INT); } /** @brief PROC execve child = (STRING, [] STRING, [] STRING) INT @param p Node in syntax tree. **/ void genie_execve_child (NODE_T * p) { int pid; A68_REF a_prog, a_args, a_env; RESET_ERRNO; /* Pop parameters */ POP_REF (p, &a_env); POP_REF (p, &a_args); POP_REF (p, &a_prog); /* Now create the pipes and fork */ #if defined HAVE_WIN32 pid = -1; PUSH_PRIMITIVE (p, -1, A68_INT); return; #else pid = (int) fork (); if (pid == -1) { PUSH_PRIMITIVE (p, -1, A68_INT); } else if (pid == 0) { /* Child process */ char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE]; /* Convert strings */ prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog))); ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT); convert_string_vector (p, argv, a_args); convert_string_vector (p, envp, a_env); if (argv[0] == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT); exit_genie (p, A68_RUNTIME_ERROR); } (void) execve (prog, argv, envp); /* execve only returns if it fails - end child process */ a68g_exit (EXIT_FAILURE); PUSH_PRIMITIVE (p, 0, A68_INT); } else { /* parent process */ PUSH_PRIMITIVE (p, pid, A68_INT); } #endif /* defined HAVE_WIN32 */ } /** @brief PROC execve child pipe = (STRING, [] STRING, [] STRING) PIPE @param p Node in syntax tree. **/ void genie_execve_child_pipe (NODE_T * p) { /* Child redirects STDIN and STDOUT. Return a PIPE that contains the descriptors for the parent. pipe ptoc ->W...R-> PARENT CHILD <-R...W<- pipe ctop */ int pid; #if ! defined HAVE_WIN32 int ptoc_fd[2], ctop_fd[2]; #endif /* ! defined HAVE_WIN32 */ A68_REF a_prog, a_args, a_env; RESET_ERRNO; /* Pop parameters */ POP_REF (p, &a_env); POP_REF (p, &a_args); POP_REF (p, &a_prog); #if defined HAVE_WIN32 pid = -1; genie_mkpipe (p, -1, -1, -1); return; #else /* Create the pipes and fork */ if ((pipe (ptoc_fd) == -1) || (pipe (ctop_fd) == -1)) { genie_mkpipe (p, -1, -1, -1); return; } pid = (int) fork (); if (pid == -1) { /* Fork failure */ genie_mkpipe (p, -1, -1, -1); return; } if (pid == 0) { /* Child process */ char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE]; /* Convert strings */ prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog))); ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT); convert_string_vector (p, argv, a_args); convert_string_vector (p, envp, a_env); /* Set up redirection */ ASSERT (close (ctop_fd[FD_READ]) == 0); ASSERT (close (ptoc_fd[FD_WRITE]) == 0); ASSERT (close (STDIN_FILENO) == 0); ASSERT (close (STDOUT_FILENO) == 0); ASSERT (dup2 (ptoc_fd[FD_READ], STDIN_FILENO) != -1); ASSERT (dup2 (ctop_fd[FD_WRITE], STDOUT_FILENO) != -1); if (argv[0] == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT); exit_genie (p, A68_RUNTIME_ERROR); } (void) execve (prog, argv, envp); /* execve only returns if it fails - end child process */ a68g_exit (EXIT_FAILURE); genie_mkpipe (p, -1, -1, -1); } else { /* Parent process */ ASSERT (close (ptoc_fd[FD_READ]) == 0); ASSERT (close (ctop_fd[FD_WRITE]) == 0); genie_mkpipe (p, ctop_fd[FD_READ], ptoc_fd[FD_WRITE], pid); } #endif /* defined HAVE_WIN32 */ } /** @brief PROC execve_output = (STRING, [] STRING, [] STRING, REF_STRING) INT @param p Node in syntax tree. **/ void genie_execve_output (NODE_T * p) { /* Child redirects STDIN and STDOUT. pipe ptoc ->W...R-> PARENT CHILD <-R...W<- pipe ctop */ int pid; #if ! defined HAVE_WIN32 int ptoc_fd[2], ctop_fd[2]; #endif /* ! defined HAVE_WIN32 */ A68_REF a_prog, a_args, a_env, dest; RESET_ERRNO; /* Pop parameters */ POP_REF (p, &dest); POP_REF (p, &a_env); POP_REF (p, &a_args); POP_REF (p, &a_prog); #if defined HAVE_WIN32 pid = -1; PUSH_PRIMITIVE (p, -1, A68_INT); return; #else /* Create the pipes and fork */ if ((pipe (ptoc_fd) == -1) || (pipe (ctop_fd) == -1)) { PUSH_PRIMITIVE (p, -1, A68_INT); return; } pid = (int) fork (); if (pid == -1) { /* Fork failure */ PUSH_PRIMITIVE (p, -1, A68_INT); return; } if (pid == 0) { /* Child process */ char *prog, *argv[VECTOR_SIZE], *envp[VECTOR_SIZE]; /* Convert strings */ prog = (char *) get_heap_space ((size_t) (1 + a68_string_size (p, a_prog))); ASSERT (a_to_c_string (p, prog, a_prog) != NO_TEXT); convert_string_vector (p, argv, a_args); convert_string_vector (p, envp, a_env); /* Set up redirection */ ASSERT (close (ctop_fd[FD_READ]) == 0); ASSERT (close (ptoc_fd[FD_WRITE]) == 0); ASSERT (close (STDIN_FILENO) == 0); ASSERT (close (STDOUT_FILENO) == 0); ASSERT (dup2 (ptoc_fd[FD_READ], STDIN_FILENO) != -1); ASSERT (dup2 (ctop_fd[FD_WRITE], STDOUT_FILENO) != -1); if (argv[0] == NO_TEXT) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_EMPTY_ARGUMENT); exit_genie (p, A68_RUNTIME_ERROR); } (void) execve (prog, argv, envp); /* execve only returns if it fails - end child process */ a68g_exit (EXIT_FAILURE); PUSH_PRIMITIVE (p, -1, A68_INT); } else { /* Parent process */ char ch; int pipe_read, ret, status; ASSERT (close (ptoc_fd[FD_READ]) == 0); ASSERT (close (ctop_fd[FD_WRITE]) == 0); reset_transput_buffer (INPUT_BUFFER); do { pipe_read = (int) io_read_conv (ctop_fd[FD_READ], &ch, 1); if (pipe_read > 0) { add_char_transput_buffer (p, INPUT_BUFFER, ch); } } while (pipe_read > 0); do { ret = (int) waitpid ((__pid_t) pid, &status, 0); } while (ret == -1 && errno == EINTR); if (ret != pid) { status = -1; } if (!IS_NIL (dest)) { * DEREF (A68_REF, &dest) = c_to_a_string (p, get_transput_buffer (INPUT_BUFFER), get_transput_buffer_index (INPUT_BUFFER)); } PUSH_PRIMITIVE (p, ret, A68_INT); } #endif /* defined HAVE_WIN32 */ } /** @brief PROC create pipe = PIPE @param p Node in syntax tree. **/ void genie_create_pipe (NODE_T * p) { RESET_ERRNO; genie_stand_in (p); genie_stand_out (p); PUSH_PRIMITIVE (p, -1, A68_INT); } /** @brief PROC wait pid = (INT) VOID @param p Node in syntax tree. **/ void genie_waitpid (NODE_T * p) { A68_INT k; RESET_ERRNO; POP_OBJECT (p, &k, A68_INT); #if ! defined HAVE_WIN32 ASSERT (waitpid ((__pid_t) VALUE (&k), NULL, 0) != -1); #endif } /* Next part contains some routines that interface Algol68G and the curses library. Be sure to know what you are doing when you use this, but on the other hand, "reset" will always restore your terminal. */ #if defined HAVE_CURSES #define CHECK_CURSES_RETVAL(f) {\ if (!(f)) {\ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES);\ exit_genie (p, A68_RUNTIME_ERROR);\ }} BOOL_T a68g_curses_mode = A68_FALSE; /** @brief Clean_curses. **/ void clean_curses (void) { if (a68g_curses_mode == A68_TRUE) { (void) wattrset (stdscr, A_NORMAL); (void) endwin (); a68g_curses_mode = A68_FALSE; } } /** @brief Init_curses. **/ void init_curses (void) { (void) initscr (); (void) cbreak (); /* raw () would cut off ctrl-c */ (void) noecho (); (void) nonl (); (void) curs_set (0); if (has_colors ()) { (void) start_color (); } } /** @brief Watch stdin for input, do not wait very long. @return Character read. **/ int rgetchar (void) { #if defined HAVE_WIN32 if (kbhit ()) { return (getch ()); } else { return (NULL_CHAR); } #else int retval; struct timeval tv; fd_set rfds; TV_SEC (&tv) = 0; TV_USEC (&tv) = 100; FD_ZERO (&rfds); FD_SET (0, &rfds); retval = select (1, &rfds, NULL, NULL, &tv); if (retval) { /* FD_ISSET(0, &rfds) will be true. */ return (getch ()); } else { return (NULL_CHAR); } #endif } /** @brief PROC curses start = VOID @param p Node in syntax tree. **/ void genie_curses_start (NODE_T * p) { errno = 0; init_curses (); if (errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES); exit_genie (p, A68_RUNTIME_ERROR); } a68g_curses_mode = A68_TRUE; } /** @brief PROC curses end = VOID @param p Node in syntax tree. **/ void genie_curses_end (NODE_T * p) { (void) p; clean_curses (); } /** @brief PROC curses clear = VOID @param p Node in syntax tree. **/ void genie_curses_clear (NODE_T * p) { if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } CHECK_CURSES_RETVAL (clear () != ERR); } /** @brief PROC curses refresh = VOID @param p Node in syntax tree. **/ void genie_curses_refresh (NODE_T * p) { if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } CHECK_CURSES_RETVAL (refresh () != ERR); } /** @brief PROC curses lines = INT @param p Node in syntax tree. **/ void genie_curses_lines (NODE_T * p) { if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } PUSH_PRIMITIVE (p, LINES, A68_INT); } /** @brief PROC curses columns = INT @param p Node in syntax tree. **/ void genie_curses_columns (NODE_T * p) { if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } PUSH_PRIMITIVE (p, COLS, A68_INT); } /** @brief PROC curses getchar = CHAR @param p Node in syntax tree. **/ void genie_curses_getchar (NODE_T * p) { if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } PUSH_PRIMITIVE (p, (char) rgetchar (), A68_CHAR); } /* @brief PROC curses colour = VOID @param p Node in syntax tree. */ #define GENIE_COLOUR(f, n, fg, bg)\ void f (NODE_T *p) {\ (void) p;\ if ((n) < COLOR_PAIRS) {\ (void) init_pair (n, (fg), (bg));\ wattrset (stdscr, COLOR_PAIR ((n)) | A_BOLD);\ }\ }\ void f##_inverse (NODE_T *p) {\ (void) p;\ if ((n + 8) < COLOR_PAIRS) {\ (void) init_pair ((n) + 8, (bg), (fg));\ wattrset (stdscr, COLOR_PAIR (((n) + 8)));\ }\ } GENIE_COLOUR (genie_curses_blue, 1, COLOR_BLUE, COLOR_BLACK) GENIE_COLOUR (genie_curses_cyan, 2, COLOR_CYAN, COLOR_BLACK) GENIE_COLOUR (genie_curses_green, 3, COLOR_GREEN, COLOR_BLACK) GENIE_COLOUR (genie_curses_magenta, 4, COLOR_MAGENTA, COLOR_BLACK) GENIE_COLOUR (genie_curses_red, 5, COLOR_RED, COLOR_BLACK) GENIE_COLOUR (genie_curses_white, 6, COLOR_WHITE, COLOR_BLACK) GENIE_COLOUR (genie_curses_yellow, 7, COLOR_YELLOW, COLOR_BLACK) /** @brief PROC curses delchar = (CHAR) BOOL @param p Node in syntax tree. **/ void genie_curses_del_char (NODE_T * p) { A68_CHAR ch; int v; POP_OBJECT (p, &ch, A68_CHAR); v = (int) VALUE (&ch); PUSH_PRIMITIVE (p, (BOOL_T) (v == 8 || v == 127 || v == KEY_BACKSPACE), A68_BOOL); } /** @brief PROC curses putchar = (CHAR) VOID @param p Node in syntax tree. **/ void genie_curses_putchar (NODE_T * p) { A68_CHAR ch; if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } POP_OBJECT (p, &ch, A68_CHAR); (void) (addch ((chtype) (VALUE (&ch)))); /* if (addch ((chtype) (VALUE (&ch))) == ERR) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN); exit_genie (p, A68_RUNTIME_ERROR); } */ } /** @brief PROC curses move = (INT, INT) VOID @param p Node in syntax tree. **/ void genie_curses_move (NODE_T * p) { A68_INT i, j; if (a68g_curses_mode == A68_FALSE) { genie_curses_start (p); } POP_OBJECT (p, &j, A68_INT); POP_OBJECT (p, &i, A68_INT); if (VALUE (&i) < 0 || VALUE (&i) >= LINES) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN); exit_genie (p, A68_RUNTIME_ERROR); } if (VALUE (&j) < 0 || VALUE (&j) >= COLS) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CURSES_OFF_SCREEN); exit_genie (p, A68_RUNTIME_ERROR); } CHECK_CURSES_RETVAL(move (VALUE (&i), VALUE (&j)) != ERR); } #endif /* HAVE_CURSES */ #if defined HAVE_REGEX_H /** @brief Return code for regex interface. @param p Position in syntax tree. @param rc Return code from regex routine. @return 0: match, 1: no match, 2: no core, 3: other error **/ void push_grep_rc (NODE_T * p, int rc) { switch (rc) { case 0: { PUSH_PRIMITIVE (p, 0, A68_INT); return; } case REG_NOMATCH: { PUSH_PRIMITIVE (p, 1, A68_INT); return; } case REG_ESPACE: { PUSH_PRIMITIVE (p, 3, A68_INT); return; } default: { PUSH_PRIMITIVE (p, 2, A68_INT); return; } } } /** @brief PROC grep in string = (STRING, STRING, REF INT, REF INT) INT @param p Node in syntax tree. @return 0: match, 1: no match, 2: no core, 3: other error **/ void genie_grep_in_string (NODE_T * p) { A68_REF ref_pat, ref_beg, ref_end, ref_str, row; A68_ARRAY *arr; A68_TUPLE *tup; int rc, nmatch, k, max_k, widest; regex_t compiled; regmatch_t *matches; POP_REF (p, &ref_end); POP_REF (p, &ref_beg); POP_REF (p, &ref_str); POP_REF (p, &ref_pat); row = *(A68_REF *) & ref_str; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); reset_transput_buffer (PATTERN_BUFFER); reset_transput_buffer (STRING_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat); add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) & ref_str); rc = regcomp (&compiled, get_transput_buffer (PATTERN_BUFFER), REG_NEWLINE | REG_EXTENDED); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } nmatch = (int) (RE_NSUB (&compiled)); if (nmatch == 0) { nmatch = 1; } matches = malloc ((size_t) (nmatch * SIZE_AL (regmatch_t))); if (nmatch > 0 && matches == NULL) { rc = 2; PUSH_PRIMITIVE (p, rc, A68_INT); regfree (&compiled); return; } rc = regexec (&compiled, get_transput_buffer (STRING_BUFFER), (size_t) nmatch, matches, 0); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } /* Find widest match. Do not assume it is the first one */ widest = 0; max_k = 0; for (k = 0; k < nmatch; k++) { int dif = (int) (RM_EO (&(matches[k]))) - (int) (RM_SO (&(matches[k]))); if (dif > widest) { widest = dif; max_k = k; } } if (!IS_NIL (ref_beg)) { A68_INT *i = DEREF (A68_INT, &ref_beg); STATUS (i) = INIT_MASK; VALUE (i) = (int) (RM_SO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup)); } if (!IS_NIL (ref_end)) { A68_INT *i = DEREF (A68_INT, &ref_end); STATUS (i) = INIT_MASK; VALUE (i) = (int) (RM_EO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup)) - 1; } free (matches); push_grep_rc (p, 0); } /** @brief PROC grep in substring = (STRING, STRING, REF INT, REF INT) INT @param p Node in syntax tree. @return 0: match, 1: no match, 2: no core, 3: other error **/ void genie_grep_in_substring (NODE_T * p) { A68_REF ref_pat, ref_beg, ref_end, ref_str, row; A68_ARRAY *arr; A68_TUPLE *tup; int rc, nmatch, k, max_k, widest; regex_t compiled; regmatch_t *matches; POP_REF (p, &ref_end); POP_REF (p, &ref_beg); POP_REF (p, &ref_str); POP_REF (p, &ref_pat); row = *(A68_REF *) & ref_str; CHECK_INIT (p, INITIALISED (&row), MODE (ROWS)); GET_DESCRIPTOR (arr, tup, &row); reset_transput_buffer (PATTERN_BUFFER); reset_transput_buffer (STRING_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat); add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) & ref_str); rc = regcomp (&compiled, get_transput_buffer (PATTERN_BUFFER), REG_NEWLINE | REG_EXTENDED); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } nmatch = (int) (RE_NSUB (&compiled)); if (nmatch == 0) { nmatch = 1; } matches = malloc ((size_t) (nmatch * SIZE_AL (regmatch_t))); if (nmatch > 0 && matches == NULL) { rc = 2; PUSH_PRIMITIVE (p, rc, A68_INT); regfree (&compiled); return; } rc = regexec (&compiled, get_transput_buffer (STRING_BUFFER), (size_t) nmatch, matches, REG_NOTBOL); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } /* Find widest match. Do not assume it is the first one */ widest = 0; max_k = 0; for (k = 0; k < nmatch; k++) { int dif = (int) (RM_EO (&(matches[k]))) - (int) (RM_SO (&(matches[k]))); if (dif > widest) { widest = dif; max_k = k; } } if (!IS_NIL (ref_beg)) { A68_INT *i = DEREF (A68_INT, &ref_beg); STATUS (i) = INIT_MASK; VALUE (i) = (int) (RM_SO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup)); } if (!IS_NIL (ref_end)) { A68_INT *i = DEREF (A68_INT, &ref_end); STATUS (i) = INIT_MASK; VALUE (i) = (int) (RM_EO (&(matches[max_k]))) + (int) (LOWER_BOUND (tup)) - 1; } free (matches); push_grep_rc (p, 0); } /** @brief PROC sub in string = (STRING, STRING, REF STRING) INT @param p Node in syntax tree. @return 0: match, 1: no match, 2: no core, 3: other error **/ void genie_sub_in_string (NODE_T * p) { A68_REF ref_pat, ref_rep, ref_str; int rc, nmatch, k, max_k, widest, begin, end; char *txt; regex_t compiled; regmatch_t *matches; POP_REF (p, &ref_str); POP_REF (p, &ref_rep); POP_REF (p, &ref_pat); if (IS_NIL (ref_str)) { PUSH_PRIMITIVE (p, 3, A68_INT); return; } reset_transput_buffer (STRING_BUFFER); reset_transput_buffer (REPLACE_BUFFER); reset_transput_buffer (PATTERN_BUFFER); add_a_string_transput_buffer (p, PATTERN_BUFFER, (BYTE_T *) & ref_pat); add_a_string_transput_buffer (p, STRING_BUFFER, (BYTE_T *) DEREF (A68_REF, &ref_str)); rc = regcomp (&compiled, get_transput_buffer (PATTERN_BUFFER), REG_NEWLINE | REG_EXTENDED); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } nmatch = (int) (RE_NSUB (&compiled)); if (nmatch == 0) { nmatch = 1; } matches = malloc ((size_t) (nmatch * SIZE_AL (regmatch_t))); if (nmatch > 0 && matches == NULL) { PUSH_PRIMITIVE (p, rc, A68_INT); regfree (&compiled); return; } rc = regexec (&compiled, get_transput_buffer (STRING_BUFFER), (size_t) nmatch, matches, 0); if (rc != 0) { push_grep_rc (p, rc); regfree (&compiled); return; } /* Find widest match. Do not assume it is the first one */ widest = 0; max_k = 0; for (k = 0; k < nmatch; k++) { int dif = (int) RM_EO (&(matches[k])) - (int) RM_SO (&(matches[k])); if (dif > widest) { widest = dif; max_k = k; } } begin = (int) RM_SO (&(matches[max_k])) + 1; end = (int) RM_EO (&(matches[max_k])); /* Substitute text */ txt = get_transput_buffer (STRING_BUFFER); for (k = 0; k < begin - 1; k++) { add_char_transput_buffer (p, REPLACE_BUFFER, txt[k]); } add_a_string_transput_buffer (p, REPLACE_BUFFER, (BYTE_T *) & ref_rep); for (k = end; k < get_transput_buffer_size (STRING_BUFFER); k++) { add_char_transput_buffer (p, REPLACE_BUFFER, txt[k]); } * DEREF (A68_REF, &ref_str) = c_to_a_string (p, get_transput_buffer (REPLACE_BUFFER), DEFAULT_WIDTH); free (matches); push_grep_rc (p, 0); } #endif /* HAVE_REGEX_H */ algol68g-2.8/source/code.c0000644000175000001440000055302312113475635012320 00000000000000/** @file code.c @author J. Marcel van der Veer @brief Emit C code for Algol 68 constructs. @section Copyright This file is part of Algol68G - an Algol 68 compiler-interpreter. Copyright (C) 2001-2013 J. Marcel van der Veer . @section License 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 . @section Description This file generates optimised C routines for many units in an Algol 68 source program. A68G 1.x contained some general optimised routines. These are decommissioned in A68G 2.x that dynamically generates routines depending on the source code. The generated routines are compiled on the fly into a dynamic library that is linked by the running interpreter. To invoke this code generator specify option --optimise. Currently the optimiser only considers units that operate on basic modes that are contained in a single C struct, for instance primitive modes INT, REAL, BOOL, CHAR and BITS and simple structures of these basic modes, such as COMPLEX and also (single) references, rows and procedures REF MODE, [] MODE, PROC PARAMSETY MODE The code generator employs a few simple optimisations like constant folding and common subexpression elimination when DEREFERENCING or SLICING is performed; for instance x[i + 1] := x[i + 1] + 1 translates into tmp = x[i + 1]; tmp := tmp + 1 There are no optimisations that are easily recognised by the back end compiler, for instance symbolic simplification. You will find here and there lines if (DEBUG_LEVEL >= ...) which I use to debug the compiler - MvdV. 1: denotations only 2: also basic unit compilation 3: also better fetching of data from the stack 4: also compile enclosed clauses Below definition switches everything on: #define DEBUG_LEVEL 9 **/ #define DEBUG_LEVEL 9 #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" #define BASIC(p, n) (basic_unit (locate ((p), (n)))) #define CON "_const" #define ELM "_elem" #define TMP "_tmp" #define ARG "_arg" #define ARR "_array" #define DEC "_declarer" #define DRF "_deref" #define DSP "_display" #define FUN "_function" #define PUP "_pop" #define REF "_ref" #define SEL "_field" #define TUP "_tuple" #define A68_MAKE_NOTHING 0 #define A68_MAKE_OTHERS 1 #define A68_MAKE_FUNCTION 2 #define OFFSET_OFF(s) (OFFSET (NODE_PACK (SUB (s)))) #define LONG_MODE(m) ((m) == MODE (LONG_INT) || (m) == MODE (LONG_REAL)) #define WIDEN_TO(p, a, b) (MOID (p) == MODE (b) && MOID (SUB (p)) == MODE (a)) #define GC_MODE(m) (m != NO_MOID && (IS (m, REF_SYMBOL) || IS (DEFLEX (m), ROW_SYMBOL))) #define NEEDS_DNS(m) (m != NO_MOID && (IS (m, REF_SYMBOL) || IS (m, PROC_SYMBOL) || IS (m, UNION_SYMBOL) || IS (m, FORMAT_SYMBOL))) #define CODE_EXECUTE(p) {\ indentf (out, snprintf (line, SNPRINTF_SIZE, "EXECUTE_UNIT_TRACE (_N_ (%d));", NUMBER (p)));\ } #define NAME_SIZE 128 static BOOL_T long_mode_allowed = A68_TRUE; static int indentation = 0; static char line[BUFFER_SIZE]; static BOOL_T basic_unit (NODE_T *); static char *compile_unit (NODE_T *, FILE_T, BOOL_T); static void inline_unit (NODE_T *, FILE_T, int); static void compile_units (NODE_T *, FILE_T); static void indent (FILE_T, char *); static void indentf (FILE_T, int); /* The phases we go through */ enum {L_NONE = 0, L_DECLARE = 1, L_INITIALISE, L_EXECUTE, L_EXECUTE_2, L_YIELD, L_PUSH}; /*********************************************************/ /* TRANSLATION tabulates translations for genie actions. */ /* This tells what to call for an A68 action. */ /*********************************************************/ typedef int LEVEL_T; typedef struct {GPROC * procedure; char * code;} TRANSLATION; static TRANSLATION monadics[] = { {genie_minus_int, "-"}, {genie_minus_real, "-"}, {genie_abs_int, "labs"}, {genie_abs_real, "fabs"}, {genie_sign_int, "SIGN"}, {genie_sign_real, "SIGN"}, {genie_entier_real, "a68g_entier"}, {genie_round_real, "a68g_round"}, {genie_not_bool, "!"}, {genie_abs_bool, "(int) "}, {genie_abs_bits, "(int) "}, {genie_bin_int, "(unsigned) "}, {genie_not_bits, "~"}, {genie_abs_char, "TO_UCHAR"}, {genie_repr_char, ""}, {genie_re_complex, "a68g_re_complex"}, {genie_im_complex, "a68g_im_complex"}, {genie_minus_complex, "a68g_minus_complex"}, {genie_abs_complex, "a68g_abs_complex"}, {genie_arg_complex, "a68g_arg_complex"}, {genie_conj_complex, "a68g_conj_complex"}, {genie_round_long_mp, "(void) round_mp"}, {genie_entier_long_mp, "(void) entier_mp"}, {genie_minus_long_mp, "(void) minus_mp"}, {genie_abs_long_mp, "(void) abs_mp"}, {genie_idle, ""}, {NO_GPROC, NO_TEXT} }; static TRANSLATION dyadics[] = { {genie_add_int, "+"}, {genie_sub_int, "-"}, {genie_mul_int, "*"}, {genie_over_int, "/"}, {genie_mod_int, "a68g_mod_int"}, {genie_div_int, "DIV_INT"}, {genie_eq_int, "=="}, {genie_ne_int, "!="}, {genie_lt_int, "<"}, {genie_gt_int, ">"}, {genie_le_int, "<="}, {genie_ge_int, ">="}, {genie_plusab_int, "a68g_plusab_int"}, {genie_minusab_int, "a68g_minusab_int"}, {genie_timesab_int, "a68g_timesab_int"}, {genie_overab_int, "a68g_overab_int"}, {genie_add_real, "+"}, {genie_sub_real, "-"}, {genie_mul_real, "*"}, {genie_div_real, "/"}, {genie_pow_real, "a68g_pow_real"}, {genie_pow_real_int, "a68g_pow_real_int"}, {genie_eq_real, "=="}, {genie_ne_real, "!="}, {genie_lt_real, "<"}, {genie_gt_real, ">"}, {genie_le_real, "<="}, {genie_ge_real, ">="}, {genie_plusab_real, "a68g_plusab_real"}, {genie_minusab_real, "a68g_minusab_real"}, {genie_timesab_real, "a68g_timesab_real"}, {genie_divab_real, "a68g_divab_real"}, {genie_eq_char, "=="}, {genie_ne_char, "!="}, {genie_lt_char, "<"}, {genie_gt_char, ">"}, {genie_le_char, "<="}, {genie_ge_char, ">="}, {genie_eq_bool, "=="}, {genie_ne_bool, "!="}, {genie_and_bool, "&&"}, {genie_or_bool, "||"}, {genie_and_bits, "&"}, {genie_or_bits, "|"}, {genie_eq_bits, "=="}, {genie_ne_bits, "!="}, {genie_shl_bits, "<<"}, {genie_shr_bits, ">>"}, {genie_icomplex, "a68g_i_complex"}, {genie_iint_complex, "a68g_i_complex"}, {genie_abs_complex, "a68g_abs_complex"}, {genie_arg_complex, "a68g_arg_complex"}, {genie_add_complex, "a68g_add_complex"}, {genie_sub_complex, "a68g_sub_complex"}, {genie_mul_complex, "a68g_mul_complex"}, {genie_div_complex, "a68g_div_complex"}, {genie_eq_complex, "a68g_eq_complex"}, {genie_ne_complex, "a68g_ne_complex"}, {genie_add_long_int, "(void) add_mp"}, {genie_add_long_mp, "(void) add_mp"}, {genie_sub_long_int, "(void) sub_mp"}, {genie_sub_long_mp, "(void) sub_mp"}, {genie_mul_long_int, "(void) mul_mp"}, {genie_mul_long_mp, "(void) mul_mp"}, {genie_over_long_mp, "(void) over_mp"}, {genie_div_long_mp, "(void) div_mp"}, {genie_eq_long_mp, "eq_mp"}, {genie_ne_long_mp, "ne_mp"}, {genie_lt_long_mp, "lt_mp"}, {genie_le_long_mp, "le_mp"}, {genie_gt_long_mp, "gt_mp"}, {genie_ge_long_mp, "ge_mp"}, {NO_GPROC, NO_TEXT} }; static TRANSLATION functions[] = { {genie_sqrt_real, "sqrt"}, {genie_curt_real, "curt"}, {genie_exp_real, "a68g_exp"}, {genie_ln_real, "log"}, {genie_log_real, "log10"}, {genie_sin_real, "sin"}, {genie_cos_real, "cos"}, {genie_tan_real, "tan"}, {genie_arcsin_real, "asin"}, {genie_arccos_real, "acos"}, {genie_arctan_real, "atan"}, {genie_sinh_real, "sinh"}, {genie_cosh_real, "cosh"}, {genie_tanh_real, "tanh"}, {genie_arcsinh_real, "a68g_asinh"}, {genie_arccosh_real, "a68g_acosh"}, {genie_arctanh_real, "a68g_atanh"}, {genie_inverf_real, "inverf"}, {genie_inverfc_real, "inverfc"}, {genie_sqrt_complex, "a68g_sqrt_complex"}, {genie_exp_complex, "a68g_exp_complex"}, {genie_ln_complex, "a68g_ln_complex"}, {genie_sin_complex, "a68g_sin_complex"}, {genie_cos_complex, "a68g_cos_complex"}, {genie_tan_complex, "a68g_tan_complex"}, {genie_arcsin_complex, "a68g_arcsin_complex"}, {genie_arccos_complex, "a68g_arccos_complex"}, {genie_arctan_complex, "a68g_arctan_complex"}, {genie_sqrt_long_mp, "(void) sqrt_mp"}, {genie_exp_long_mp, "(void) exp_mp"}, {genie_ln_long_mp, "(void) ln_mp"}, {genie_log_long_mp, "(void) log_mp"}, {genie_sin_long_mp, "(void) sin_mp"}, {genie_cos_long_mp, "(void) cos_mp"}, {genie_tan_long_mp, "(void) tan_mp"}, {genie_asin_long_mp, "(void) asin_mp"}, {genie_acos_long_mp, "(void) acos_mp"}, {genie_atan_long_mp, "(void) atan_mp"}, {genie_sinh_long_mp, "(void) sinh_mp"}, {genie_cosh_long_mp, "(void) cosh_mp"}, {genie_tanh_long_mp, "(void) tanh_mp"}, {genie_arcsinh_long_mp, "(void) asinh_mp"}, {genie_arccosh_long_mp, "(void) acosh_mp"}, {genie_arctanh_long_mp, "(void) atanh_mp"}, {NO_GPROC, NO_TEXT} }; static TRANSLATION constants[] = { {genie_int_lengths, "3"}, {genie_int_shorths, "1"}, {genie_real_lengths, "3"}, {genie_real_shorths, "1"}, {genie_complex_lengths, "3"}, {genie_complex_shorths, "1"}, {genie_bits_lengths, "3"}, {genie_bits_shorths, "1"}, {genie_bytes_lengths, "2"}, {genie_bytes_shorths, "1"}, {genie_int_width, "INT_WIDTH"}, {genie_long_int_width, "LONG_INT_WIDTH"}, {genie_longlong_int_width, "LONGLONG_INT_WIDTH"}, {genie_real_width, "REAL_WIDTH"}, {genie_long_real_width, "LONG_REAL_WIDTH"}, {genie_longlong_real_width, "LONGLONG_REAL_WIDTH"}, {genie_exp_width, "EXP_WIDTH"}, {genie_long_exp_width, "LONG_EXP_WIDTH"}, {genie_longlong_exp_width, "LONGLONG_EXP_WIDTH"}, {genie_bits_width, "BITS_WIDTH"}, {genie_bytes_width, "BYTES_WIDTH"}, {genie_long_bytes_width, "LONG_BYTES_WIDTH"}, {genie_max_abs_char, "UCHAR_MAX"}, {genie_max_int, "A68_MAX_INT"}, {genie_max_real, "DBL_MAX"}, {genie_min_real, "DBL_MIN"}, {genie_null_char, "NULL_CHAR"}, {genie_small_real, "DBL_EPSILON"}, {genie_pi, "A68_PI"}, {genie_pi_long_mp, NO_TEXT}, {genie_long_max_int, NO_TEXT}, {genie_long_min_real, NO_TEXT}, {genie_long_small_real, NO_TEXT}, {genie_long_max_real, NO_TEXT}, {genie_cgs_acre, "GSL_CONST_CGSM_ACRE"}, {genie_cgs_angstrom, "GSL_CONST_CGSM_ANGSTROM"}, {genie_cgs_astronomical_unit, "GSL_CONST_CGSM_ASTRONOMICAL_UNIT"}, {genie_cgs_bar, "GSL_CONST_CGSM_BAR"}, {genie_cgs_barn, "GSL_CONST_CGSM_BARN"}, {genie_cgs_bohr_magneton, "GSL_CONST_CGSM_BOHR_MAGNETON"}, {genie_cgs_bohr_radius, "GSL_CONST_CGSM_BOHR_RADIUS"}, {genie_cgs_boltzmann, "GSL_CONST_CGSM_BOLTZMANN"}, {genie_cgs_btu, "GSL_CONST_CGSM_BTU"}, {genie_cgs_calorie, "GSL_CONST_CGSM_CALORIE"}, {genie_cgs_canadian_gallon, "GSL_CONST_CGSM_CANADIAN_GALLON"}, {genie_cgs_carat, "GSL_CONST_CGSM_CARAT"}, {genie_cgs_cup, "GSL_CONST_CGSM_CUP"}, {genie_cgs_curie, "GSL_CONST_CGSM_CURIE"}, {genie_cgs_day, "GSL_CONST_CGSM_DAY"}, {genie_cgs_dyne, "GSL_CONST_CGSM_DYNE"}, {genie_cgs_electron_charge, "GSL_CONST_CGSM_ELECTRON_CHARGE"}, {genie_cgs_electron_magnetic_moment, "GSL_CONST_CGSM_ELECTRON_MAGNETIC_MOMENT"}, {genie_cgs_electron_volt, "GSL_CONST_CGSM_ELECTRON_VOLT"}, {genie_cgs_erg, "GSL_CONST_CGSM_ERG"}, {genie_cgs_faraday, "GSL_CONST_CGSM_FARADAY"}, {genie_cgs_fathom, "GSL_CONST_CGSM_FATHOM"}, {genie_cgs_fluid_ounce, "GSL_CONST_CGSM_FLUID_OUNCE"}, {genie_cgs_foot, "GSL_CONST_CGSM_FOOT"}, {genie_cgs_footcandle, "GSL_CONST_CGSM_FOOTCANDLE"}, {genie_cgs_footlambert, "GSL_CONST_CGSM_FOOTLAMBERT"}, {genie_cgs_gauss, "GSL_CONST_CGSM_GAUSS"}, {genie_cgs_gram_force, "GSL_CONST_CGSM_GRAM_FORCE"}, {genie_cgs_grav_accel, "GSL_CONST_CGSM_GRAV_ACCEL"}, {genie_cgs_gravitational_constant, "GSL_CONST_CGSM_GRAVITATIONAL_CONSTANT"}, {genie_cgs_hectare, "GSL_CONST_CGSM_HECTARE"}, {genie_cgs_horsepower, "GSL_CONST_CGSM_HORSEPOWER"}, {genie_cgs_hour, "GSL_CONST_CGSM_HOUR"}, {genie_cgs_inch, "GSL_CONST_CGSM_INCH"}, {genie_cgs_inch_of_mercury, "GSL_CONST_CGSM_INCH_OF_MERCURY"}, {genie_cgs_inch_of_water, "GSL_CONST_CGSM_INCH_OF_WATER"}, {genie_cgs_joule, "GSL_CONST_CGSM_JOULE"}, {genie_cgs_kilometers_per_hour, "GSL_CONST_CGSM_KILOMETERS_PER_HOUR"}, {genie_cgs_kilopound_force, "GSL_CONST_CGSM_KILOPOUND_FORCE"}, {genie_cgs_knot, "GSL_CONST_CGSM_KNOT"}, {genie_cgs_lambert, "GSL_CONST_CGSM_LAMBERT"}, {genie_cgs_light_year, "GSL_CONST_CGSM_LIGHT_YEAR"}, {genie_cgs_liter, "GSL_CONST_CGSM_LITER"}, {genie_cgs_lumen, "GSL_CONST_CGSM_LUMEN"}, {genie_cgs_lux, "GSL_CONST_CGSM_LUX"}, {genie_cgs_mass_electron, "GSL_CONST_CGSM_MASS_ELECTRON"}, {genie_cgs_mass_muon, "GSL_CONST_CGSM_MASS_MUON"}, {genie_cgs_mass_neutron, "GSL_CONST_CGSM_MASS_NEUTRON"}, {genie_cgs_mass_proton, "GSL_CONST_CGSM_MASS_PROTON"}, {genie_cgs_meter_of_mercury, "GSL_CONST_CGSM_METER_OF_MERCURY"}, {genie_cgs_metric_ton, "GSL_CONST_CGSM_METRIC_TON"}, {genie_cgs_micron, "GSL_CONST_CGSM_MICRON"}, {genie_cgs_mil, "GSL_CONST_CGSM_MIL"}, {genie_cgs_mile, "GSL_CONST_CGSM_MILE"}, {genie_cgs_miles_per_hour, "GSL_CONST_CGSM_MILES_PER_HOUR"}, {genie_cgs_minute, "GSL_CONST_CGSM_MINUTE"}, {genie_cgs_molar_gas, "GSL_CONST_CGSM_MOLAR_GAS"}, {genie_cgs_nautical_mile, "GSL_CONST_CGSM_NAUTICAL_MILE"}, {genie_cgs_newton, "GSL_CONST_CGSM_NEWTON"}, {genie_cgs_nuclear_magneton, "GSL_CONST_CGSM_NUCLEAR_MAGNETON"}, {genie_cgs_ounce_mass, "GSL_CONST_CGSM_OUNCE_MASS"}, {genie_cgs_parsec, "GSL_CONST_CGSM_PARSEC"}, {genie_cgs_phot, "GSL_CONST_CGSM_PHOT"}, {genie_cgs_pint, "GSL_CONST_CGSM_PINT"}, {genie_cgs_planck_constant_h, "6.6260693e-27"}, {genie_cgs_planck_constant_hbar, "1.0545717e-27"}, {genie_cgs_point, "GSL_CONST_CGSM_POINT"}, {genie_cgs_poise, "GSL_CONST_CGSM_POISE"}, {genie_cgs_pound_force, "GSL_CONST_CGSM_POUND_FORCE"}, {genie_cgs_pound_mass, "GSL_CONST_CGSM_POUND_MASS"}, {genie_cgs_poundal, "GSL_CONST_CGSM_POUNDAL"}, {genie_cgs_proton_magnetic_moment, "GSL_CONST_CGSM_PROTON_MAGNETIC_MOMENT"}, {genie_cgs_psi, "GSL_CONST_CGSM_PSI"}, {genie_cgs_quart, "GSL_CONST_CGSM_QUART"}, {genie_cgs_rad, "GSL_CONST_CGSM_RAD"}, {genie_cgs_roentgen, "GSL_CONST_CGSM_ROENTGEN"}, {genie_cgs_rydberg, "GSL_CONST_CGSM_RYDBERG"}, {genie_cgs_solar_mass, "GSL_CONST_CGSM_SOLAR_MASS"}, {genie_cgs_speed_of_light, "GSL_CONST_CGSM_SPEED_OF_LIGHT"}, {genie_cgs_standard_gas_volume, "GSL_CONST_CGSM_STANDARD_GAS_VOLUME"}, {genie_cgs_std_atmosphere, "GSL_CONST_CGSM_STD_ATMOSPHERE"}, {genie_cgs_stilb, "GSL_CONST_CGSM_STILB"}, {genie_cgs_stokes, "GSL_CONST_CGSM_STOKES"}, {genie_cgs_tablespoon, "GSL_CONST_CGSM_TABLESPOON"}, {genie_cgs_teaspoon, "GSL_CONST_CGSM_TEASPOON"}, {genie_cgs_texpoint, "GSL_CONST_CGSM_TEXPOINT"}, {genie_cgs_therm, "GSL_CONST_CGSM_THERM"}, {genie_cgs_ton, "GSL_CONST_CGSM_TON"}, {genie_cgs_torr, "GSL_CONST_CGSM_TORR"}, {genie_cgs_troy_ounce, "GSL_CONST_CGSM_TROY_OUNCE"}, {genie_cgs_uk_gallon, "GSL_CONST_CGSM_UK_GALLON"}, {genie_cgs_uk_ton, "GSL_CONST_CGSM_UK_TON"}, {genie_cgs_unified_atomic_mass, "GSL_CONST_CGSM_UNIFIED_ATOMIC_MASS"}, {genie_cgs_us_gallon, "GSL_CONST_CGSM_US_GALLON"}, {genie_cgs_week, "GSL_CONST_CGSM_WEEK"}, {genie_cgs_yard, "GSL_CONST_CGSM_YARD"}, {genie_mks_acre, "GSL_CONST_MKS_ACRE"}, {genie_mks_angstrom, "GSL_CONST_MKS_ANGSTROM"}, {genie_mks_astronomical_unit, "GSL_CONST_MKS_ASTRONOMICAL_UNIT"}, {genie_mks_bar, "GSL_CONST_MKS_BAR"}, {genie_mks_barn, "GSL_CONST_MKS_BARN"}, {genie_mks_bohr_magneton, "GSL_CONST_MKS_BOHR_MAGNETON"}, {genie_mks_bohr_radius, "GSL_CONST_MKS_BOHR_RADIUS"}, {genie_mks_boltzmann, "GSL_CONST_MKS_BOLTZMANN"}, {genie_mks_btu, "GSL_CONST_MKS_BTU"}, {genie_mks_calorie, "GSL_CONST_MKS_CALORIE"}, {genie_mks_canadian_gallon, "GSL_CONST_MKS_CANADIAN_GALLON"}, {genie_mks_carat, "GSL_CONST_MKS_CARAT"}, {genie_mks_cup, "GSL_CONST_MKS_CUP"}, {genie_mks_curie, "GSL_CONST_MKS_CURIE"}, {genie_mks_day, "GSL_CONST_MKS_DAY"}, {genie_mks_dyne, "GSL_CONST_MKS_DYNE"}, {genie_mks_electron_charge, "GSL_CONST_MKS_ELECTRON_CHARGE"}, {genie_mks_electron_magnetic_moment, "GSL_CONST_MKS_ELECTRON_MAGNETIC_MOMENT"}, {genie_mks_electron_volt, "GSL_CONST_MKS_ELECTRON_VOLT"}, {genie_mks_erg, "GSL_CONST_MKS_ERG"}, {genie_mks_faraday, "GSL_CONST_MKS_FARADAY"}, {genie_mks_fathom, "GSL_CONST_MKS_FATHOM"}, {genie_mks_fluid_ounce, "GSL_CONST_MKS_FLUID_OUNCE"}, {genie_mks_foot, "GSL_CONST_MKS_FOOT"}, {genie_mks_footcandle, "GSL_CONST_MKS_FOOTCANDLE"}, {genie_mks_footlambert, "GSL_CONST_MKS_FOOTLAMBERT"}, {genie_mks_gauss, "GSL_CONST_MKS_GAUSS"}, {genie_mks_gram_force, "GSL_CONST_MKS_GRAM_FORCE"}, {genie_mks_grav_accel, "GSL_CONST_MKS_GRAV_ACCEL"}, {genie_mks_gravitational_constant, "GSL_CONST_MKS_GRAVITATIONAL_CONSTANT"}, {genie_mks_hectare, "GSL_CONST_MKS_HECTARE"}, {genie_mks_horsepower, "GSL_CONST_MKS_HORSEPOWER"}, {genie_mks_hour, "GSL_CONST_MKS_HOUR"}, {genie_mks_inch, "GSL_CONST_MKS_INCH"}, {genie_mks_inch_of_mercury, "GSL_CONST_MKS_INCH_OF_MERCURY"}, {genie_mks_inch_of_water, "GSL_CONST_MKS_INCH_OF_WATER"}, {genie_mks_joule, "GSL_CONST_MKS_JOULE"}, {genie_mks_kilometers_per_hour, "GSL_CONST_MKS_KILOMETERS_PER_HOUR"}, {genie_mks_kilopound_force, "GSL_CONST_MKS_KILOPOUND_FORCE"}, {genie_mks_knot, "GSL_CONST_MKS_KNOT"}, {genie_mks_lambert, "GSL_CONST_MKS_LAMBERT"}, {genie_mks_light_year, "GSL_CONST_MKS_LIGHT_YEAR"}, {genie_mks_liter, "GSL_CONST_MKS_LITER"}, {genie_mks_lumen, "GSL_CONST_MKS_LUMEN"}, {genie_mks_lux, "GSL_CONST_MKS_LUX"}, {genie_mks_mass_electron, "GSL_CONST_MKS_MASS_ELECTRON"}, {genie_mks_mass_muon, "GSL_CONST_MKS_MASS_MUON"}, {genie_mks_mass_neutron, "GSL_CONST_MKS_MASS_NEUTRON"}, {genie_mks_mass_proton, "GSL_CONST_MKS_MASS_PROTON"}, {genie_mks_meter_of_mercury, "GSL_CONST_MKS_METER_OF_MERCURY"}, {genie_mks_metric_ton, "GSL_CONST_MKS_METRIC_TON"}, {genie_mks_micron, "GSL_CONST_MKS_MICRON"}, {genie_mks_mil, "GSL_CONST_MKS_MIL"}, {genie_mks_mile, "GSL_CONST_MKS_MILE"}, {genie_mks_miles_per_hour, "GSL_CONST_MKS_MILES_PER_HOUR"}, {genie_mks_minute, "GSL_CONST_MKS_MINUTE"}, {genie_mks_molar_gas, "GSL_CONST_MKS_MOLAR_GAS"}, {genie_mks_nautical_mile, "GSL_CONST_MKS_NAUTICAL_MILE"}, {genie_mks_newton, "GSL_CONST_MKS_NEWTON"}, {genie_mks_nuclear_magneton, "GSL_CONST_MKS_NUCLEAR_MAGNETON"}, {genie_mks_ounce_mass, "GSL_CONST_MKS_OUNCE_MASS"}, {genie_mks_parsec, "GSL_CONST_MKS_PARSEC"}, {genie_mks_phot, "GSL_CONST_MKS_PHOT"}, {genie_mks_pint, "GSL_CONST_MKS_PINT"}, {genie_mks_planck_constant_h, "6.6260693e-34"}, {genie_mks_planck_constant_hbar, "1.0545717e-34"}, {genie_mks_point, "GSL_CONST_MKS_POINT"}, {genie_mks_poise, "GSL_CONST_MKS_POISE"}, {genie_mks_pound_force, "GSL_CONST_MKS_POUND_FORCE"}, {genie_mks_pound_mass, "GSL_CONST_MKS_POUND_MASS"}, {genie_mks_poundal, "GSL_CONST_MKS_POUNDAL"}, {genie_mks_proton_magnetic_moment, "GSL_CONST_MKS_PROTON_MAGNETIC_MOMENT"}, {genie_mks_psi, "GSL_CONST_MKS_PSI"}, {genie_mks_quart, "GSL_CONST_MKS_QUART"}, {genie_mks_rad, "GSL_CONST_MKS_RAD"}, {genie_mks_roentgen, "GSL_CONST_MKS_ROENTGEN"}, {genie_mks_rydberg, "GSL_CONST_MKS_RYDBERG"}, {genie_mks_solar_mass, "GSL_CONST_MKS_SOLAR_MASS"}, {genie_mks_speed_of_light, "GSL_CONST_MKS_SPEED_OF_LIGHT"}, {genie_mks_standard_gas_volume, "GSL_CONST_MKS_STANDARD_GAS_VOLUME"}, {genie_mks_std_atmosphere, "GSL_CONST_MKS_STD_ATMOSPHERE"}, {genie_mks_stilb, "GSL_CONST_MKS_STILB"}, {genie_mks_stokes, "GSL_CONST_MKS_STOKES"}, {genie_mks_tablespoon, "GSL_CONST_MKS_TABLESPOON"}, {genie_mks_teaspoon, "GSL_CONST_MKS_TEASPOON"}, {genie_mks_texpoint, "GSL_CONST_MKS_TEXPOINT"}, {genie_mks_therm, "GSL_CONST_MKS_THERM"}, {genie_mks_ton, "GSL_CONST_MKS_TON"}, {genie_mks_torr, "GSL_CONST_MKS_TORR"}, {genie_mks_troy_ounce, "GSL_CONST_MKS_TROY_OUNCE"}, {genie_mks_uk_gallon, "GSL_CONST_MKS_UK_GALLON"}, {genie_mks_uk_ton, "GSL_CONST_MKS_UK_TON"}, {genie_mks_unified_atomic_mass, "GSL_CONST_MKS_UNIFIED_ATOMIC_MASS"}, {genie_mks_us_gallon, "GSL_CONST_MKS_US_GALLON"}, {genie_mks_vacuum_permeability, "GSL_CONST_MKS_VACUUM_PERMEABILITY"}, {genie_mks_vacuum_permittivity, "GSL_CONST_MKS_VACUUM_PERMITTIVITY"}, {genie_mks_week, "GSL_CONST_MKS_WEEK"}, {genie_mks_yard, "GSL_CONST_MKS_YARD"}, {genie_num_atto, "GSL_CONST_NUM_ATTO"}, {genie_num_avogadro, "GSL_CONST_NUM_AVOGADRO"}, {genie_num_exa, "GSL_CONST_NUM_EXA"}, {genie_num_femto, "GSL_CONST_NUM_FEMTO"}, {genie_num_fine_structure, "GSL_CONST_NUM_FINE_STRUCTURE"}, {genie_num_giga, "GSL_CONST_NUM_GIGA"}, {genie_num_kilo, "GSL_CONST_NUM_KILO"}, {genie_num_mega, "GSL_CONST_NUM_MEGA"}, {genie_num_micro, "GSL_CONST_NUM_MICRO"}, {genie_num_milli, "GSL_CONST_NUM_MILLI"}, {genie_num_nano, "GSL_CONST_NUM_NANO"}, {genie_num_peta, "GSL_CONST_NUM_PETA"}, {genie_num_pico, "GSL_CONST_NUM_PICO"}, {genie_num_tera, "GSL_CONST_NUM_TERA"}, {genie_num_yocto, "GSL_CONST_NUM_YOCTO"}, {genie_num_yotta, "GSL_CONST_NUM_YOTTA"}, {genie_num_zepto, "GSL_CONST_NUM_ZEPTO"}, {genie_num_zetta, "GSL_CONST_NUM_ZETTA"}, {NO_GPROC, NO_TEXT} }; /**************************/ /* Pretty printing stuff. */ /**************************/ /** @brief Write indented text. @param out Output file descriptor. @param str Text. **/ static void indent (FILE_T out, char *str) { int j = indentation; if (out == 0) { return; } while (j -- > 0) { WRITE (out, " "); } WRITE (out, str); } /** @brief Write unindented text. @param out Output file descriptor. @param str Text. **/ static void undent (FILE_T out, char *str) { if (out == 0) { return; } WRITE (out, str); } /** @brief Write indent text. @param out Output file descriptor. @param ret Bytes written by snprintf. **/ static void indentf (FILE_T out, int ret) { if (out == 0) { return; } if (ret >= 0) { indent (out, line); } else { ABEND(A68_TRUE, "Return value failure", error_specification ()); } } /** @brief Write unindent text. @param out Output file descriptor. @param ret Bytes written by snprintf. **/ static void undentf (FILE_T out, int ret) { if (out == 0) { return; } if (ret >= 0) { WRITE (out, line); } else { ABEND(A68_TRUE, "Return value failure", error_specification ()); } } /*************************************/ /* Administration of C declarations */ /* Pretty printing of C declarations */ /*************************************/ /** @brief Add declaration to a tree. @param p Top token. @param t Token text. @return New entry. **/ typedef struct DEC_T DEC_T; struct DEC_T { char *text; int level; DEC_T *sub, *less, *more; }; static DEC_T *root_idf = NO_DEC; /** @brief Add declaration to a tree. @param p Top declaration. @param level Pointer level (0, 1 = *, 2 = **, etcetera) @param idf Identifier name. @return New entry. **/ DEC_T *add_identifier (DEC_T ** p, int level, char *idf) { char *z = new_temp_string (idf); while (*p != NO_DEC) { int k = strcmp (z, TEXT (*p)); if (k < 0) { p = &LESS (*p); } else if (k > 0) { p = &MORE (*p); } else { ABEND(A68_TRUE, "duplicate declaration", z); return (*p); } } *p = (DEC_T *) get_temp_heap_space ((size_t) SIZE_AL (DEC_T)); TEXT (*p) = z; LEVEL (*p) = level; SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC; return (*p); } /** @brief Add declaration to a tree. @param p Top declaration. @param mode Mode for identifier. @param level Pointer level (0, 1 = *, 2 = **, etcetera) @param idf Identifier name. @return New entry. **/ DEC_T *add_declaration (DEC_T ** p, char *mode, int level, char *idf) { char *z = new_temp_string (mode); while (*p != NO_DEC) { int k = strcmp (z, TEXT (*p)); if (k < 0) { p = &LESS (*p); } else if (k > 0) { p = &MORE (*p); } else { (void) add_identifier (&SUB(*p), level, idf); return (*p); } } *p = (DEC_T *) get_temp_heap_space ((size_t) SIZE_AL (DEC_T)); TEXT (*p) = z; LEVEL (*p) = -1; SUB (*p) = LESS (*p) = MORE (*p) = NO_DEC; (void) add_identifier(&SUB(*p), level, idf); return (*p); } static BOOL_T put_idf_comma = A68_TRUE; /** @brief Print identifiers (following mode). @param out File to print to. @param p Top token. **/ void print_identifiers (FILE_T out, DEC_T *p) { if (p != NO_DEC) { print_identifiers (out, LESS (p)); if (put_idf_comma) { WRITE (out, ", "); } else { put_idf_comma = A68_TRUE; } if (LEVEL (p) > 0) { int k = LEVEL (p); while (k--) { WRITE (out, "*"); } WRITE (out, " "); } WRITE (out, TEXT (p)); print_identifiers (out, MORE (p)); } } /** @brief Print declarations. @param out File to print to. @param p Top token. **/ void print_declarations (FILE_T out, DEC_T *p) { if (p != NO_DEC) { print_declarations (out, LESS (p)); indent (out, TEXT (p)); WRITE (out, " "); put_idf_comma = A68_FALSE; print_identifiers (out, SUB (p)); WRITELN (out, ";\n") print_declarations (out, MORE (p)); } } /***************************************************************************/ /* Administration for common (sub) expression elimination. */ /* BOOK keeps track of already seen (temporary) variables and denotations. */ /***************************************************************************/ typedef struct { int action, phase; char * idf; void * info; int number; } BOOK_T; enum {BOOK_NONE = 0, BOOK_DECL, BOOK_INIT, BOOK_DEREF, BOOK_ARRAY, BOOK_COMPILE}; #define MAX_BOOK 1024 BOOK_T temp_book[MAX_BOOK]; int temp_book_pointer; /** @brief Book identifier to keep track of it for CSE. @param action Some identification as L_DECLARE or DEREFERENCING. @param phase Phase in which booking is made. @param idf Identifier name. @param info Identifier information. @param number Unique identifying number. **/ static void sign_in (int action, int phase, char * idf, void * info, int number) { if (temp_book_pointer < MAX_BOOK) { ACTION (&temp_book[temp_book_pointer]) = action; PHASE (&temp_book[temp_book_pointer]) = phase; IDF (&temp_book[temp_book_pointer]) = idf; INFO (&temp_book[temp_book_pointer]) = info; NUMBER (&temp_book[temp_book_pointer]) = number; temp_book_pointer ++; } } /** @brief Whether identifier is signed_in. @param action Some identification as L_DECLARE or DEREFERENCING. @param phase Phase in which booking is made. @param idf Identifier name. @return Number given to it. **/ static BOOK_T * signed_in (int action, int phase, char * idf) { int k; for (k = 0; k < temp_book_pointer; k ++) { if (IDF (&temp_book[k]) == idf && ACTION (&temp_book[k]) == action && PHASE (&temp_book[k]) >= phase) { return (& (temp_book[k])); } } return (NO_BOOK); } /** @brief Make name. @param buf Output buffer. @param name Appropriate name. @param tag Optional tag to name. @param n Unique identifying number. @return Output buffer. **/ static char * make_name (char * buf, char * name, char * tag, int n) { if (strlen (tag) > 0) { ASSERT (snprintf (buf, NAME_SIZE, "%s_%s_%d", name, tag, n) >= 0); } else { ASSERT (snprintf (buf, NAME_SIZE, "%s_%d", name, n) >= 0); } ABEND (strlen (buf) >= NAME_SIZE, "make name error", NO_TEXT); return (buf); } /** @brief Whether two sub-trees are the same Algol 68 construct. @param l Left-hand tree. @param r Right-hand tree. @return See brief description. **/ static BOOL_T same_tree (NODE_T * l, NODE_T *r) { if (l == NO_NODE) { return ((BOOL_T) (r == NO_NODE)); } else if (r == NO_NODE) { return ((BOOL_T) (l == NO_NODE)); } else if (ATTRIBUTE (l) == ATTRIBUTE (r) && NSYMBOL (l) == NSYMBOL (r)) { return ((BOOL_T) (same_tree (SUB (l), SUB (r)) && same_tree (NEXT (l), NEXT (r)))); } else { return (A68_FALSE); } } /********************/ /* Basic mode check */ /********************/ /** @brief Whether primitive mode, with simple C equivalent. @param m Mode to check. @return See brief description. **/ static BOOL_T primitive_mode (MOID_T * m) { if (m == MODE (INT)) { return (A68_TRUE); } else if (m == MODE (REAL)) { return (A68_TRUE); } else if (m == MODE (BOOL)) { return (A68_TRUE); } else if (m == MODE (CHAR)) { return (A68_TRUE); } else if (m == MODE (BITS)) { return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Whether mode for which denotations are compiled. @param m Mode to check. @return See brief description. **/ static BOOL_T denotation_mode (MOID_T * m) { if (primitive_mode (m)) { return (A68_TRUE); } else if (LONG_MODE (m) && long_mode_allowed) { return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Whether mode is handled by the constant folder. @param m Mode to check. @return See brief description. **/ BOOL_T folder_mode (MOID_T * m) { if (primitive_mode (m)) { return (A68_TRUE); } else if (m == MODE (COMPLEX)) { return (A68_TRUE); } else if (LONG_MODE (m)) { return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Whether basic mode, for which units are compiled. @param m Mode to check. @return See brief description. **/ static BOOL_T basic_mode (MOID_T * m) { if (denotation_mode (m)) { return (A68_TRUE); } else if (IS (m, REF_SYMBOL)) { if (IS (SUB (m), REF_SYMBOL) || IS (SUB (m), PROC_SYMBOL)) { return (A68_FALSE); } else { return (basic_mode (SUB (m))); } } else if (IS (m, ROW_SYMBOL)) { if (primitive_mode (SUB (m))) { return (A68_TRUE); } else if (IS (SUB (m), STRUCT_SYMBOL)) { return (basic_mode (SUB (m))); } else { return (A68_FALSE); } } else if (IS (m, STRUCT_SYMBOL)) { PACK_T *p = PACK (m); for (; p != NO_PACK; FORWARD (p)) { if (!primitive_mode (MOID (p))) { return (A68_FALSE); } } return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Whether basic mode, which is not a row. @param m Mode to check. @return See brief description. **/ static BOOL_T basic_mode_non_row (MOID_T * m) { if (denotation_mode (m)) { return (A68_TRUE); } else if (IS (m, REF_SYMBOL)) { if (IS (SUB (m), REF_SYMBOL) || IS (SUB (m), PROC_SYMBOL)) { return (A68_FALSE); } else { return (basic_mode_non_row (SUB (m))); } } else if (IS (m, STRUCT_SYMBOL)) { PACK_T *p = PACK (m); for (; p != NO_PACK; FORWARD (p)) { if (!primitive_mode (MOID (p))) { return (A68_FALSE); } } return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Whether stems from certain attribute. @param p Node in syntax tree. @param att Attribute to comply to. @return See brief description. **/ static NODE_T * locate (NODE_T * p, int att) { if (IS (p, VOIDING)) { return (locate (SUB (p), att)); } else if (IS (p, UNIT)) { return (locate (SUB (p), att)); } else if (IS (p, TERTIARY)) { return (locate (SUB (p), att)); } else if (IS (p, SECONDARY)) { return (locate (SUB (p), att)); } else if (IS (p, PRIMARY)) { return (locate (SUB (p), att)); } else if (IS (p, att)) { return (p); } else { return (NO_NODE); } } /**********************************************************/ /* Basic unit check */ /* Whether a unit is sufficiently "basic" to be compiled. */ /**********************************************************/ /** @brief Whether basic collateral clause. @param p Node in syntax tree. @return See brief description. **/ static BOOL_T basic_collateral (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else if (IS (p, UNIT)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_unit (SUB (p)) && basic_collateral (NEXT (p)))); } else { return ((BOOL_T) (basic_collateral (SUB (p)) && basic_collateral (NEXT (p)))); } } /** @brief Whether basic serial clause. @param p Node in syntax tree. @param total Total units. @param good Basic units. @return See brief description. **/ static void count_basic_units (NODE_T * p, int * total, int * good) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { (* total) ++; if (basic_unit (p)) { (* good) ++; } } else if (IS (p, DECLARATION_LIST)) { (* total) ++; } else { count_basic_units (SUB (p), total, good); } } } /** @brief Whether basic serial clause. @param p Node in syntax tree. @param want > 0 is how many units we allow, <= 0 is don't care @return See brief description. **/ static BOOL_T basic_serial (NODE_T * p, int want) { int total = 0, good = 0; count_basic_units (p, &total, &good); if (want > 0) { return (total == want && total == good); } else { return (total == good); } } /** @brief Whether basic indexer. @param p Node in syntax tree. @return See brief description. **/ static BOOL_T basic_indexer (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else if (IS (p, TRIMMER)) { return (A68_FALSE); } else if (IS (p, UNIT)) { return (basic_unit (p)); } else { return ((BOOL_T) (basic_indexer (SUB (p)) && basic_indexer (NEXT (p)))); } } /** @brief Whether basic slice. @param p Starting node. @return See brief description. **/ static BOOL_T basic_slice (NODE_T * p) { if (IS (p, SLICE)) { NODE_T * prim = SUB (p); NODE_T * idf = locate (prim, IDENTIFIER); if (idf != NO_NODE) { NODE_T * indx = NEXT (prim); return (basic_indexer (indx)); } } return (A68_FALSE); } /** @brief Whether basic argument. @param p Starting node. @return See brief description. **/ static BOOL_T basic_argument (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else if (IS (p, UNIT)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_unit (p) && basic_argument (NEXT (p)))); } else { return ((BOOL_T) (basic_argument (SUB (p)) && basic_argument (NEXT (p)))); } } /** @brief Whether basic call. @param p Starting node. @return See brief description. **/ static BOOL_T basic_call (NODE_T * p) { if (IS (p, CALL)) { NODE_T * prim = SUB (p); NODE_T * idf = locate (prim, IDENTIFIER); if (idf == NO_NODE) { return (A68_FALSE); } else if (SUB_MOID (idf) == MOID (p)) { /* Prevent partial parametrisation */ int k; for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) { NODE_T * args = NEXT (prim); return (basic_argument (args)); } } } } return (A68_FALSE); } /** @brief Whether basic monadic formula. @param p Starting node. @return See brief description. **/ static BOOL_T basic_monadic_formula (NODE_T * p) { if (IS (p, MONADIC_FORMULA)) { NODE_T * op = SUB (p); int k; for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) { NODE_T * rhs = NEXT (op); return (basic_unit (rhs)); } } } return (A68_FALSE); } /** @brief Whether basic dyadic formula. @param p Starting node. @return See brief description. **/ static BOOL_T basic_formula (NODE_T * p) { if (IS (p, FORMULA)) { NODE_T * lhs = SUB (p); NODE_T * op = NEXT (lhs); if (op == NO_NODE) { return (basic_monadic_formula (lhs)); } else { int k; for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) { NODE_T * rhs = NEXT (op); return ((BOOL_T) (basic_unit (lhs) && basic_unit (rhs))); } } } } return (A68_FALSE); } /** @brief Whether basic conditional clause. @param p Starting node. @return See brief description. **/ static BOOL_T basic_conditional (NODE_T * p) { if (! (IS (p, IF_PART) || IS (p, OPEN_PART))) { return (A68_FALSE); } if (! basic_serial (NEXT_SUB (p), 1)) { return (A68_FALSE); } FORWARD (p); if (! (IS (p, THEN_PART) || IS (p, CHOICE))) { return (A68_FALSE); } if (! basic_serial (NEXT_SUB (p), 1)) { return (A68_FALSE); } FORWARD (p); if (IS (p, ELSE_PART) || IS (p, CHOICE)) { return (basic_serial (NEXT_SUB (p), 1)); } else if (IS (p, FI_SYMBOL)) { return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Whether basic unit. @param p Starting node. @return See brief description. **/ static BOOL_T basic_unit (NODE_T * p) { if (p == NO_NODE) { return (A68_FALSE); } else if (IS (p, UNIT)) { return (basic_unit (SUB (p))); } else if (IS (p, TERTIARY)) { return (basic_unit (SUB (p))); } else if (IS (p, SECONDARY)) { return (basic_unit (SUB (p))); } else if (IS (p, PRIMARY)) { return (basic_unit (SUB (p))); } else if (IS (p, ENCLOSED_CLAUSE)) { return (basic_unit (SUB (p))); } else if (IS (p, CLOSED_CLAUSE)) { return (basic_serial (NEXT_SUB (p), 1)); } else if (IS (p, COLLATERAL_CLAUSE)) { return (basic_mode (MOID (p)) && basic_collateral (NEXT_SUB (p))); } else if (IS (p, CONDITIONAL_CLAUSE)) { return (basic_mode (MOID (p)) && basic_conditional (SUB (p))); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), IDENTIFIER) != NO_NODE) { NODE_T * dst = SUB_SUB (p); NODE_T * src = NEXT_NEXT (dst); return ((BOOL_T) basic_unit (src) && basic_mode_non_row (MOID (src))); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SLICE) != NO_NODE) { NODE_T * dst = SUB_SUB (p); NODE_T * src = NEXT_NEXT (dst); NODE_T * slice = locate (dst, SLICE); return ((BOOL_T) (IS (MOID (slice), REF_SYMBOL) && basic_slice (slice) && basic_unit (src) && basic_mode_non_row (MOID (src)))); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SELECTION) != NO_NODE) { NODE_T * dst = SUB_SUB (p); NODE_T * src = NEXT_NEXT (dst); return ((BOOL_T) (locate (NEXT_SUB (locate (dst, SELECTION)), IDENTIFIER) != NO_NODE && basic_unit (src) && basic_mode_non_row (MOID (dst)))); } else if (IS (p, VOIDING)) { return (basic_unit (SUB (p))); } else if (IS (p, DEREFERENCING) && locate (SUB (p), IDENTIFIER)) { return ((BOOL_T) (basic_mode (MOID (p)) && BASIC (SUB (p), IDENTIFIER))); } else if (IS (p, DEREFERENCING) && locate (SUB (p), SLICE)) { NODE_T * slice = locate (SUB (p), SLICE); return ((BOOL_T) (basic_mode (MOID (p)) && IS (MOID (SUB (slice)), REF_SYMBOL) && basic_slice (slice))); } else if (IS (p, DEREFERENCING) && locate (SUB (p), SELECTION)) { return ((BOOL_T) (primitive_mode (MOID (p)) && BASIC (SUB (p), SELECTION))); } else if (IS (p, WIDENING)) { if (WIDEN_TO (p, INT, REAL)) { return (basic_unit (SUB (p))); } else if (WIDEN_TO (p, INT, LONG_INT)) { return (basic_unit (SUB (p))); } else if (WIDEN_TO (p, REAL, COMPLEX)) { return (basic_unit (SUB (p))); } else if (WIDEN_TO (p, REAL, LONG_REAL)) { return (basic_unit (SUB (p))); } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) { return (basic_unit (SUB (p))); } else { return (A68_FALSE); } } else if (IS (p, IDENTIFIER)) { if (A68G_STANDENV_PROC (TAX (p))) { int k; for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) { return (A68_TRUE); } } return (A68_FALSE); } else { return (basic_mode (MOID (p))); } } else if (IS (p, DENOTATION)) { return (denotation_mode (MOID (p))); } else if (IS (p, MONADIC_FORMULA)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_monadic_formula (p))); } else if (IS (p, FORMULA)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_formula (p))); } else if (IS (p, CALL)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_call (p))); } else if (IS (p, CAST)) { return ((BOOL_T) (folder_mode (MOID (SUB (p))) && basic_unit (NEXT_SUB (p)))); } else if (IS (p, SLICE)) { return ((BOOL_T) (basic_mode (MOID (p)) && basic_slice (p))); } else if (IS (p, SELECTION)) { NODE_T * sec = locate (NEXT_SUB (p), IDENTIFIER); if (sec == NO_NODE) { return (A68_FALSE); } else { return (basic_mode_non_row (MOID (sec))); } } else if (IS (p, IDENTITY_RELATION)) { #define GOOD(p) (locate (p, IDENTIFIER) != NO_NODE && IS (MOID (locate ((p), IDENTIFIER)), REF_SYMBOL)) NODE_T * lhs = SUB (p); NODE_T * rhs = NEXT_NEXT (lhs); if (GOOD (lhs) && GOOD (rhs)) { return (A68_TRUE); } else if (GOOD (lhs) && locate (rhs, NIHIL) != NO_NODE) { return (A68_TRUE); } else { return (A68_FALSE); } #undef GOOD } else { return (A68_FALSE); } } /*******************************************************************/ /* Constant folder */ /* Uses interpreter routines to calculate compile-time expressions */ /*******************************************************************/ /***********************/ /* Constant unit check */ /***********************/ /** @brief Whether constant collateral clause. @param p Node in syntax tree. @return See brief description. **/ static BOOL_T constant_collateral (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else if (IS (p, UNIT)) { return ((BOOL_T) (folder_mode (MOID (p)) && constant_unit (SUB (p)) && constant_collateral (NEXT (p)))); } else { return ((BOOL_T) (constant_collateral (SUB (p)) && constant_collateral (NEXT (p)))); } } /** @brief Whether constant serial clause. @param p Node in syntax tree. @param total Total units. @param good Basic units. @return See brief description. **/ static void count_constant_units (NODE_T * p, int * total, int * good) { if (p != NO_NODE) { if (IS (p, UNIT)) { (* total) ++; if (constant_unit (p)) { (* good) ++; } count_constant_units (NEXT (p), total, good); } else { count_constant_units (SUB (p), total, good); count_constant_units (NEXT (p), total, good); } } } /** @brief Whether constant serial clause. @param p Node in syntax tree. @param want > 0 is how many units we allow, <= 0 is don't care @return See brief description. **/ static BOOL_T constant_serial (NODE_T * p, int want) { int total = 0, good = 0; count_constant_units (p, &total, &good); if (want > 0) { return (total == want && total == good); } else { return (total == good); } } /** @brief Whether constant argument. @param p Starting node. @return See brief description. **/ static BOOL_T constant_argument (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else if (IS (p, UNIT)) { return ((BOOL_T) (folder_mode (MOID (p)) && constant_unit (p) && constant_argument (NEXT (p)))); } else { return ((BOOL_T) (constant_argument (SUB (p)) && constant_argument (NEXT (p)))); } } /** @brief Whether constant call. @param p Starting node. @return See brief description. **/ static BOOL_T constant_call (NODE_T * p) { if (IS (p, CALL)) { NODE_T * prim = SUB (p); NODE_T * idf = locate (prim, IDENTIFIER); if (idf != NO_NODE) { int k; for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) { NODE_T * args = NEXT (prim); return (constant_argument (args)); } } } } return (A68_FALSE); } /** @brief Whether constant monadic formula. @param p Starting node. @return See brief description. **/ static BOOL_T constant_monadic_formula (NODE_T * p) { if (IS (p, MONADIC_FORMULA)) { NODE_T * op = SUB (p); int k; for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) { NODE_T * rhs = NEXT (op); return (constant_unit (rhs)); } } } return (A68_FALSE); } /** @brief Whether constant dyadic formula. @param p Starting node. @return See brief description. **/ static BOOL_T constant_formula (NODE_T * p) { if (IS (p, FORMULA)) { NODE_T * lhs = SUB (p); NODE_T * op = NEXT (lhs); if (op == NO_NODE) { return (constant_monadic_formula (lhs)); } else { int k; for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) { NODE_T * rhs = NEXT (op); return ((BOOL_T) (constant_unit (lhs) && constant_unit (rhs))); } } } } return (A68_FALSE); } /** @brief Whether constant unit. @param p Starting node. @return See brief description. **/ BOOL_T constant_unit (NODE_T * p) { if (p == NO_NODE) { return (A68_FALSE); } else if (IS (p, UNIT)) { return (constant_unit (SUB (p))); } else if (IS (p, TERTIARY)) { return (constant_unit (SUB (p))); } else if (IS (p, SECONDARY)) { return (constant_unit (SUB (p))); } else if (IS (p, PRIMARY)) { return (constant_unit (SUB (p))); } else if (IS (p, ENCLOSED_CLAUSE)) { return (constant_unit (SUB (p))); } else if (IS (p, CLOSED_CLAUSE)) { return (constant_serial (NEXT_SUB (p), 1)); } else if (IS (p, COLLATERAL_CLAUSE)) { return (folder_mode (MOID (p)) && constant_collateral (NEXT_SUB (p))); } else if (IS (p, WIDENING)) { if (WIDEN_TO (p, INT, REAL)) { return (constant_unit (SUB (p))); } else if (WIDEN_TO (p, INT, LONG_INT)) { return (constant_unit (SUB (p))); } else if (WIDEN_TO (p, REAL, COMPLEX)) { return (constant_unit (SUB (p))); } else if (WIDEN_TO (p, REAL, LONG_REAL)) { return (constant_unit (SUB (p))); } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) { return (constant_unit (SUB (p))); } else { return (A68_FALSE); } } else if (IS (p, IDENTIFIER)) { if (A68G_STANDENV_PROC (TAX (p))) { int k; for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) { return (A68_TRUE); } } return (A68_FALSE); } else { /* Possible constant folding */ NODE_T * def = NODE (TAX (p)); BOOL_T ret = A68_FALSE; if (STATUS (p) & COOKIE_MASK) { diagnostic_node (A68_WARNING, p, WARNING_UNINITIALISED); } else { STATUS (p) |= COOKIE_MASK; if (folder_mode (MOID (p)) && def != NO_NODE && NEXT (def) != NO_NODE && IS (NEXT (def), EQUALS_SYMBOL)) { ret = constant_unit (NEXT_NEXT (def)); } } STATUS (p) &= !(COOKIE_MASK); return (ret); } } else if (IS (p, DENOTATION)) { return (denotation_mode (MOID (p))); } else if (IS (p, MONADIC_FORMULA)) { return ((BOOL_T) (folder_mode (MOID (p)) && constant_monadic_formula (p))); } else if (IS (p, FORMULA)) { return ((BOOL_T) (folder_mode (MOID (p)) && constant_formula (p))); } else if (IS (p, CALL)) { return ((BOOL_T) (folder_mode (MOID (p)) && constant_call (p))); } else if (IS (p, CAST)) { return ((BOOL_T) (folder_mode (MOID (SUB (p))) && constant_unit (NEXT_SUB (p)))); } else { return (A68_FALSE); } } /*****************************************************************/ /* Evaluate compile-time expressions using interpreter routines. */ /*****************************************************************/ /** @brief Push denotation. @param p Node in syntax tree. **/ static void push_denotation (NODE_T * p) { #define PUSH_DENOTATION(mode, decl) {\ decl z;\ NODE_T *s = (IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p));\ if (genie_string_to_value_internal (p, MODE (mode), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {\ diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (mode));\ }\ PUSH_PRIMITIVE (p, VALUE (&z), decl);} /**/ #define PUSH_LONG_DENOTATION(mode, decl) {\ decl z;\ NODE_T *s = (IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p));\ if (genie_string_to_value_internal (p, MODE (mode), NSYMBOL (s), (BYTE_T *) z) == A68_FALSE) {\ diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (mode));\ }\ PUSH (p, &z, SIZE (MODE (mode)));} /**/ if (MOID (p) == MODE (INT)) { PUSH_DENOTATION (INT, A68_INT); } else if (MOID (p) == MODE (REAL)) { PUSH_DENOTATION (REAL, A68_REAL); } else if (MOID (p) == MODE (BOOL)) { PUSH_DENOTATION (BOOL, A68_BOOL); } else if (MOID (p) == MODE (CHAR)) { if ((NSYMBOL (p))[0] == NULL_CHAR) { PUSH_PRIMITIVE (p, NULL_CHAR, A68_CHAR); } else { PUSH_PRIMITIVE (p, (NSYMBOL (p))[0], A68_CHAR); } } else if (MOID (p) == MODE (BITS)) { PUSH_DENOTATION (BITS, A68_BITS); } else if (MOID (p) == MODE (LONG_INT)) { PUSH_LONG_DENOTATION (LONG_INT, A68_LONG); } else if (MOID (p) == MODE (LONG_REAL)) { PUSH_LONG_DENOTATION (LONG_REAL, A68_LONG); } #undef PUSH_DENOTATION #undef PUSH_LONG_DENOTATION } /** @brief Push widening. @param p Starting node. **/ static void push_widening (NODE_T * p) { push_unit (SUB (p)); if (WIDEN_TO (p, INT, REAL)) { A68_INT k; POP_OBJECT (p, &k, A68_INT); PUSH_PRIMITIVE (p, (double) VALUE (&k), A68_REAL); } else if (WIDEN_TO (p, REAL, COMPLEX)) { PUSH_PRIMITIVE (p, 0.0, A68_REAL); } else if (WIDEN_TO (p, INT, LONG_INT)) { genie_lengthen_int_to_long_mp (p); } else if (WIDEN_TO (p, REAL, LONG_REAL)) { genie_lengthen_real_to_long_mp (p); } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) { /* 1:1 mapping */; } } /** @brief Code collateral units. @param p Starting node. **/ static void push_collateral_units (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, UNIT)) { push_unit (p); } else { push_collateral_units (SUB (p)); push_collateral_units (NEXT (p)); } } /** @brief Code argument. @param p Starting node. **/ static void push_argument (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { push_unit (p); } else { push_argument (SUB (p)); } } } /** @brief Push unit. @param p Starting node. **/ void push_unit (NODE_T * p) { if (p == NO_NODE) { return; } if (IS (p, UNIT)) { push_unit (SUB (p)); } else if (IS (p, TERTIARY)) { push_unit (SUB (p)); } else if (IS (p, SECONDARY)) { push_unit (SUB (p)); } else if (IS (p, PRIMARY)) { push_unit (SUB (p)); } else if (IS (p, ENCLOSED_CLAUSE)) { push_unit (SUB (p)); } else if (IS (p, CLOSED_CLAUSE)) { push_unit (SUB (NEXT_SUB (p))); } else if (IS (p, COLLATERAL_CLAUSE)) { push_collateral_units (NEXT_SUB (p)); } else if (IS (p, WIDENING)) { push_widening (p); } else if (IS (p, IDENTIFIER)) { if (A68G_STANDENV_PROC (TAX (p))) { (void) (*(PROCEDURE (TAX (p)))) (p); } else { /* Possible constant folding */ NODE_T * def = NODE (TAX (p)); push_unit (NEXT_NEXT (def)); } } else if (IS (p, DENOTATION)) { push_denotation (p); } else if (IS (p, MONADIC_FORMULA)) { NODE_T * op = SUB (p); NODE_T * rhs = NEXT (op); push_unit (rhs); (*(PROCEDURE (TAX (op)))) (op); } else if (IS (p, FORMULA)) { NODE_T * lhs = SUB (p); NODE_T * op = NEXT (lhs); if (op == NO_NODE) { push_unit (lhs); } else { NODE_T * rhs = NEXT (op); push_unit (lhs); push_unit (rhs); (*(PROCEDURE (TAX (op)))) (op); } } else if (IS (p, CALL)) { NODE_T * prim = SUB (p); NODE_T * args = NEXT (prim); NODE_T * idf = locate (prim, IDENTIFIER); push_argument (args); (void) (*(PROCEDURE (TAX (idf)))) (p); } else if (IS (p, CAST)) { push_unit (NEXT_SUB (p)); } } /** @brief Code constant folding. @param p Node to start. @param out Output file descriptor. @param phase Phase of code generation. **/ static void constant_folder (NODE_T * p, FILE_T out, int phase) { if (phase == L_DECLARE) { if (MOID (p) == MODE (COMPLEX)) { char acc[NAME_SIZE]; A68_REAL re, im; (void) make_name (acc, CON, "", NUMBER (p)); stack_pointer = 0; push_unit (p); POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_COMPLEX %s = {", acc)); undentf (out, snprintf (line, SNPRINTF_SIZE, "{INIT_MASK, %.*g}", REAL_WIDTH, VALUE (&re))); undentf (out, snprintf (line, SNPRINTF_SIZE, ", {INIT_MASK, %.*g}", REAL_WIDTH, VALUE (&im))); undent (out, "};\n"); ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (LONG_MODE (MOID (p))) { char acc[NAME_SIZE]; A68_LONG z; int k; (void) make_name (acc, CON, "", NUMBER (p)); stack_pointer = 0; push_unit (p); POP (p, &z, SIZE (MOID (p))); indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_LONG %s = {INIT_MASK, %.0f", acc, z[1])); for (k = 1; k <= LONG_MP_DIGITS; k ++) { undentf (out, snprintf (line, SNPRINTF_SIZE, ", %.0f", z[k + 1])); } undent (out, "};\n"); ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } } else if (phase == L_EXECUTE) { if (MOID (p) == MODE (COMPLEX)) { /* Done at declaration stage */ } else if (LONG_MODE (MOID (p))) { /* Done at declaration stage */ } } else if (phase == L_YIELD) { if (MOID (p) == MODE (INT)) { A68_INT k; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &k, A68_INT); ASSERT (snprintf (line, SNPRINTF_SIZE, "%d", VALUE (&k)) >= 0); undent (out, line); ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (MOID (p) == MODE (REAL)) { A68_REAL x; double conv; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &x, A68_REAL); /* Mind overflowing or underflowing values */ if (VALUE (&x) == DBL_MAX) { undent (out, "DBL_MAX"); } else if (VALUE (&x) == -DBL_MAX) { undent (out, "(-DBL_MAX)"); } else { ASSERT (snprintf (line, SNPRINTF_SIZE, "%.*g", REAL_WIDTH, VALUE (&x)) >= 0); errno = 0; conv = strtod (line, NO_VAR); if (errno == ERANGE && conv == 0.0) { undent (out, "0.0"); } else if (errno == ERANGE && conv == HUGE_VAL) { diagnostic_node (A68_WARNING, p, WARNING_OVERFLOW, MODE (REAL)); undent (out, "DBL_MAX"); } else if (errno == ERANGE && conv == -HUGE_VAL) { diagnostic_node (A68_WARNING, p, WARNING_OVERFLOW, MODE (REAL)); undent (out, "(-DBL_MAX)"); } else if (errno == ERANGE && conv >= 0) { diagnostic_node (A68_WARNING, p, WARNING_UNDERFLOW, MODE (REAL)); undent (out, "DBL_MIN"); } else if (errno == ERANGE && conv < 0) { diagnostic_node (A68_WARNING, p, WARNING_UNDERFLOW, MODE (REAL)); undent (out, "(-DBL_MIN)"); } else { if (strchr (line, '.') == NO_TEXT && strchr (line, 'e') == NO_TEXT && strchr (line, 'E') == NO_TEXT) { strncat (line, ".0", BUFFER_SIZE); } undent (out, line); } } ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (MOID (p) == MODE (BOOL)) { A68_BOOL b; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &b, A68_BOOL); ASSERT (snprintf (line, SNPRINTF_SIZE, "%s", (VALUE (&b) ? "A68_TRUE" : "A68_FALSE")) >= 0); undent (out, line); ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (MOID (p) == MODE (CHAR)) { A68_CHAR c; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &c, A68_CHAR); if (VALUE (&c) == '\'') { undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\\''")); } else if (VALUE (&c) == '\\') { undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\\\'")); } else if (VALUE (&c) == NULL_CHAR) { undentf (out, snprintf (line, SNPRINTF_SIZE, "NULL_CHAR")); } else if (IS_PRINT (VALUE (&c))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "'%c'", VALUE (&c))); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "(int) 0x%04x", (unsigned) VALUE (&c))); } ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (MOID (p) == MODE (BITS)) { A68_BITS b; stack_pointer = 0; push_unit (p); POP_OBJECT (p, &b, A68_BITS); ASSERT (snprintf (line, SNPRINTF_SIZE, "0x%x", VALUE (&b)) >= 0); undent (out, line); ABEND (stack_pointer > 0, "stack not empty", NO_TEXT); } else if (MOID (p) == MODE (COMPLEX)) { char acc[NAME_SIZE]; (void) make_name (acc, CON, "", NUMBER (p)); undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) %s", acc)); } else if (LONG_MODE (MOID (p))) { char acc[NAME_SIZE]; (void) make_name (acc, CON, "", NUMBER (p)); undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) %s", acc)); } } } /********************************************/ /* Auxilliary routines for emitting C code. */ /********************************************/ /** @brief Whether frame needs initialisation. @param p Node in syntax tree. **/ static BOOL_T need_initialise_frame (NODE_T * p) { TAG_T *tag; int count; for (tag = ANONYMOUS (TABLE (p)); tag != NO_TAG; FORWARD (tag)) { if (PRIO (tag) == ROUTINE_TEXT) { return (A68_TRUE); } else if (PRIO (tag) == FORMAT_TEXT) { return (A68_TRUE); } } count = 0; genie_find_proc_op (p, &count); if (count > 0) { return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Comment source line. @param p Node in syntax tree. @param out Output file descriptor. @param want_space Space required. @param max_print Maximum items to print. **/ static void comment_tree (NODE_T * p, FILE_T out, int *want_space, int *max_print) { /* Take care not to generate nested comments */ #define UNDENT(out, p) {\ char * q;\ for (q = p; q[0] != NULL_CHAR; q ++) {\ if (q[0] == '*' && q[1] == '/') {\ undent (out, "\\*\\/");\ q ++;\ } else if (q[0] == '/' && q[1] == '*') {\ undent (out, "\\/\\*");\ q ++;\ } else {\ char w[2];\ w[0] = q[0];\ w[1] = NULL_CHAR;\ undent (out, w);\ }\ }} /**/ for (; p != NO_NODE && (*max_print) >= 0; FORWARD (p)) { if (IS (p, ROW_CHAR_DENOTATION)) { if (*want_space != 0) { UNDENT (out, " "); } UNDENT (out, "\""); UNDENT (out, NSYMBOL (p)); UNDENT (out, "\""); *want_space = 2; } else if (SUB (p) != NO_NODE) { comment_tree (SUB (p), out, want_space, max_print); } else if (NSYMBOL (p)[0] == '(' || NSYMBOL (p)[0] == '[' || NSYMBOL (p)[0] == '{') { if (*want_space == 2) { UNDENT (out, " "); } UNDENT (out, NSYMBOL (p)); *want_space = 0; } else if (NSYMBOL (p)[0] == ')' || NSYMBOL (p)[0] == ']' || NSYMBOL (p)[0] == '}') { UNDENT (out, NSYMBOL (p)); *want_space = 1; } else if (NSYMBOL (p)[0] == ';' || NSYMBOL (p)[0] == ',') { UNDENT (out, NSYMBOL (p)); *want_space = 2; } else if (strlen (NSYMBOL (p)) == 1 && (NSYMBOL (p)[0] == '.' || NSYMBOL (p)[0] == ':')) { UNDENT (out, NSYMBOL (p)); *want_space = 2; } else { if (*want_space != 0) { UNDENT (out, " "); } if ((*max_print) > 0) { UNDENT (out, NSYMBOL (p)); } else if ((*max_print) == 0) { if (*want_space == 0) { UNDENT (out, " "); } UNDENT (out, "..."); } (*max_print)--; if (IS_UPPER (NSYMBOL (p)[0])) { *want_space = 2; } else if (! IS_ALNUM (NSYMBOL (p)[0])) { *want_space = 2; } else { *want_space = 1; } } } #undef UNDENT } /** @brief Comment source line. @param p Node in syntax tree. @param out Output file descriptor. **/ static void comment_source (NODE_T * p, FILE_T out) { int want_space = 0, max_print = 16; undentf (out, snprintf (line, SNPRINTF_SIZE, "/* %s: %d: ", FILENAME (LINE (INFO (p))), LINE_NUMBER (p))); comment_tree (p, out, &want_space, &max_print); undent (out, " */\n"); } /** @brief Inline comment source line. @param p Node in syntax tree. @param out Output file descriptor. **/ static void inline_comment_source (NODE_T * p, FILE_T out) { int want_space = 0, max_print = 8; undent (out, " /* "); comment_tree (p, out, &want_space, &max_print); undent (out, " */"); } /** @brief Write prelude. @param out Output file descriptor. **/ static void write_prelude (FILE_T out) { indentf (out, snprintf (line, SNPRINTF_SIZE, "/* \"%s\" %s */\n\n", FILE_OBJECT_NAME (&program), PACKAGE_STRING)); if (OPTION_LOCAL (&program)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "#include \"a68g-config.h\"\n")); indentf (out, snprintf (line, SNPRINTF_SIZE, "#include \"a68g.h\"\n\n")); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "#include <%s/a68g-config.h>\n", PACKAGE)); indentf (out, snprintf (line, SNPRINTF_SIZE, "#include <%s/a68g.h>\n\n", PACKAGE)); } indent (out, "#define _CODE_(n) PROP_T n (NODE_T * p) {\\\n"); indent (out, " PROP_T self;\n\n"); indent (out, "#define _EDOC_(n, q) UNIT (&self) = n;\\\n"); indent (out, " SOURCE (&self) = q;\\\n"); indent (out, " (void) p;\\\n"); indent (out, " return (self);}\n\n"); indent (out, "#define DIV_INT(i, j) ((double) (i) / (double) (j))\n"); indent (out, "#define _N_(n) (node_register[n])\n"); indent (out, "#define _S_(z) (STATUS (z))\n"); indent (out, "#define _V_(z) (VALUE (z))\n\n"); } /** @brief Write initialisation of frame. **/ static void init_static_frame (FILE_T out, NODE_T * p) { if (AP_INCREMENT (TABLE (p)) > 0) { indentf (out, snprintf (line, SNPRINTF_SIZE, "FRAME_CLEAR (%d);\n", AP_INCREMENT (TABLE (p)))); } if (LEX_LEVEL (p) == global_level) { indent (out, "global_pointer = frame_pointer;\n"); } if (need_initialise_frame (p)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "initialise_frame (_N_ (%d));\n", NUMBER (p))); } } /********************************/ /* COMPILATION OF PARTIAL UNITS */ /********************************/ /** @brief Code getting objects from the stack. @param p Node in syntax tree. @param out Output file descriptor. @param dst Where to store. @param cast Mode to cast to. **/ static void get_stack (NODE_T * p, FILE_T out, char * dst, char * cast) { if (DEBUG_LEVEL >= 4) { if (LEVEL (GINFO (p)) == global_level) { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_GLOBAL (%s, %s, %d);\n", dst, cast, OFFSET (TAX (p)))); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, %d);\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p)))); } } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_FRAME (%s, %s, %d, %d);\n", dst, cast, LEVEL (GINFO (p)), OFFSET (TAX (p)))); } } /** @brief Code function prelude. @param out Output file descriptor. @param p Node in syntax tree. @param fn Function name. **/ static void write_fun_prelude (NODE_T * p, FILE_T out, char * fn) { (void) p; indentf (out, snprintf (line, SNPRINTF_SIZE, "_CODE_ (%s)\n", fn)); indentation ++; temp_book_pointer = 0; } /** @brief Code function postlude. @param out Output file descriptor. @param p Node in syntax tree. @param fn Function name. **/ static void write_fun_postlude (NODE_T * p, FILE_T out, char * fn) { (void) p; indentation --; indentf (out, snprintf (line, SNPRINTF_SIZE, "_EDOC_ (%s, _N_ (%d))\n\n", fn, NUMBER (p))); temp_book_pointer = 0; } /** @brief Code internal a68g mode. @param m Mode to check. @return See brief description. **/ static char *internal_mode (MOID_T * m) { if (m == MODE (INT)) { return ("MODE (INT)"); } else if (m == MODE (REAL)) { return ("MODE (REAL)"); } else if (m == MODE (BOOL)) { return ("MODE (BOOL)"); } else if (m == MODE (CHAR)) { return ("MODE (CHAR)"); } else if (m == MODE (BITS)) { return ("MODE (BITS)"); } else { return ("MODE (ERROR)"); } } /** @brief Code an A68 mode. @param m Mode to code. @return Internal identifier for mode. **/ static char * inline_mode (MOID_T * m) { if (m == MODE (INT)) { return ("A68_INT"); } else if (m == MODE (REAL)) { return ("A68_REAL"); } else if (LONG_MODE (m)) { return ("A68_LONG"); } else if (m == MODE (BOOL)) { return ("A68_BOOL"); } else if (m == MODE (CHAR)) { return ("A68_CHAR"); } else if (m == MODE (BITS)) { return ("A68_BITS"); } else if (m == MODE (COMPLEX)) { return ("A68_COMPLEX"); } else if (IS (m, REF_SYMBOL)) { return ("A68_REF"); } else if (IS (m, ROW_SYMBOL)) { return ("A68_ROW"); } else if (IS (m, PROC_SYMBOL)) { return ("A68_PROCEDURE"); } else if (IS (m, STRUCT_SYMBOL)) { return ("A68_STRUCT"); } else { return ("A68_ERROR"); } } /** @brief Code denotation. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_denotation (NODE_T * p, FILE_T out, int phase) { if (phase == L_DECLARE && LONG_MODE (MOID (p))) { char acc[NAME_SIZE]; A68_LONG z; NODE_T *s = IS (SUB (p), LONGETY) ? NEXT_SUB (p) : SUB (p); int k; (void) make_name (acc, CON, "", NUMBER (p)); if (genie_string_to_value_internal (p, MOID (p), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (INT)); } indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_LONG %s = {INIT_MASK, %.0f", acc, z[1])); for (k = 1; k <= LONG_MP_DIGITS; k ++) { undentf (out, snprintf (line, SNPRINTF_SIZE, ", %.0f", z[k + 1])); } undent (out, "};\n"); } if (phase == L_YIELD) { if (MOID (p) == MODE (INT)) { A68_INT z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); char *den = NSYMBOL (s); if (genie_string_to_value_internal (p, MODE (INT), den, (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (INT)); } undentf (out, snprintf (line, SNPRINTF_SIZE, "%d", VALUE (&z))); } else if (MOID (p) == MODE (REAL)) { A68_REAL z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); char *den = NSYMBOL (s); if (genie_string_to_value_internal (p, MODE (REAL), den, (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (REAL)); } if (strchr (den, '.') == NO_TEXT && strchr (den, 'e') == NO_TEXT && strchr (den, 'E') == NO_TEXT) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(double) %s", den)); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", den)); } } else if (LONG_MODE (MOID (p))) { char acc[NAME_SIZE]; (void) make_name (acc, CON, "", NUMBER (p)); undent (out, acc); } else if (MOID (p) == MODE (BOOL)) { undent (out, "(BOOL_T) A68_"); undent (out, NSYMBOL (p)); } else if (MOID (p) == MODE (CHAR)) { if (NSYMBOL (p)[0] == '\'') { undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\''")); } else if (NSYMBOL (p)[0] == NULL_CHAR) { undentf (out, snprintf (line, SNPRINTF_SIZE, "NULL_CHAR")); } else if (NSYMBOL (p)[0] == '\\') { undentf (out, snprintf (line, SNPRINTF_SIZE, "'\\\\'")); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "'%c'", (NSYMBOL (p))[0])); } } else if (MOID (p) == MODE (BITS)) { A68_BITS z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, MODE (BITS), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (BITS)); } ASSERT (snprintf (line, SNPRINTF_SIZE, "(unsigned) 0x%x", VALUE (&z)) >= 0); undent (out, line); } } } /** @brief Code widening. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_widening (NODE_T * p, FILE_T out, int phase) { if (WIDEN_TO (p, INT, REAL)) { if (phase == L_DECLARE) { inline_unit (SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (p), out, L_EXECUTE); } else if (phase == L_YIELD) { undent (out, "(double) ("); inline_unit (SUB (p), out, L_YIELD); undent (out, ")"); } } else if (WIDEN_TO (p, REAL, COMPLEX)) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MODE (COMPLEX)), 0, acc); inline_unit (SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (p), out, L_EXECUTE); indentf (out, snprintf (line, SNPRINTF_SIZE, "STATUS_RE (%s) = INIT_MASK;\n", acc)); indentf (out, snprintf (line, SNPRINTF_SIZE, "STATUS_IM (%s) = INIT_MASK;\n", acc)); indentf (out, snprintf (line, SNPRINTF_SIZE, "RE (%s) = (double) (", acc)); inline_unit (SUB (p), out, L_YIELD); undent (out, ");\n"); indentf (out, snprintf (line, SNPRINTF_SIZE, "IM (%s) = 0.0;\n", acc)); } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) %s", acc)); } } else if (WIDEN_TO (p, INT, LONG_INT)) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MODE (LONG_INT)), 0, acc); inline_unit (SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (p), out, L_EXECUTE); indentf (out, snprintf (line, SNPRINTF_SIZE, "(void) int_to_mp (_N_ (%d), %s, ", NUMBER (p), acc)); inline_unit (SUB (p), out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) %s", acc)); } } else if (WIDEN_TO (p, REAL, LONG_REAL)) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MODE (LONG_REAL)), 0, acc); inline_unit (SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (p), out, L_EXECUTE); indentf (out, snprintf (line, SNPRINTF_SIZE, "(void) real_to_mp (_N_ (%d), %s, ", NUMBER (p), acc)); inline_unit (SUB (p), out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) %s", acc)); } } else if (WIDEN_TO (p, LONG_INT, LONG_REAL)) { inline_unit (SUB (p), out, phase); } } /** @brief Code dereferencing of identifier. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_dereference_identifier (NODE_T * p, FILE_T out, int phase) { NODE_T * q = locate (SUB (p), IDENTIFIER); ABEND (q == NO_NODE, "not dereferencing an identifier", NO_TEXT); if (phase == L_DECLARE) { if (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)) != NO_BOOK) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (q), "", NUMBER (p)); (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, idf); sign_in (BOOK_DEREF, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p)); inline_unit (SUB (p), out, L_DECLARE); } } else if (phase == L_EXECUTE) { if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) != NO_BOOK) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (q), "", NUMBER (p)); inline_unit (SUB (p), out, L_EXECUTE); if (BODY (TAX (q)) != NO_TAG) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) LOCAL_ADDRESS (", idf, inline_mode (MOID (p)))); sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p)); inline_unit (SUB (p), out, L_YIELD); undent (out, ");\n"); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, ", idf, inline_mode (MOID (p)))); sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p)); inline_unit (SUB (p), out, L_YIELD); undent (out, ");\n"); } } } else if (phase == L_YIELD) { char idf[NAME_SIZE]; if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) != NO_BOOK) { (void) make_name (idf, NSYMBOL (q), "", NUMBER (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)))); } else { (void) make_name (idf, NSYMBOL (q), "", NUMBER (p)); } if (primitive_mode (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", idf)); } else if (MOID (p) == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf)); } else if (LONG_MODE (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", idf)); } else if (basic_mode (MOID (p))) { undent (out, idf); } } } /** @brief Code identifier. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_identifier (NODE_T * p, FILE_T out, int phase) { /* Possible constant folding */ NODE_T * def = NODE (TAX (p)); if (primitive_mode (MOID (p)) && def != NO_NODE && NEXT (def) != NO_NODE && IS (NEXT (def), EQUALS_SYMBOL)) { NODE_T * src = locate (NEXT_NEXT (def), DENOTATION); if (src != NO_NODE) { inline_denotation (src, out, phase); return; } } /* No folding - consider identifier */ if (phase == L_DECLARE) { if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (p)) != NO_BOOK) { return; } else if (A68G_STANDENV_PROC (TAX (p))) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, idf); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p)); } } else if (phase == L_EXECUTE) { if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)) != NO_BOOK) { return; } else if (A68G_STANDENV_PROC (TAX (p))) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); get_stack (p, out, idf, inline_mode (MOID (p))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p)); } } else if (phase == L_YIELD) { if (A68G_STANDENV_PROC (TAX (p))) { int k; for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) { undent (out, CODE (&constants[k])); return; } } } else { char idf[NAME_SIZE]; BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)); if (entry != NO_BOOK) { (void) make_name (idf, NSYMBOL (p), "", NUMBER (entry)); } else { (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); } if (primitive_mode (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", idf)); } else if (MOID (p) == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", idf)); } else if (LONG_MODE (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", idf)); } else if (basic_mode (MOID (p))) { undent (out, idf); } } } } /** @brief Code indexer. @param p Starting node. @param out Object file. @param phase Phase of code generation. @param k Counter. @param tup Tuple pointer. **/ static void inline_indexer (NODE_T * p, FILE_T out, int phase, int * k, char * tup) { if (p == NO_NODE) { return; } else if (IS (p, UNIT)) { if (phase != L_YIELD) { inline_unit (p, out, phase); } else { if ((*k) == 0) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(SPAN (&%s[%d]) * (", tup, (*k))); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, " + (SPAN (&%s[%d]) * (", tup, (*k))); } inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ") - SHIFT (&%s[%d]))", tup, (*k))); } (*k) ++; } else { inline_indexer (SUB (p), out, phase, k, tup); inline_indexer (NEXT (p), out, phase, k, tup); } } /** @brief Code dereferencing of slice. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_dereference_slice (NODE_T * p, FILE_T out, int phase) { NODE_T * prim = SUB (p); NODE_T * indx = NEXT (prim); MOID_T * row_mode = DEFLEX (MOID (prim)); MOID_T * mode = SUB_SUB (row_mode); char * symbol = NSYMBOL (SUB (prim)); char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE]; int k; if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, symbol); if (entry == NO_BOOK) { (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); (void) add_declaration (&root_idf, "A68_REF", 1, idf); (void) add_declaration (&root_idf, "A68_REF", 0, elm); (void) add_declaration (&root_idf, "A68_ARRAY", 1, arr); (void) add_declaration (&root_idf, "A68_TUPLE", 1, tup); (void) add_declaration (&root_idf, inline_mode (mode), 1, drf); sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); (void) add_declaration (&root_idf, "A68_REF", 0, elm); (void) add_declaration (&root_idf, inline_mode (mode), 1, drf); } k = 0; inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); NODE_T * pidf = locate (prim, IDENTIFIER); if (entry == NO_BOOK) { (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); get_stack (pidf, out, idf, "A68_REF"); if (IS (row_mode, REF_SYMBOL) && IS (SUB (row_mode), ROW_SYMBOL)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); } else { ABEND (A68_TRUE, "strange mode in dereference slice (execute)", NO_TEXT); } sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (arr, ARR, "", NUMBER (entry)); (void) make_name (tup, TUP, "", NUMBER (entry)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); } else { return; } indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm)); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) { (void) make_name (drf, DRF, "", NUMBER (entry)); } else { (void) make_name (drf, DRF, "", NUMBER (prim)); } if (primitive_mode (mode)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", drf)); } else if (mode == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf)); } else if (LONG_MODE (mode)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", drf)); } else if (basic_mode (mode)) { undent (out, drf); } else { ABEND (A68_TRUE, "strange mode in dereference slice (yield)", NO_TEXT); } } } /** @brief Code slice REF [] MODE -> REF MODE. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_slice_ref_to_ref (NODE_T * p, FILE_T out, int phase) { NODE_T * prim = SUB (p); NODE_T * indx = NEXT (prim); MOID_T * mode = SUB_MOID (p); MOID_T * row_mode = DEFLEX (MOID (prim)); char * symbol = NSYMBOL (SUB (prim)); char idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE], drf[NAME_SIZE]; int k; if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, symbol); if (entry == NO_BOOK) { (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); /*indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF * %s, %s; %s * %s; A68_ARRAY * %s; A68_TUPLE * %s;\n", idf, elm, inline_mode (mode), drf, arr, tup));*/ (void) add_declaration (&root_idf, "A68_REF", 1, idf); (void) add_declaration (&root_idf, "A68_REF", 0, elm); (void) add_declaration (&root_idf, "A68_ARRAY", 1, arr); (void) add_declaration (&root_idf, "A68_TUPLE", 1, tup); (void) add_declaration (&root_idf, inline_mode (mode), 1, drf); sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); /*indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF %s; %s * %s;\n", elm, inline_mode (mode), drf));*/ (void) add_declaration (&root_idf, "A68_REF", 0, elm); (void) add_declaration (&root_idf, inline_mode (mode), 1, drf); } k = 0; inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); if (entry == NO_BOOK) { NODE_T * pidf = locate (prim, IDENTIFIER); (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); get_stack (pidf, out, idf, "A68_REF"); if (IS (row_mode, REF_SYMBOL) && IS (SUB (row_mode), ROW_SYMBOL)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); } else { ABEND (A68_TRUE, "strange mode in slice (execute)", NO_TEXT); } sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (arr, ARR, "", NUMBER (entry)); (void) make_name (tup, TUP, "", NUMBER (entry)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); } else { return; } indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm)); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) { (void) make_name (elm, ELM, "", NUMBER (entry)); } else { (void) make_name (elm, ELM, "", NUMBER (prim)); } undentf (out, snprintf (line, SNPRINTF_SIZE, "(&%s)", elm)); } } /** @brief Code slice [] MODE -> MODE. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_slice (NODE_T * p, FILE_T out, int phase) { NODE_T * prim = SUB (p); NODE_T * indx = NEXT (prim); MOID_T * mode = MOID (p); MOID_T * row_mode = DEFLEX (MOID (prim)); char * symbol = NSYMBOL (SUB (prim)); char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE]; int k; if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, symbol); if (entry == NO_BOOK) { (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF * %s, %s; %s * %s; A68_ARRAY * %s; A68_TUPLE * %s;\n", idf, elm, inline_mode (mode), drf, arr, tup)); sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF %s; %s * %s;\n", elm, inline_mode (mode), drf)); } k = 0; inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); if (entry == NO_BOOK) { NODE_T * pidf = locate (prim, IDENTIFIER); (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); get_stack (pidf, out, idf, "A68_REF"); if (IS (row_mode, REF_SYMBOL)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, (A68_ROW *) %s);\n", arr, tup, idf)); } sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim)); } else if (same_tree (indx, (NODE_T *) (INFO (entry))) == A68_FALSE) { (void) make_name (arr, ARR, "", NUMBER (entry)); (void) make_name (tup, TUP, "", NUMBER (entry)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); } else { return; } indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm)); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, symbol); if (entry != NO_BOOK && same_tree (indx, (NODE_T *) (INFO (entry))) == A68_TRUE) { (void) make_name (drf, DRF, "", NUMBER (entry)); } else { (void) make_name (drf, DRF, "", NUMBER (prim)); } if (primitive_mode (mode)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", drf)); } else if (mode == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", drf)); } else if (LONG_MODE (mode)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", drf)); } else if (basic_mode (mode)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", drf)); } else { ABEND (A68_TRUE, "strange mode in slice (yield)", NO_TEXT); } } } /** @brief Code monadic formula. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_monadic_formula (NODE_T * p, FILE_T out, int phase) { NODE_T *op = SUB (p); NODE_T * rhs = NEXT (op); if (IS (p, MONADIC_FORMULA) && MOID (p) == MODE (COMPLEX)) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MODE (COMPLEX)), 0, acc); inline_unit (rhs, out, L_DECLARE); } else if (phase == L_EXECUTE) { int k; inline_unit (rhs, out, L_EXECUTE); for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (%s, ", CODE (&monadics[k]), acc)); inline_unit (rhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); } } } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } } else if (IS (p, MONADIC_FORMULA) && LONG_MODE (MOID (rhs))) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc); inline_unit (rhs, out, L_DECLARE); } else if (phase == L_EXECUTE) { int k; inline_unit (rhs, out, L_EXECUTE); for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) { if (LONG_MODE (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), %s, ", CODE (&monadics[k]), NUMBER (op), acc)); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), & %s, ", CODE (&monadics[k]), NUMBER (op), acc)); } inline_unit (rhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } } } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } } else if (IS (p, MONADIC_FORMULA) && basic_mode (MOID (p))) { if (phase != L_YIELD) { inline_unit (rhs, out, phase); } else { int k; for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) { if (IS_ALNUM ((CODE (&monadics[k]))[0])) { undent (out, CODE (&monadics[k])); undent (out, "("); inline_unit (rhs, out, L_YIELD); undent (out, ")"); } else { undent (out, CODE (&monadics[k])); undent (out, "("); inline_unit (rhs, out, L_YIELD); undent (out, ")"); } } } } } } /** @brief Code dyadic formula. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_formula (NODE_T * p, FILE_T out, int phase) { NODE_T * lhs = SUB (p), *rhs; NODE_T * op = NEXT (lhs); if (IS (p, FORMULA) && op == NO_NODE) { inline_monadic_formula (lhs, out, phase); return; } rhs = NEXT (op); if (IS (p, FORMULA) && MOID (p) == MODE (COMPLEX)) { if (op == NO_NODE) { inline_monadic_formula (lhs, out, phase); } else if (phase == L_DECLARE) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc); inline_unit (lhs, out, L_DECLARE); inline_unit (rhs, out, L_DECLARE); } else if (phase == L_EXECUTE) { char acc[NAME_SIZE]; int k; (void) make_name (acc, TMP, "", NUMBER (p)); inline_unit (lhs, out, L_EXECUTE); inline_unit (rhs, out, L_EXECUTE); for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) { if (MOID (p) == MODE (COMPLEX)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (%s, ", CODE (&dyadics[k]), acc)); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (& %s, ", CODE (&dyadics[k]), acc)); } inline_unit (lhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", ")); inline_unit (rhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); } } } else if (phase == L_YIELD) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (MOID (p) == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (& %s)", acc)); } } } else if (IS (p, FORMULA) && LONG_MODE (MOID (lhs)) && LONG_MODE (MOID (rhs))) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc); inline_unit (lhs, out, L_DECLARE); inline_unit (rhs, out, L_DECLARE); } else if (phase == L_EXECUTE) { int k; inline_unit (lhs, out, L_EXECUTE); inline_unit (rhs, out, L_EXECUTE); for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) { if (LONG_MODE (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), %s, ", CODE (&dyadics[k]), NUMBER (op), acc)); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), & %s, ", CODE (&dyadics[k]), NUMBER (op), acc)); } inline_unit (lhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", ")); inline_unit (rhs, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } } } else if (phase == L_YIELD) { if (LONG_MODE (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (& %s)", acc)); } } } else if (IS (p, FORMULA) && basic_mode (MOID (p))) { if (phase != L_YIELD) { inline_unit (lhs, out, phase); inline_unit (rhs, out, phase); } else { int k; for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) { if (IS_ALNUM ((CODE (&dyadics[k]))[0])) { undent (out, CODE (&dyadics[k])); undent (out, "("); inline_unit (lhs, out, L_YIELD); undent (out, ", "); inline_unit (rhs, out, L_YIELD); undent (out, ")"); } else { undent (out, "("); inline_unit (lhs, out, L_YIELD); undent (out, " "); undent (out, CODE (&dyadics[k])); undent (out, " "); inline_unit (rhs, out, L_YIELD); undent (out, ")"); } } } } } } /** @brief Code argument. @param p Starting node. @param out Output file descriptor. @param phase Phase of code generation. @return See brief description. **/ static void inline_single_argument (NODE_T * p, FILE_T out, int phase) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, ARGUMENT_LIST) || IS (p, ARGUMENT)) { inline_single_argument (SUB (p), out, phase); } else if (IS (p, GENERIC_ARGUMENT_LIST) || IS (p, GENERIC_ARGUMENT)) { inline_single_argument (SUB (p), out, phase); } else if (IS (p, UNIT)) { inline_unit (p, out, phase); } } } /** @brief Code call. @param p Starting node. @param out Output file descriptor. @param phase Phase of code generation. @return See brief description. **/ static void inline_call (NODE_T * p, FILE_T out, int phase) { NODE_T * prim = SUB (p); NODE_T * args = NEXT (prim); NODE_T * idf = locate (prim, IDENTIFIER); if (MOID (p) == MODE (COMPLEX)) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MODE (COMPLEX)), 0, acc); inline_single_argument (args, out, L_DECLARE); } else if (phase == L_EXECUTE) { int k; inline_single_argument (args, out, L_EXECUTE); for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (%s, ", CODE (&functions[k]), acc)); inline_single_argument (args, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); } } } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } } else if (LONG_MODE (MOID (p))) { char acc[NAME_SIZE]; (void) make_name (acc, TMP, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MOID (p)), 0, acc); inline_single_argument (args, out, L_DECLARE); } else if (phase == L_EXECUTE) { int k; inline_single_argument (args, out, L_EXECUTE); for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s (_N_ (%d), %s, ", CODE (&functions[k]), NUMBER (idf), acc)); inline_single_argument (args, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } } } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", acc)); } } else if (basic_mode (MOID (p))) { if (phase != L_YIELD) { inline_single_argument (args, out, phase); } else { int k; for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k ++) { if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) { undent (out, CODE (&functions[k])); undent (out, " ("); inline_single_argument (args, out, L_YIELD); undent (out, ")"); } } } } } /** @brief Code collateral units. @param out Output file descriptor. @param p Starting node. @param phase Phase of compilation. **/ static void inline_collateral_units (NODE_T * p, FILE_T out, int phase) { if (p == NO_NODE) { return; } else if (IS (p, UNIT)) { if (phase == L_DECLARE) { inline_unit (SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (p), out, L_EXECUTE); } else if (phase == L_YIELD) { indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, ")); inline_unit (SUB (p), out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p)))); } } else { inline_collateral_units (SUB (p), out, phase); inline_collateral_units (NEXT (p), out, phase); } } /** @brief Code collateral units. @param out Output file descriptor. @param p Starting node. @param phase Compilation phase. **/ static void inline_collateral (NODE_T * p, FILE_T out, int phase) { char dsp[NAME_SIZE]; (void) make_name (dsp, DSP, "", NUMBER (p)); if (p == NO_NODE) { return; } else if (phase == L_DECLARE) { if (MOID (p) == MODE (COMPLEX)) { (void) add_declaration (&root_idf, inline_mode (MODE (REAL)), 1, dsp); } else { (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, dsp); } inline_collateral_units (NEXT_SUB (p), out, L_DECLARE); } else if (phase == L_EXECUTE) { if (MOID (p) == MODE (COMPLEX)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (MODE (REAL)))); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) STACK_TOP;\n", dsp, inline_mode (MOID (p)))); } inline_collateral_units (NEXT_SUB (p), out, L_EXECUTE); inline_collateral_units (NEXT_SUB (p), out, L_YIELD); } else if (phase == L_YIELD) { undentf (out, snprintf (line, SNPRINTF_SIZE, "%s", dsp)); } } /** @brief Code basic closed clause. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_closed (NODE_T * p, FILE_T out, int phase) { if (p == NO_NODE) { return; } else if (phase != L_YIELD) { inline_unit (SUB (NEXT_SUB (p)), out, phase); } else { undent (out, "("); inline_unit (SUB (NEXT_SUB (p)), out, L_YIELD); undent (out, ")"); } } /** @brief Code basic closed clause. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_conditional (NODE_T * p, FILE_T out, int phase) { NODE_T * if_part = NO_NODE, * then_part = NO_NODE, * else_part = NO_NODE; p = SUB (p); if (IS (p, IF_PART) || IS (p, OPEN_PART)) { if_part = p; } else { ABEND (A68_TRUE, "if-part expected", NO_TEXT); } FORWARD (p); if (IS (p, THEN_PART) || IS (p, CHOICE)) { then_part = p; } else { ABEND (A68_TRUE, "then-part expected", NO_TEXT); } FORWARD (p); if (IS (p, ELSE_PART) || IS (p, CHOICE)) { else_part = p; } else { else_part = NO_NODE; } if (phase == L_DECLARE) { inline_unit (SUB (NEXT_SUB (if_part)), out, L_DECLARE); inline_unit (SUB (NEXT_SUB (then_part)), out, L_DECLARE); inline_unit (SUB (NEXT_SUB (else_part)), out, L_DECLARE); } else if (phase == L_EXECUTE) { inline_unit (SUB (NEXT_SUB (if_part)), out, L_EXECUTE); inline_unit (SUB (NEXT_SUB (then_part)), out, L_EXECUTE); inline_unit (SUB (NEXT_SUB (else_part)), out, L_EXECUTE); } else if (phase == L_YIELD) { undent (out, "("); inline_unit (SUB (NEXT_SUB (if_part)), out, L_YIELD); undent (out, " ? "); inline_unit (SUB (NEXT_SUB (then_part)), out, L_YIELD); undent (out, " : "); if (else_part != NO_NODE) { inline_unit (SUB (NEXT_SUB (else_part)), out, L_YIELD); } else { /* This is not an ideal solution although RR permits it; an omitted else-part means SKIP: yield some value of the mode required. */ inline_unit (SUB (NEXT_SUB (then_part)), out, L_YIELD); } undent (out, ")"); } } /** @brief Code dereferencing of selection. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_dereference_selection (NODE_T * p, FILE_T out, int phase) { NODE_T * field = SUB (p); NODE_T * sec = NEXT (field); NODE_T * idf = locate (sec, IDENTIFIER); char ref[NAME_SIZE], sel[NAME_SIZE]; char * field_idf = NSYMBOL (SUB (field)); if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); (void) add_declaration (&root_idf, "A68_REF", 1, ref); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field)); } if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) { (void) make_name (sel, SEL, "", NUMBER (field)); (void) add_declaration (&root_idf, inline_mode (SUB_MOID (field)), 1, sel); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (sec, out, L_DECLARE); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); get_stack (idf, out, ref, "A68_REF"); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), NULL, NUMBER (field)); } if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); (void) make_name (sel, SEL, "", NUMBER (field)); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[%d]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } else if (field_idf != (char *) (INFO (entry))) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry)); (void) make_name (sel, SEL, "", NUMBER (field)); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[%d]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (sec, out, L_EXECUTE); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)); if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) { (void) make_name (sel, SEL, "", NUMBER (entry)); } else { (void) make_name (sel, SEL, "", NUMBER (field)); } if (primitive_mode (SUB_MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", sel)); } else if (SUB_MOID (p) == MODE (COMPLEX)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(A68_REAL *) (%s)", sel)); } else if (LONG_MODE (SUB_MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(MP_T *) (%s)", sel)); } else if (basic_mode (SUB_MOID (p))) { undent (out, sel); } else { ABEND (A68_TRUE, "strange mode in dereference selection (yield)", NO_TEXT); } } } /** @brief Code selection. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_selection (NODE_T * p, FILE_T out, int phase) { NODE_T * field = SUB (p); NODE_T * sec = NEXT (field); NODE_T * idf = locate (sec, IDENTIFIER); char ref[NAME_SIZE], sel[NAME_SIZE]; char * field_idf = NSYMBOL (SUB (field)); if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); (void) add_declaration (&root_idf, "A68_STRUCT", 0, ref); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field)); } if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) { (void) make_name (sel, SEL, "", NUMBER (field)); (void) add_declaration (&root_idf, inline_mode (MOID (field)), 1, sel); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (sec, out, L_DECLARE); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); get_stack (idf, out, ref, "BYTE_T"); (void) make_name (sel, SEL, "", NUMBER (field)); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (%s[%d]);\n", sel, inline_mode (MOID (field)), ref, OFFSET_OFF (field))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } else if (field_idf != (char *) (INFO (entry))) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry)); (void) make_name (sel, SEL, "", NUMBER (field)); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (%s[%d]);\n", sel, inline_mode (MOID (field)), ref, OFFSET_OFF (field))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (sec, out, L_EXECUTE); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)); if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) { (void) make_name (sel, SEL, "", NUMBER (entry)); } else { (void) make_name (sel, SEL, "", NUMBER (field)); } if (primitive_mode (MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s)", sel)); } else { ABEND (A68_TRUE, "strange mode in selection (yield)", NO_TEXT); } } } /** @brief Code selection. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_selection_ref_to_ref (NODE_T * p, FILE_T out, int phase) { NODE_T * field = SUB (p); NODE_T * sec = NEXT (field); NODE_T * idf = locate (sec, IDENTIFIER); char ref[NAME_SIZE], sel[NAME_SIZE]; char * field_idf = NSYMBOL (SUB (field)); if (phase == L_DECLARE) { BOOK_T * entry = signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); (void) add_declaration (&root_idf, "A68_REF", 1, ref); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), NULL, NUMBER (field)); } if (entry == NO_BOOK || field_idf != (char *) (INFO (entry))) { (void) make_name (sel, SEL, "", NUMBER (field)); (void) add_declaration (&root_idf, "A68_REF", 0, sel); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (sec, out, L_DECLARE); } else if (phase == L_EXECUTE) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf)); if (entry == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); get_stack (idf, out, ref, "A68_REF"); (void) make_name (sel, SEL, "", NUMBER (field)); sign_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } else if (field_idf != (char *) (INFO (entry))) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (entry)); (void) make_name (sel, SEL, "", NUMBER (field)); sign_in (BOOK_DECL, L_EXECUTE_2, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = *%s;\n", sel, ref)); indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (&%s) += %d;\n", sel, OFFSET_OFF (field))); inline_unit (sec, out, L_EXECUTE); } else if (phase == L_YIELD) { BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)); if (entry != NO_BOOK && (char *) (INFO (entry)) == field_idf) { (void) make_name (sel, SEL, "", NUMBER (entry)); } else { (void) make_name (sel, SEL, "", NUMBER (field)); } if (primitive_mode (SUB_MOID (p))) { undentf (out, snprintf (line, SNPRINTF_SIZE, "(&%s)", sel)); } else { ABEND (A68_TRUE, "strange mode in selection (yield)", NO_TEXT); } } } /** @brief Code identifier. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_ref_identifier (NODE_T * p, FILE_T out, int phase) { /* No folding - consider identifier */ if (phase == L_DECLARE) { if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (p)) != NO_BOOK) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); (void) add_declaration (&root_idf, "A68_REF", 1, idf); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (p), NULL, NUMBER (p)); } } else if (phase == L_EXECUTE) { if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)) != NO_BOOK) { return; } else { char idf[NAME_SIZE]; (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); get_stack (p, out, idf, "A68_REF"); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), NULL, NUMBER (p)); } } else if (phase == L_YIELD) { char idf[NAME_SIZE]; BOOK_T * entry = signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p)); if (entry != NO_BOOK) { (void) make_name (idf, NSYMBOL (p), "", NUMBER (entry)); } else { (void) make_name (idf, NSYMBOL (p), "", NUMBER (p)); } undent (out, idf); } } /** @brief Code identity-relation. @param p Starting node. @param out Output file descriptor. @param phase Phase of code generation. **/ static void inline_identity_relation (NODE_T * p, FILE_T out, int phase) { #define GOOD(p) (locate (p, IDENTIFIER) != NO_NODE && IS (MOID (locate ((p), IDENTIFIER)), REF_SYMBOL)) NODE_T * lhs = SUB (p); NODE_T * op = NEXT (lhs); NODE_T * rhs = NEXT (op); if (GOOD (lhs) && GOOD (rhs)) { if (phase == L_DECLARE) { NODE_T * lidf = locate (lhs, IDENTIFIER); NODE_T * ridf = locate (rhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_DECLARE); inline_ref_identifier (ridf, out, L_DECLARE); } else if (phase == L_EXECUTE) { NODE_T * lidf = locate (lhs, IDENTIFIER); NODE_T * ridf = locate (rhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_EXECUTE); inline_ref_identifier (ridf, out, L_EXECUTE); } else if (phase == L_YIELD) { NODE_T * lidf = locate (lhs, IDENTIFIER); NODE_T * ridf = locate (rhs, IDENTIFIER); if (IS (op, IS_SYMBOL)) { undentf (out, snprintf (line, SNPRINTF_SIZE, "ADDRESS (")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ") == ADDRESS (")); inline_ref_identifier (ridf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ")")); } else { undentf (out, snprintf (line, SNPRINTF_SIZE, "ADDRESS (")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ") != ADDRESS (")); inline_ref_identifier (ridf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ")")); } } } else if (GOOD (lhs) && locate (rhs, NIHIL) != NO_NODE) { if (phase == L_DECLARE) { NODE_T * lidf = locate (lhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_DECLARE); } else if (phase == L_EXECUTE) { NODE_T * lidf = locate (lhs, IDENTIFIER); inline_ref_identifier (lidf, out, L_EXECUTE); } else if (phase == L_YIELD) { NODE_T * lidf = locate (lhs, IDENTIFIER); if (IS (op, IS_SYMBOL)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "IS_NIL (*")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ")")); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "!IS_NIL (*")); inline_ref_identifier (lidf, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ")")); } } } #undef GOOD } /** @brief Code unit. @param p Starting node. @param out Object file. @param phase Phase of code generation. **/ static void inline_unit (NODE_T * p, FILE_T out, int phase) { if (p == NO_NODE) { return; } else if (constant_unit (p) && locate (p, DENOTATION) == NO_NODE) { constant_folder (p, out, phase); } else if (IS (p, UNIT)) { inline_unit (SUB (p), out, phase); } else if (IS (p, TERTIARY)) { inline_unit (SUB (p), out, phase); } else if (IS (p, SECONDARY)) { inline_unit (SUB (p), out, phase); } else if (IS (p, PRIMARY)) { inline_unit (SUB (p), out, phase); } else if (IS (p, ENCLOSED_CLAUSE)) { inline_unit (SUB (p), out, phase); } else if (IS (p, CLOSED_CLAUSE)) { inline_closed (p, out, phase); } else if (IS (p, COLLATERAL_CLAUSE)) { inline_collateral (p, out, phase); } else if (IS (p, CONDITIONAL_CLAUSE)) { inline_conditional (p, out, phase); } else if (IS (p, WIDENING)) { inline_widening (p, out, phase); } else if (IS (p, IDENTIFIER)) { inline_identifier (p, out, phase); } else if (IS (p, DEREFERENCING) && locate (SUB (p), IDENTIFIER) != NO_NODE) { inline_dereference_identifier (p, out, phase); } else if (IS (p, SLICE)) { NODE_T * prim = SUB (p); MOID_T * mode = MOID (p); MOID_T * row_mode = DEFLEX (MOID (prim)); if (mode == SUB (row_mode)) { inline_slice (p, out, phase); } else if (IS (mode, REF_SYMBOL) && IS (row_mode, REF_SYMBOL) && SUB (mode) == SUB_SUB (row_mode)) { inline_slice_ref_to_ref (p, out, phase); } else { ABEND (A68_TRUE, "strange mode for slice", NO_TEXT); } } else if (IS (p, DEREFERENCING) && locate (SUB (p), SLICE) != NO_NODE) { inline_dereference_slice (SUB (p), out, phase); } else if (IS (p, DEREFERENCING) && locate (SUB (p), SELECTION) != NO_NODE) { inline_dereference_selection (SUB (p), out, phase); } else if (IS (p, SELECTION)) { NODE_T * sec = NEXT_SUB (p); MOID_T * mode = MOID (p); MOID_T * struct_mode = MOID (sec); if (IS (struct_mode, REF_SYMBOL) && IS (mode, REF_SYMBOL)) { inline_selection_ref_to_ref (p, out, phase); } else if (IS (struct_mode, STRUCT_SYMBOL) && primitive_mode (mode)) { inline_selection (p, out, phase); } else { ABEND (A68_TRUE, "strange mode for selection", NO_TEXT); } } else if (IS (p, DENOTATION)) { inline_denotation (p, out, phase); } else if (IS (p, MONADIC_FORMULA)) { inline_monadic_formula (p, out, phase); } else if (IS (p, FORMULA)) { inline_formula (p, out, phase); } else if (IS (p, CALL)) { inline_call (p, out, phase); } else if (IS (p, CAST)) { inline_unit (NEXT_SUB (p), out, phase); } else if (IS (p, IDENTITY_RELATION)) { inline_identity_relation (p, out, phase); } } /*********************************/ /* COMPILATION OF COMPLETE UNITS */ /*********************************/ /** @brief Compile code clause. @param out Output file descriptor. @param p Starting node. @return Function name or NO_NODE. **/ static void embed_code_clause (NODE_T * p, FILE_T out) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, ROW_CHAR_DENOTATION)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s\n", NSYMBOL (p))); } embed_code_clause (SUB (p), out); } } /** @brief Compile push. @param p Starting node. @param out Output file descriptor. **/ static void compile_push (NODE_T * p, FILE_T out) { if (primitive_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p)))); } else if (basic_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE ((void *) STACK_TOP, (void *) ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p)))); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer += %d;\n", SIZE (MOID (p)))); } else { ABEND (A68_TRUE, "cannot push", moid_to_string (MOID (p), 80, NO_NODE)); } } /** @brief Compile assign (C source to C destination). @param p Starting node. @param out Output file descriptor. @param dst String denoting destination. **/ static void compile_assign (NODE_T * p, FILE_T out, char * dst) { if (primitive_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "_S_ (%s) = INIT_MASK;\n", dst)); indentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s) = ", dst)); inline_unit (p, out, L_YIELD); undent (out, ";\n"); } else if (LONG_MODE (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE_MP ((void *) %s, (void *) ", dst)); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", LONG_MP_DIGITS)); } else if (basic_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", dst)); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p)))); } else { ABEND (A68_TRUE, "cannot assign", moid_to_string (MOID (p), 80, NO_NODE)); } } /** @brief Compile denotation. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_denotation (NODE_T * p, FILE_T out, int compose_fun) { if (denotation_mode (MOID (p))) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_denotation", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); if (primitive_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %s);\n", inline_mode (MOID (p)))); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH (p, ")); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p)))); } (void) make_name (fn, "_denotation", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile cast. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_cast (NODE_T * p, FILE_T out, int compose_fun) { if (basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_cast", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (NEXT_SUB (p), out, L_DECLARE); print_declarations (out, root_idf); inline_unit (NEXT_SUB (p), out, L_EXECUTE); compile_push (NEXT_SUB (p), out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_cast", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile identifier. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_identifier (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_identifier", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); (void) make_name (fn, "_identifier", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile dereference identifier. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_dereference_identifier (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_deref_identifier", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); (void) make_name (fn, "_deref_identifier", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile slice. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_slice (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_slice", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_slice", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile slice. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_dereference_slice (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_deref_slice", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_deref_slice", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile selection. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_selection (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_selection", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_selection", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile selection. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_dereference_selection (NODE_T * p, FILE_T out, int compose_fun) { if (basic_mode (MOID (p)) && basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_deref_selection", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_deref_selection", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile formula. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_formula (NODE_T * p, FILE_T out, int compose_fun) { if (basic_unit (p)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_formula", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_formula", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile voiding formula. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_voiding_formula (NODE_T * p, FILE_T out, int compose_fun) { if (basic_unit (p)) { static char fn[NAME_SIZE]; char pop[NAME_SIZE]; (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_void_formula", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; (void) add_declaration (&root_idf, "ADDR_T", 0, pop); inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); inline_unit (p, out, L_EXECUTE); indent (out, "(void) ("); inline_unit (p, out, L_YIELD); undent (out, ");\n"); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_formula", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile uniting. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_uniting (NODE_T * p, FILE_T out, int compose_fun) { MOID_T *u = MOID (p), *v = MOID (SUB (p)); NODE_T *q = SUB (p); if (basic_unit (q) && ATTRIBUTE (v) != UNION_SYMBOL && primitive_mode (v)) { static char fn[NAME_SIZE]; char pop0[NAME_SIZE]; (void) make_name (pop0, PUP, "0", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_unite", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; (void) add_declaration (&root_idf, "ADDR_T", 0, pop0); inline_unit (q, out, L_DECLARE); print_declarations (out, root_idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop0)); indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_UNION (_N_ (%d), %s);\n", NUMBER (p), internal_mode (v))); inline_unit (q, out, L_EXECUTE); compile_push (q, out); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s + %d;\n", pop0, SIZE (u))); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile inline arguments. @param p Starting node. @param out Output file descriptor. @param phase Compilation phase. @param size Position in frame stack. **/ static void inline_arguments (NODE_T * p, FILE_T out, int phase, int * size) { if (p == NO_NODE) { return; } else if (IS (p, UNIT) && phase == L_PUSH) { indentf (out, snprintf (line, SNPRINTF_SIZE, "EXECUTE_UNIT_TRACE (_N_ (%d));\n", NUMBER (p))); inline_arguments (NEXT (p), out, L_PUSH, size); } else if (IS (p, UNIT)) { char arg[NAME_SIZE]; (void) make_name (arg, ARG, "", NUMBER (p)); if (phase == L_DECLARE) { (void) add_declaration (&root_idf, inline_mode (MOID (p)), 1, arg); inline_unit (p, out, L_DECLARE); } else if (phase == L_INITIALISE) { inline_unit (p, out, L_EXECUTE); } else if (phase == L_EXECUTE) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) FRAME_OBJECT (%d);\n", arg, inline_mode (MOID (p)), *size)); (*size) += SIZE (MOID (p)); } else if (phase == L_YIELD && primitive_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "_S_ (%s) = INIT_MASK;\n", arg)); indentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s) = ", arg)); inline_unit (p, out, L_YIELD); undent (out, ";\n"); } else if (phase == L_YIELD && basic_mode (MOID (p))) { indentf (out, snprintf (line, SNPRINTF_SIZE, "MOVE ((void *) %s, (void *) ", arg)); inline_unit (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", %d);\n", SIZE (MOID (p)))); } } else { inline_arguments (SUB (p), out, phase, size); inline_arguments (NEXT (p), out, phase, size); } } /** @brief Compile deproceduring. @param out Output file descriptor. @param p Starting node. @param compose_fun Whether to compose a function. @return Function name or NO_NODE. **/ static char * compile_deproceduring (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * idf = locate (SUB (p), IDENTIFIER); if (idf == NO_NODE) { return (NO_TEXT); } else if (! (SUB_MOID (idf) == MODE (VOID) || basic_mode (SUB_MOID (idf)))) { return (NO_TEXT); } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) { return (NO_TEXT); } else { static char fn[NAME_SIZE]; char fun[NAME_SIZE]; (void) make_name (fun, FUN, "", NUMBER (idf)); comment_source (p, out); (void) make_name (fn, "_deproc", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Declare */ root_idf = NO_DEC; (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun); (void) add_declaration (&root_idf, "NODE_T", 1, "body"); print_declarations (out, root_idf); /* Initialise */ if (compose_fun != A68_MAKE_NOTHING) { } get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n")); /* Execute procedure */ indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT (body));\n"); indent (out, "if (frame_pointer == finish_frame_pointer) {\n"); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); indentation --; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); if (GC_MODE (SUB_MOID (idf))) { } if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_deproc", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } } /** @brief Compile deproceduring. @param out Output file descriptor. @param p Starting node. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_voiding_deproceduring (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * idf = locate (SUB_SUB (p), IDENTIFIER); if (idf == NO_NODE) { return (NO_TEXT); } else if (! (SUB_MOID (idf) == MODE (VOID) || basic_mode (SUB_MOID (idf)))) { return (NO_TEXT); } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) { return (NO_TEXT); } else { static char fn[NAME_SIZE]; char fun[NAME_SIZE], pop[NAME_SIZE]; (void) make_name (fun, FUN, "", NUMBER (idf)); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_void_deproc", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Declare */ root_idf = NO_DEC; (void) add_declaration (&root_idf, "ADDR_T", 0, pop); (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun); (void) add_declaration (&root_idf, "NODE_T", 1, "body"); print_declarations (out, root_idf); /* Initialise */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); if (compose_fun != A68_MAKE_NOTHING) { } get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n")); /* Execute procedure */ indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT (body));\n"); indent (out, "if (frame_pointer == finish_frame_pointer) {\n"); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); indentation --; indent (out, "}\n"); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); indent (out, "CLOSE_FRAME;\n"); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_deproc", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } } /** @brief Compile call. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_call (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * proc = SUB (p); NODE_T * args = NEXT (proc); NODE_T * idf = locate (proc, IDENTIFIER); if (idf == NO_NODE) { return (NO_TEXT); } else if (! (SUB_MOID (proc) == MODE (VOID) || basic_mode (SUB_MOID (proc)))) { return (NO_TEXT); } else if (DIM (MOID (proc)) == 0) { return (NO_TEXT); } else if (A68G_STANDENV_PROC (TAX (idf))) { if (basic_call (p)) { static char fn[NAME_SIZE]; char fun[NAME_SIZE]; (void) make_name (fun, FUN, "", NUMBER (proc)); comment_source (p, out); (void) make_name (fn, "_call", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_unit (p, out, L_DECLARE); print_declarations (out, root_idf); inline_unit (p, out, L_EXECUTE); compile_push (p, out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_call", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) { return (NO_TEXT); } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) { return (NO_TEXT); } else if (!basic_argument (args)) { return (NO_TEXT); } else { static char fn[NAME_SIZE]; char fun[NAME_SIZE], pop[NAME_SIZE]; int size; /* Declare */ (void) make_name (fun, FUN, "", NUMBER (proc)); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_call", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Compute arguments */ size = 0; root_idf = NO_DEC; inline_arguments (args, out, L_DECLARE, &size); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun); (void) add_declaration (&root_idf, "NODE_T", 1, "body"); print_declarations (out, root_idf); /* Initialise */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); if (compose_fun != A68_MAKE_NOTHING) { } inline_arguments (args, out, L_INITIALISE, &size); get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n")); size = 0; inline_arguments (args, out, L_EXECUTE, &size); size = 0; inline_arguments (args, out, L_YIELD, &size); /* Execute procedure */ indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n"); indent (out, "if (frame_pointer == finish_frame_pointer) {\n"); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); indentation --; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); if (GC_MODE (SUB_MOID (proc))) { } if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_call", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } } /** @brief Compile call. @param out Output file descriptor. @param p Starting node. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_voiding_call (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * proc = SUB (locate (p, CALL)); NODE_T * args = NEXT (proc); NODE_T * idf = locate (proc, IDENTIFIER); if (idf == NO_NODE) { return (NO_TEXT); } else if (! (SUB_MOID (proc) == MODE (VOID) || basic_mode (SUB_MOID (proc)))) { return (NO_TEXT); } else if (DIM (MOID (proc)) == 0) { return (NO_TEXT); } else if (A68G_STANDENV_PROC (TAX (idf))) { return (NO_TEXT); } else if (!(CODEX (TAX (idf)) & PROC_DECLARATION_MASK)) { return (NO_TEXT); } else if (DIM (PARTIAL_PROC (GINFO (proc))) != 0) { return (NO_TEXT); } else if (!basic_argument (args)) { return (NO_TEXT); } else { static char fn[NAME_SIZE]; char fun[NAME_SIZE], pop[NAME_SIZE]; int size; /* Declare */ (void) make_name (fun, FUN, "", NUMBER (proc)); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_void_call", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Compute arguments */ size = 0; root_idf = NO_DEC; inline_arguments (args, out, L_DECLARE, &size); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); (void) add_declaration (&root_idf, "A68_PROCEDURE", 1, fun); (void) add_declaration (&root_idf, "NODE_T", 1, "body"); print_declarations (out, root_idf); /* Initialise */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); if (compose_fun != A68_MAKE_NOTHING) { } inline_arguments (args, out, L_INITIALISE, &size); get_stack (idf, out, fun, "A68_PROCEDURE"); indentf (out, snprintf (line, SNPRINTF_SIZE, "body = SUB (NODE (&BODY (%s)));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_PROC_FRAME (body, ENVIRON (%s));\n", fun)); indentf (out, snprintf (line, SNPRINTF_SIZE, "INIT_STATIC_FRAME (body);\n")); size = 0; inline_arguments (args, out, L_EXECUTE, &size); size = 0; inline_arguments (args, out, L_YIELD, &size); /* Execute procedure */ indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); indent (out, "EXECUTE_UNIT_TRACE (NEXT_NEXT_NEXT (body));\n"); indent (out, "if (frame_pointer == finish_frame_pointer) {\n"); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE);\n")); indentation --; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_call", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } } /** @brief Compile voiding assignation. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_voiding_assignation_selection (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * dst = SUB (locate (p, ASSIGNATION)); NODE_T * src = NEXT_NEXT (dst); if (BASIC (dst, SELECTION) && basic_unit (src) && basic_mode_non_row (MOID (dst))) { NODE_T * field = SUB (locate (dst, SELECTION)); NODE_T * sec = NEXT (field); NODE_T * idf = locate (sec, IDENTIFIER); char sel[NAME_SIZE], ref[NAME_SIZE], pop[NAME_SIZE]; char * field_idf = NSYMBOL (SUB (field)); static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (pop, PUP, "", NUMBER (p)); (void) make_name (fn, "_void_assign", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Declare */ root_idf = NO_DEC; if (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf)) == NO_BOOK) { (void) make_name (ref, NSYMBOL (idf), "", NUMBER (field)); (void) make_name (sel, SEL, "", NUMBER (field)); indentf (out, snprintf (line, SNPRINTF_SIZE, "A68_REF * %s; /* %s */\n", ref, NSYMBOL (idf))); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s * %s;\n", inline_mode (SUB_MOID (field)), sel)); sign_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } else { int n = NUMBER (signed_in (BOOK_DECL, L_DECLARE, NSYMBOL (idf))); (void) make_name (ref, NSYMBOL (idf), "", n); (void) make_name (sel, SEL, "", n); } inline_unit (src, out, L_DECLARE); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); /* Initialise */ if (signed_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf)) == NO_BOOK) { get_stack (idf, out, ref, "A68_REF"); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) & (ADDRESS (%s)[%d]);\n", sel, inline_mode (SUB_MOID (field)), ref, OFFSET_OFF (field))); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (idf), (void *) field_idf, NUMBER (field)); } inline_unit (src, out, L_EXECUTE); /* Generate */ compile_assign (src, out, sel); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_assign", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile voiding assignation. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_voiding_assignation_slice (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * dst = SUB (locate (p, ASSIGNATION)); NODE_T * src = NEXT_NEXT (dst); NODE_T * slice = locate (SUB (dst), SLICE); NODE_T * prim = SUB (slice); MOID_T * mode = SUB_MOID (dst); MOID_T * row_mode = DEFLEX (MOID (prim)); if (IS (row_mode, REF_SYMBOL) && basic_slice (slice) && basic_unit (src) && basic_mode_non_row (MOID (src))) { NODE_T * indx = NEXT (prim); char * symbol = NSYMBOL (SUB (prim)); char drf[NAME_SIZE], idf[NAME_SIZE], arr[NAME_SIZE], tup[NAME_SIZE], elm[NAME_SIZE], pop[NAME_SIZE]; static char fn[NAME_SIZE]; int k; comment_source (p, out); (void) make_name (pop, PUP, "", NUMBER (p)); (void) make_name (fn, "_void_assign", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } /* Declare */ root_idf = NO_DEC; (void) add_declaration (&root_idf, "ADDR_T", 0, pop); if (signed_in (BOOK_DECL, L_DECLARE, symbol) == NO_BOOK) { (void) make_name (idf, symbol, "", NUMBER (prim)); (void) make_name (arr, ARR, "", NUMBER (prim)); (void) make_name (tup, TUP, "", NUMBER (prim)); (void) make_name (elm, ELM, "", NUMBER (prim)); (void) make_name (drf, DRF, "", NUMBER (prim)); (void) add_declaration (&root_idf, "A68_REF", 1, idf); (void) add_declaration (&root_idf, "A68_REF", 0, elm); (void) add_declaration (&root_idf, "A68_ARRAY", 1, arr); (void) add_declaration (&root_idf, "A68_TUPLE", 1, tup); (void) add_declaration (&root_idf, inline_mode (mode), 1, drf); sign_in (BOOK_DECL, L_DECLARE, symbol, (void *) indx, NUMBER (prim)); } else { int n = NUMBER (signed_in (BOOK_DECL, L_EXECUTE, symbol)); (void) make_name (idf, symbol, "", n); (void) make_name (arr, ARR, "", n); (void) make_name (tup, TUP, "", n); (void) make_name (elm, ELM, "", n); (void) make_name (drf, DRF, "", n); } k = 0; inline_indexer (indx, out, L_DECLARE, &k, NO_TEXT); inline_unit (src, out, L_DECLARE); print_declarations (out, root_idf); /* Initialise */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); if (signed_in (BOOK_DECL, L_EXECUTE, symbol) == NO_BOOK) { NODE_T * pidf = locate (prim, IDENTIFIER); get_stack (pidf, out, idf, "A68_REF"); indentf (out, snprintf (line, SNPRINTF_SIZE, "GET_DESCRIPTOR (%s, %s, DEREF (A68_ROW, %s));\n", arr, tup, idf)); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = ARRAY (%s);\n", elm, arr)); sign_in (BOOK_DECL, L_EXECUTE, NSYMBOL (p), (void *) indx, NUMBER (prim)); } k = 0; inline_indexer (indx, out, L_EXECUTE, &k, NO_TEXT); indentf (out, snprintf (line, SNPRINTF_SIZE, "OFFSET (& %s) += ROW_ELEMENT (%s, ", elm, arr)); k = 0; inline_indexer (indx, out, L_YIELD, &k, tup); undentf (out, snprintf (line, SNPRINTF_SIZE, ");\n")); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, & %s);\n", drf, inline_mode (mode), elm)); inline_unit (src, out, L_EXECUTE); /* Generate */ compile_assign (src, out, drf); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_assign", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile voiding assignation. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_voiding_assignation_identifier (NODE_T * p, FILE_T out, int compose_fun) { NODE_T * dst = SUB (locate (p, ASSIGNATION)); NODE_T * src = NEXT_NEXT (dst); if (BASIC (dst, IDENTIFIER) && basic_unit (src) && basic_mode_non_row (MOID (src))) { static char fn[NAME_SIZE]; char idf[NAME_SIZE], pop[NAME_SIZE]; NODE_T * q = locate (dst, IDENTIFIER); /* Declare */ (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_void_assign", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; if (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q)) == NO_BOOK) { (void) make_name (idf, NSYMBOL (q), "", NUMBER (p)); (void) add_declaration (&root_idf, inline_mode (SUB_MOID (dst)), 1, idf); sign_in (BOOK_DEREF, L_DECLARE, NSYMBOL (q), NULL, NUMBER (p)); } else { (void) make_name (idf, NSYMBOL (q), "", NUMBER (signed_in (BOOK_DEREF, L_DECLARE, NSYMBOL (p)))); } inline_unit (dst, out, L_DECLARE); inline_unit (src, out, L_DECLARE); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); /* Initialise */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); inline_unit (dst, out, L_EXECUTE); if (signed_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q)) == NO_BOOK) { if (BODY (TAX (q)) != NO_TAG) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (%s *) LOCAL_ADDRESS (", idf, inline_mode (SUB_MOID (dst)))); inline_unit (dst, out, L_YIELD); undent (out, ");\n"); sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q), NULL, NUMBER (p)); } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = DEREF (%s, ", idf, inline_mode (SUB_MOID (dst)))); inline_unit (dst, out, L_YIELD); undent (out, ");\n"); sign_in (BOOK_DEREF, L_EXECUTE, NSYMBOL (q), NULL, NUMBER (p)); } } inline_unit (src, out, L_EXECUTE); compile_assign (src, out, idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_void_assign", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile identity-relation. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_identity_relation (NODE_T * p, FILE_T out, int compose_fun) { #define GOOD(p) (locate (p, IDENTIFIER) != NO_NODE && IS (MOID (locate ((p), IDENTIFIER)), REF_SYMBOL)) NODE_T * lhs = SUB (p); NODE_T * op = NEXT (lhs); NODE_T * rhs = NEXT (op); if (GOOD (lhs) && GOOD (rhs)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_identity", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_identity_relation (p, out, L_DECLARE); print_declarations (out, root_idf); inline_identity_relation (p, out, L_EXECUTE); indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, ")); inline_identity_relation (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", A68_BOOL);\n")); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_identity", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else if (GOOD (lhs) && locate (rhs, NIHIL) != NO_NODE) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_identity", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_identity_relation (p, out, L_DECLARE); print_declarations (out, root_idf); inline_identity_relation (p, out, L_EXECUTE); indentf (out, snprintf (line, SNPRINTF_SIZE, "PUSH_PRIMITIVE (p, ")); inline_identity_relation (p, out, L_YIELD); undentf (out, snprintf (line, SNPRINTF_SIZE, ", A68_BOOL);\n")); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_identity", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } #undef GOOD } /** @brief Compile closed clause. @param out Output file descriptor. @param decs Number of declarations. @param pop Value to restore stack pointer to. @param p Starting node. **/ static void compile_declaration_list (NODE_T * p, FILE_T out, int * decs, char * pop) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case MODE_DECLARATION: case PROCEDURE_DECLARATION: case BRIEF_OPERATOR_DECLARATION: case PRIORITY_DECLARATION: { /* No action needed */ (* decs) ++; return; } case OPERATOR_DECLARATION: { indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_operator_dec (_N_ (%d));", NUMBER (SUB (p)))); inline_comment_source (p, out); undent (out, NEWLINE_STRING); (* decs) ++; break; } case IDENTITY_DECLARATION: { indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_identity_dec (_N_ (%d));", NUMBER (SUB (p)))); inline_comment_source (p, out); undent (out, NEWLINE_STRING); (* decs) ++; break; } case VARIABLE_DECLARATION: { char declarer[NAME_SIZE]; (void) make_name (declarer, DEC, "", NUMBER (SUB (p))); indent (out, "{"); inline_comment_source (p, out); undent (out, NEWLINE_STRING); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "NODE_T *%s = NO_NODE;\n", declarer)); indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_variable_dec (_N_ (%d), &%s, stack_pointer);\n", NUMBER (SUB (p)), declarer)); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); indentation --; indent (out, "}\n"); (* decs) ++; break; } case PROCEDURE_VARIABLE_DECLARATION: { indentf (out, snprintf (line, SNPRINTF_SIZE, "genie_proc_variable_dec (_N_ (%d));", NUMBER (SUB (p)))); inline_comment_source (p, out); undent (out, NEWLINE_STRING); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); (* decs) ++; break; } default: { compile_declaration_list (SUB (p), out, decs, pop); break; } } } } /** @brief Compile closed clause. @param p Starting node. @param out Output file descriptor. @param last Last unit generated. @param units Number of units. @param decs Number of declarations. @param pop Value to restore stack pointer to. @param compose_fun Whether to compose a function. **/ static void compile_serial_clause (NODE_T * p, FILE_T out, NODE_T ** last, int * units, int * decs, char * pop, int compose_fun) { for (; p != NO_NODE; FORWARD (p)) { if (compose_fun == A68_MAKE_OTHERS) { if (IS (p, UNIT)) { (* units) ++; } if (IS (p, DECLARATION_LIST)) { (* decs) ++; } if (IS (p, UNIT) || IS (p, DECLARATION_LIST)) { if (compile_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) { if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) { compile_units (SUB_SUB (p), out); } else { compile_units (SUB (p), out); } } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) { COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p))); COMPILE_NAME (GINFO (p)) = COMPILE_NAME (GINFO (SUB (p))); } return; } else { compile_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun); } } else switch (ATTRIBUTE (p)) { case UNIT: { (* last) = p; CODE_EXECUTE (p); inline_comment_source (p, out); undent (out, NEWLINE_STRING); (* units) ++; return; } case SEMI_SYMBOL: { if (IS (* last, UNIT) && MOID (* last) == MODE (VOID)) { break; } else if (IS (* last, DECLARATION_LIST)) { break; } else { indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); } break; } case DECLARATION_LIST: { (* last) = p; compile_declaration_list (SUB (p), out, decs, pop); break; } default: { compile_serial_clause (SUB (p), out, last, units, decs, pop, compose_fun); break; } } } } /** @brief Embed serial clause. @param p Starting node. @param out Output file descriptor. @param pop Value to restore stack pointer to. */ static void embed_serial_clause (NODE_T * p, FILE_T out, char * pop) { NODE_T * last = NO_NODE; int units = 0, decs = 0; indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_N_ (%d));\n", NUMBER (p))); init_static_frame (out, p); compile_serial_clause (p, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION); indent (out, "CLOSE_FRAME;\n"); } /** @brief Compile code clause. @param out Output file descriptor. @param p Starting node. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_code_clause (NODE_T * p, FILE_T out, int compose_fun) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_code", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } embed_code_clause (SUB (p), out); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_code", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } /** @brief Compile closed clause. @param out Output file descriptor. @param p Starting node. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_closed_clause (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *sc = NEXT_SUB (p); if (MOID (p) == MODE (VOID) && LABELS (TABLE (sc)) == NO_TAG) { static char fn[NAME_SIZE]; char pop[NAME_SIZE]; int units = 0, decs = 0; NODE_T * last = NO_NODE; compile_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_OTHERS); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_closed", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); embed_serial_clause (sc, out, pop); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_closed", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile collateral clause. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_collateral_clause (NODE_T * p, FILE_T out, int compose_fun) { if (basic_unit (p) && IS (MOID (p), STRUCT_SYMBOL)) { static char fn[NAME_SIZE]; comment_source (p, out); (void) make_name (fn, "_collateral", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; inline_collateral_units (NEXT_SUB (p), out, L_DECLARE); print_declarations (out, root_idf); inline_collateral_units (NEXT_SUB (p), out, L_EXECUTE); inline_collateral_units (NEXT_SUB (p), out, L_YIELD); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_collateral", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } else { return (NO_TEXT); } } /** @brief Compile conditional clause. @param out Output file descriptor. @param p Starting node. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_basic_conditional (NODE_T * p, FILE_T out, int compose_fun) { static char fn[NAME_SIZE]; NODE_T * q = SUB (p); if (! (basic_mode (MOID (p)) || MOID (p) == MODE (VOID))) { return (NO_TEXT); } p = q; if (!basic_conditional (p)) { return (NO_TEXT); } comment_source (p, out); (void) make_name (fn, "_conditional", "", NUMBER (q)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (q, out, fn); } /* Collect declarations */ if (IS (p, IF_PART) || IS (p, OPEN_PART)) { root_idf = NO_DEC; inline_unit (SUB (NEXT_SUB (p)), out, L_DECLARE); print_declarations (out, root_idf); inline_unit (SUB (NEXT_SUB (p)), out, L_EXECUTE); indent (out, "if ("); inline_unit (SUB (NEXT_SUB (p)), out, L_YIELD); undent (out, ") {\n"); indentation ++; } else { ABEND (A68_TRUE, "if-part expected", NO_TEXT); } FORWARD (p); if (IS (p, THEN_PART) || IS (p, CHOICE)) { int pop = temp_book_pointer; (void) compile_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING); indentation --; temp_book_pointer = pop; } else { ABEND (A68_TRUE, "then-part expected", NO_TEXT); } FORWARD (p); if (IS (p, ELSE_PART) || IS (p, CHOICE)) { int pop = temp_book_pointer; indent (out, "} else {\n"); indentation ++; (void) compile_unit (SUB (NEXT_SUB (p)), out, A68_MAKE_NOTHING); indentation --; temp_book_pointer = pop; } /* Done */ indent (out, "}\n"); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_conditional", "", NUMBER (q)); write_fun_postlude (q, out, fn); } return (fn); } /** @brief Compile conditional clause. @param p Starting node. @param out Output file descriptor. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_conditional_clause (NODE_T * p, FILE_T out, int compose_fun) { static char fn[NAME_SIZE]; char pop[NAME_SIZE]; int units = 0, decs = 0; NODE_T * q, * last; /* We only compile IF basic unit or ELIF basic unit, so we save on opening frames */ /* Check worthiness of the clause */ if (MOID (p) != MODE (VOID)) { return (NO_TEXT); } q = SUB (p); while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) { if (! basic_serial (NEXT_SUB (q), 1)) { return (NO_TEXT); } FORWARD (q); while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) { if (LABELS (TABLE (NEXT_SUB (q))) != NO_TAG) { return (NO_TEXT); } FORWARD (q); } if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) { q = SUB (q); } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } } /* Generate embedded units */ q = SUB (p); while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) { FORWARD (q); while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) { last = NO_NODE; units = decs = 0; compile_serial_clause (NEXT_SUB (q), out, &last, &units, &decs, pop, A68_MAKE_OTHERS); FORWARD (q); } if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) { q = SUB (q); } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } } /* Prep and Dec */ (void) make_name (fn, "_conditional", "", NUMBER (p)); (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; q = SUB (p); while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) { inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE); FORWARD (q); while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) { FORWARD (q); } if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) { q = SUB (q); } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } } (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); /* Generate the function body */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); q = SUB (p); while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) { inline_unit (SUB (NEXT_SUB (q)), out, L_EXECUTE); FORWARD (q); while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) { FORWARD (q); } if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) { q = SUB (q); } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } } q = SUB (p); while (q != NO_NODE && is_one_of (q, IF_PART, OPEN_PART, ELIF_IF_PART, ELSE_OPEN_PART, STOP)) { BOOL_T else_part = A68_FALSE; if (is_one_of (q, IF_PART, OPEN_PART, STOP) ) { indent (out, "if ("); } else { indent (out, "} else if ("); } inline_unit (SUB (NEXT_SUB (q)), out, L_YIELD); undent (out, ") {\n"); FORWARD (q); while (q != NO_NODE && (IS (q, THEN_PART) || IS (q, ELSE_PART) || IS (q, CHOICE))) { if (else_part) { indent (out, "} else {\n"); } indentation ++; embed_serial_clause (NEXT_SUB (q), out, pop); indentation --; else_part = A68_TRUE; FORWARD (q); } if (q != NO_NODE && is_one_of (q, ELIF_PART, BRIEF_ELIF_PART, STOP)) { q = SUB (q); } else if (q != NO_NODE && is_one_of (q, FI_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } } indent (out, "}\n"); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_conditional", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } /** @brief Compile unit from integral-case in-part. @param p Node in syntax tree. @param out Output file descriptor. @param sym Node in syntax tree. @param k Value of enquiry clause. @param count Unit counter. @param compose_fun Whether to compose a function. @return Whether a unit was compiled. **/ BOOL_T compile_int_case_units (NODE_T * p, FILE_T out, NODE_T * sym, int k, int * count, int compose_fun) { if (p == NO_NODE) { return (A68_FALSE); } else { if (IS (p, UNIT)) { if (k == * count) { if (compose_fun == A68_MAKE_FUNCTION) { indentf (out, snprintf (line, SNPRINTF_SIZE, "case %d: {\n", k)); indentation ++; indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_N_ (%d));\n", NUMBER (sym))); CODE_EXECUTE (p); inline_comment_source (p, out); undent (out, NEWLINE_STRING); indent (out, "CLOSE_FRAME;\n"); indent (out, "break;\n"); indentation --; indent (out, "}\n"); } else if (compose_fun == A68_MAKE_OTHERS) { if (compile_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) { if (IS (p, UNIT) && IS (SUB (p), TERTIARY)) { compile_units (SUB_SUB (p), out); } else { compile_units (SUB (p), out); } } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) { COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p))); COMPILE_NAME (GINFO (p)) = COMPILE_NAME (GINFO (SUB (p))); } } return (A68_TRUE); } else { (* count)++; return (A68_FALSE); } } else { if (compile_int_case_units (SUB (p), out, sym, k, count, compose_fun)) { return (A68_TRUE); } else { return (compile_int_case_units (NEXT (p), out, sym, k, count, compose_fun)); } } } } /** @brief Compile integral-case-clause. @param p Node in syntax tree. @param out Output file descriptor. @param compose_fun Whether to compose a function. **/ static char * compile_int_case_clause (NODE_T * p, FILE_T out, int compose_fun) { static char fn[NAME_SIZE]; char pop[NAME_SIZE]; int units = 0, decs = 0, k = 0, count = 0; NODE_T * q, * last; /* We only compile CASE basic unit */ /* Check worthiness of the clause */ if (MOID (p) != MODE (VOID)) { return (NO_TEXT); } q = SUB (p); if (q != NO_NODE && is_one_of (q, CASE_PART, OPEN_PART, STOP)) { if (! basic_serial (NEXT_SUB (q), 1)) { return (NO_TEXT); } FORWARD (q); } else { return (NO_TEXT); } while (q != NO_NODE && is_one_of (q, CASE_IN_PART, OUT_PART, CHOICE, STOP)) { if (LABELS (TABLE (NEXT_SUB (q))) != NO_TAG) { return (NO_TEXT); } FORWARD (q); } if (q != NO_NODE && is_one_of (q, ESAC_SYMBOL, CLOSE_SYMBOL)) { FORWARD (q); } else { return (NO_TEXT); } /* Generate embedded units */ q = SUB (p); if (q != NO_NODE && is_one_of (q, CASE_PART, OPEN_PART, STOP)) { FORWARD (q); if (q != NO_NODE && is_one_of (q, CASE_IN_PART, CHOICE, STOP)) { last = NO_NODE; units = decs = 0; k = 0; do { count = 1; k ++; } while (compile_int_case_units (NEXT_SUB (q), out, NO_NODE, k, & count, A68_MAKE_OTHERS)); FORWARD (q); } if (q != NO_NODE && is_one_of (q, OUT_PART, CHOICE, STOP)) { last = NO_NODE; units = decs = 0; compile_serial_clause (NEXT_SUB (q), out, &last, &units, &decs, pop, A68_MAKE_OTHERS); FORWARD (q); } } /* Prep and Dec */ (void) make_name (pop, PUP, "", NUMBER (p)); comment_source (p, out); (void) make_name (fn, "_case", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; q = SUB (p); inline_unit (SUB (NEXT_SUB (q)), out, L_DECLARE); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); /* Generate the function body */ indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); q = SUB (p); inline_unit (SUB (NEXT_SUB (q)), out, L_EXECUTE); indent (out, "switch ("); inline_unit (SUB (NEXT_SUB (q)), out, L_YIELD); undent (out, ") {\n"); indentation ++; FORWARD (q); k = 0; do { count = 1; k ++; } while (compile_int_case_units (NEXT_SUB (q), out, SUB (q), k, & count, A68_MAKE_FUNCTION)); FORWARD (q); if (q != NO_NODE && is_one_of (q, OUT_PART, CHOICE, STOP)) { indent (out, "default: {\n"); indentation ++; embed_serial_clause (NEXT_SUB (q), out, pop); indent (out, "break;\n"); indentation --; indent (out, "}\n"); } indentation --; indent (out, "}\n"); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_case", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } /** @brief Compile loop clause. @param out Output file descriptor. @param p Starting node. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_loop_clause (NODE_T * p, FILE_T out, int compose_fun) { NODE_T *for_part = NO_NODE, *from_part = NO_NODE, *by_part = NO_NODE, *to_part = NO_NODE, * downto_part = NO_NODE, * while_part = NO_NODE, * sc; static char fn[NAME_SIZE]; char idf[NAME_SIZE], z[NAME_SIZE], pop[NAME_SIZE]; NODE_T * q = SUB (p), * last = NO_NODE; int units, decs; BOOL_T gc, need_reinit; /* FOR identifier */ if (IS (q, FOR_PART)) { for_part = NEXT_SUB (q); FORWARD (q); } /* FROM unit */ if (IS (p, FROM_PART)) { from_part = NEXT_SUB (q); if (! basic_unit (from_part)) { return (NO_TEXT); } FORWARD (q); } /* BY unit */ if (IS (q, BY_PART)) { by_part = NEXT_SUB (q); if (! basic_unit (by_part)) { return (NO_TEXT); } FORWARD (q); } /* TO unit, DOWNTO unit */ if (IS (q, TO_PART)) { if (IS (SUB (q), TO_SYMBOL)) { to_part = NEXT_SUB (q); if (! basic_unit (to_part)) { return (NO_TEXT); } } else if (IS (SUB (q), DOWNTO_SYMBOL)) { downto_part = NEXT_SUB (q); if (! basic_unit (downto_part)) { return (NO_TEXT); } } FORWARD (q); } /* WHILE DO OD is not yet supported */ if (IS (q, WHILE_PART)) { return (NO_TEXT); } /* DO UNTIL OD is not yet supported */ if (IS (q, DO_PART) || IS (q, ALT_DO_PART)) { sc = q = NEXT_SUB (q); if (IS (q, SERIAL_CLAUSE)) { FORWARD (q); } if (q != NO_NODE && IS (q, UNTIL_PART)) { return (NO_TEXT); } } else { return (NO_TEXT); } if (LABELS (TABLE (sc)) != NO_TAG) { return (NO_TEXT); } /* Loop clause is compiled */ units = decs = 0; compile_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_OTHERS); gc = (decs > 0); comment_source (p, out); (void) make_name (fn, "_loop", "", NUMBER (p)); if (compose_fun == A68_MAKE_FUNCTION) { write_fun_prelude (p, out, fn); } root_idf = NO_DEC; (void) make_name (idf, "k", "", NUMBER (p)); (void) add_declaration (&root_idf, "int", 0, idf); if (for_part != NO_NODE) { (void) make_name (z, "z", "", NUMBER (p)); (void) add_declaration (&root_idf, "A68_INT", 1, z); } if (from_part != NO_NODE) { inline_unit (from_part, out, L_DECLARE); } if (by_part != NO_NODE) { inline_unit (by_part, out, L_DECLARE); } if (to_part != NO_NODE) { inline_unit (to_part, out, L_DECLARE); } if (downto_part != NO_NODE) { inline_unit (downto_part, out, L_DECLARE); } if (while_part != NO_NODE) { inline_unit (SUB (NEXT_SUB (while_part)), out, L_DECLARE); } (void) make_name (pop, PUP, "", NUMBER (p)); (void) add_declaration (&root_idf, "ADDR_T", 0, pop); print_declarations (out, root_idf); indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = stack_pointer;\n", pop)); if (from_part != NO_NODE) { inline_unit (from_part, out, L_EXECUTE); } if (by_part != NO_NODE) { inline_unit (by_part, out, L_EXECUTE); } if (to_part != NO_NODE) { inline_unit (to_part, out, L_EXECUTE); } if (downto_part != NO_NODE) { inline_unit (downto_part, out, L_EXECUTE); } if (while_part != NO_NODE) { inline_unit (SUB (NEXT_SUB (while_part)), out, L_EXECUTE); } indentf (out, snprintf (line, SNPRINTF_SIZE, "OPEN_STATIC_FRAME (_N_ (%d));\n", NUMBER (sc))); init_static_frame (out, sc); if (for_part != NO_NODE) { indentf (out, snprintf (line, SNPRINTF_SIZE, "%s = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (_N_ (%d)))));\n", z, NUMBER (for_part))); } /* The loop in C */ /* Initialisation */ indentf (out, snprintf (line, SNPRINTF_SIZE, "for (%s = ", idf)); if (from_part == NO_NODE) { undent (out, "1"); } else { inline_unit (from_part, out, L_YIELD); } undent (out, "; "); /* Condition */ if (to_part == NO_NODE && downto_part == NO_NODE && while_part == NO_NODE) { undent (out, "A68_TRUE"); } else { undent (out, idf); if (to_part != NO_NODE) { undent (out, " <= "); } else if (downto_part != NO_NODE) { undent (out, " >= "); } inline_unit (to_part, out, L_YIELD); } undent (out, "; "); /* Increment */ if (by_part == NO_NODE) { undent (out, idf); if (to_part != NO_NODE) { undent (out, " ++"); } else if (downto_part != NO_NODE) { undent (out, " --"); } else { undent (out, " ++"); } } else { undent (out, idf); if (to_part != NO_NODE) { undent (out, " += "); } else if (downto_part != NO_NODE) { undent (out, " -= "); } else { undent (out, " += "); } inline_unit (by_part, out, L_YIELD); } undent (out, ") {\n"); indentation++; if (gc) { indent (out, "/* PREEMPTIVE_GC; */\n"); } if (for_part != NO_NODE) { indentf (out, snprintf (line, SNPRINTF_SIZE, "_S_ (%s) = INIT_MASK;\n", z)); indentf (out, snprintf (line, SNPRINTF_SIZE, "_V_ (%s) = %s;\n", z, idf)); } units = decs = 0; compile_serial_clause (sc, out, &last, &units, &decs, pop, A68_MAKE_FUNCTION); /* Re-initialise if necessary */ need_reinit = (BOOL_T) (AP_INCREMENT (TABLE (sc)) > 0 || need_initialise_frame (sc)); if (need_reinit) { indent (out, "if ("); if (to_part == NO_NODE && downto_part == NO_NODE) { undent (out, "A68_TRUE"); } else { undent (out, idf); if (to_part != NO_NODE) { undent (out, " < "); } else if (downto_part != NO_NODE) { undent (out, " > "); } inline_unit (to_part, out, L_YIELD); } undent (out, ") {\n"); indentation++; if (AP_INCREMENT (TABLE (sc)) > 0) { indentf (out, snprintf (line, SNPRINTF_SIZE, "FRAME_CLEAR (%d);\n", AP_INCREMENT (TABLE (sc)))); } if (need_initialise_frame (sc)) { indentf (out, snprintf (line, SNPRINTF_SIZE, "initialise_frame (_N_ (%d));\n", NUMBER (sc))); } indentation--; indent (out, "}\n"); } /* End of loop */ indentation--; indent (out, "}\n"); indent (out, "CLOSE_FRAME;\n"); indentf (out, snprintf (line, SNPRINTF_SIZE, "stack_pointer = %s;\n", pop)); if (compose_fun == A68_MAKE_FUNCTION) { (void) make_name (fn, "_loop", "", NUMBER (p)); write_fun_postlude (p, out, fn); } return (fn); } /** @brief Compile serial units. @param out Output file descriptor. @param p Starting node. @param compose_fun Whether to compose a function. @return Function name. **/ static char * compile_unit (NODE_T * p, FILE_T out, BOOL_T compose_fun) { /**/ #define COMPILE(p, out, fun, compose_fun) {\ char * fn = (fun) (p, out, compose_fun);\ if (compose_fun == A68_MAKE_FUNCTION && fn != NO_TEXT) {\ ABEND (strlen (fn) > 32, ERROR_INTERNAL_CONSISTENCY, NO_TEXT);\ COMPILE_NAME (GINFO (p)) = new_string (fn, NO_TEXT);\ if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) {\ COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p)));\ } else {\ COMPILE_NODE (GINFO (p)) = NUMBER (p);\ }\ return (COMPILE_NAME (GINFO (p)));\ } else {\ COMPILE_NAME (GINFO (p)) = NO_TEXT;\ COMPILE_NODE (GINFO (p)) = 0;\ return (NO_TEXT);\ }} /**/ LOW_SYSTEM_STACK_ALERT (p); if (p == NO_NODE) { return (NO_TEXT); } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, ENCLOSED_CLAUSE, STOP)) { COMPILE (SUB (p), out, compile_unit, compose_fun); } if (DEBUG_LEVEL >= 3) { /* Control structure */ if (IS (p, CLOSED_CLAUSE)) { COMPILE (p, out, compile_closed_clause, compose_fun); } else if (IS (p, COLLATERAL_CLAUSE)) { COMPILE (p, out, compile_collateral_clause, compose_fun); } else if (IS (p, CONDITIONAL_CLAUSE)) { char * fn2 = compile_basic_conditional (p, out, compose_fun); if (compose_fun == A68_MAKE_FUNCTION && fn2 != NO_TEXT) { ABEND (strlen (fn2) > 32, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); COMPILE_NAME (GINFO (p)) = new_string (fn2, NO_TEXT); if (SUB (p) != NO_NODE && COMPILE_NODE (GINFO (SUB (p))) > 0) { COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p))); } else { COMPILE_NODE (GINFO (p)) = NUMBER (p); } return (COMPILE_NAME (GINFO (p))); } else { COMPILE (p, out, compile_conditional_clause, compose_fun); } } else if (IS (p, CASE_CLAUSE)) { COMPILE (p, out, compile_int_case_clause, compose_fun); } else if (IS (p, LOOP_CLAUSE)) { COMPILE (p, out, compile_loop_clause, compose_fun); } } if (DEBUG_LEVEL >= 2) { /* Simple constructions */ if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), IDENTIFIER) != NO_NODE) { COMPILE (p, out, compile_voiding_assignation_identifier, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SLICE) != NO_NODE) { COMPILE (p, out, compile_voiding_assignation_slice, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && locate (SUB_SUB (p), SELECTION) != NO_NODE) { COMPILE (p, out, compile_voiding_assignation_selection, compose_fun); } else if (IS (p, SLICE)) { COMPILE (p, out, compile_slice, compose_fun); } else if (IS (p, DEREFERENCING) && locate (SUB (p), SLICE) != NO_NODE) { COMPILE (p, out, compile_dereference_slice, compose_fun); } else if (IS (p, SELECTION)) { COMPILE (p, out, compile_selection, compose_fun); } else if (IS (p, DEREFERENCING) && locate (SUB (p), SELECTION) != NO_NODE) { COMPILE (p, out, compile_dereference_selection, compose_fun); } else if (IS (p, CAST)) { COMPILE (p, out, compile_cast, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), FORMULA)) { COMPILE (SUB (p), out, compile_voiding_formula, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), MONADIC_FORMULA)) { COMPILE (SUB (p), out, compile_voiding_formula, compose_fun); } else if (IS (p, DEPROCEDURING)) { COMPILE (p, out, compile_deproceduring, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), DEPROCEDURING)) { COMPILE (p, out, compile_voiding_deproceduring, compose_fun); } else if (IS (p, CALL)) { COMPILE (p, out, compile_call, compose_fun); } else if (IS (p, VOIDING) && IS (SUB (p), CALL)) { COMPILE (p, out, compile_voiding_call, compose_fun); } else if (IS (p, IDENTITY_RELATION)) { COMPILE (p, out, compile_identity_relation, compose_fun); } else if (IS (p, UNITING)) { COMPILE (p, out, compile_uniting, compose_fun); } } if (DEBUG_LEVEL >= 1) { /* Debugging stuff, only basic */ if (IS (p, DENOTATION)) { COMPILE (p, out, compile_denotation, compose_fun); } else if (IS (p, IDENTIFIER)) { COMPILE (p, out, compile_identifier, compose_fun); } else if (IS (p, DEREFERENCING) && locate (SUB (p), IDENTIFIER) != NO_NODE) { COMPILE (p, out, compile_dereference_identifier, compose_fun); } else if (IS (p, MONADIC_FORMULA)) { COMPILE (p, out, compile_formula, compose_fun); } else if (IS (p, FORMULA)) { COMPILE (p, out, compile_formula, compose_fun); } } if (IS (p, CODE_CLAUSE)) { COMPILE (p, out, compile_code_clause, compose_fun); } return (NO_TEXT); #undef COMPILE } /** @brief Compile units. @param p Starting node. @param out Output file descriptor. **/ void compile_units (NODE_T * p, FILE_T out) { ADDR_T pop_temp_heap_pointer = temp_heap_pointer; /* At the end we discard temporary declarations */ for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT) || IS (p, CODE_CLAUSE)) { if (compile_unit (p, out, A68_MAKE_FUNCTION) == NO_TEXT) { compile_units (SUB (p), out); } else if (SUB (p) != NO_NODE && GINFO (SUB (p)) != NO_GINFO && COMPILE_NODE (GINFO (SUB (p))) > 0) { COMPILE_NODE (GINFO (p)) = COMPILE_NODE (GINFO (SUB (p))); COMPILE_NAME (GINFO (p)) = COMPILE_NAME (GINFO (SUB (p))); } } else { compile_units (SUB (p), out); } } temp_heap_pointer = pop_temp_heap_pointer; } /** @brief Compiler driver. @param out Output file descriptor. **/ void compiler (FILE_T out) { if (OPTION_OPTIMISE (&program) == A68_FALSE) { return; } indentation = 0; temp_book_pointer = 0; root_idf = NO_DEC; global_level = A68_MAX_INT; global_pointer = 0; get_global_level (SUB (TOP_NODE (&program))); max_lex_lvl = 0; genie_preprocess (TOP_NODE (&program), & max_lex_lvl, NULL); write_prelude (out); get_global_level (TOP_NODE (&program)); stack_pointer = stack_start; expr_stack_limit = stack_end - storage_overhead; compile_units (TOP_NODE (&program), out); ABEND (indentation != 0, "indentation error", NO_TEXT); } algol68g-2.8/source/genie.c0000644000175000001440000060671312160170652012473 00000000000000/** @file genie.c @author J. Marcel van der Veer. @brief Routines executing primitive A68 actions. @section Copyright This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2013 J. Marcel van der Veer . @section License 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 . **/ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" A68_HANDLE nil_handle = { INIT_MASK, NO_BYTE, 0, NO_MOID, NO_HANDLE, NO_HANDLE }; A68_REF nil_ref = { (STATUS_MASK) (INIT_MASK | NIL_MASK), 0, 0, NO_HANDLE }; #define IF_ROW(m)\ (IS (m, FLEX_SYMBOL) || IS (m, ROW_SYMBOL) || m == MODE (STRING)) ADDR_T frame_pointer = 0, stack_pointer = 0, heap_pointer = 0, handle_pointer = 0, global_pointer = 0, frame_start, frame_end, stack_start, stack_end; BOOL_T do_confirm_exit = A68_TRUE; BYTE_T *stack_segment = NO_BYTE, *heap_segment = NO_BYTE, *handle_segment = NO_BYTE; NODE_T *last_unit = NO_NODE; int global_level = 0, ret_code, ret_line_number, ret_char_number; int max_lex_lvl = 0; jmp_buf genie_exit_label; int frame_stack_size, expr_stack_size, heap_size, handle_pool_size; int stack_limit, frame_stack_limit, expr_stack_limit; int storage_overhead; A68_PROCEDURE on_gc_event; static A68_REF genie_make_rowrow (NODE_T *, MOID_T *, int, ADDR_T); static A68_REF genie_make_ref_row_of_row (NODE_T *, MOID_T *, MOID_T *, ADDR_T); static A68_REF genie_make_ref_row_row (NODE_T *, MOID_T *, MOID_T *, ADDR_T); static A68_REF genie_clone (NODE_T *, MOID_T *, A68_REF *, A68_REF *); static void genie_clone_stack (NODE_T *, MOID_T *, A68_REF *, A68_REF *); static void genie_serial_units_no_label (NODE_T *, int, NODE_T **); /* Genie routines */ static PROP_T genie_and_function (NODE_T *); static PROP_T genie_assertion (NODE_T *); static PROP_T genie_assignation_constant (NODE_T *); static PROP_T genie_assignation (NODE_T *); static PROP_T genie_call (NODE_T *); static PROP_T genie_cast (NODE_T *); static PROP_T genie_closed (volatile NODE_T *); static PROP_T genie_coercion (NODE_T *); static PROP_T genie_collateral (NODE_T *); static PROP_T genie_column_function (NODE_T *); static PROP_T genie_conditional (volatile NODE_T *); static PROP_T genie_constant (NODE_T *); static PROP_T genie_denotation (NODE_T *); static PROP_T genie_deproceduring (NODE_T *); static PROP_T genie_dereference_frame_identifier (NODE_T *); static PROP_T genie_dereference_generic_identifier (NODE_T *); static PROP_T genie_dereference_selection_name_quick (NODE_T *); static PROP_T genie_dereference_slice_name_quick (NODE_T *); static PROP_T genie_dereferencing (NODE_T *); static PROP_T genie_dereferencing_quick (NODE_T *); static PROP_T genie_diagonal_function (NODE_T *); static PROP_T genie_dyadic (NODE_T *); static PROP_T genie_dyadic_quick (NODE_T *); static PROP_T genie_enclosed (volatile NODE_T *); static PROP_T genie_field_selection (NODE_T *); static PROP_T genie_format_text (NODE_T *); static PROP_T genie_formula (NODE_T *); static PROP_T genie_generator (NODE_T *); static PROP_T genie_identifier (NODE_T *); static PROP_T genie_identifier_standenv (NODE_T *); static PROP_T genie_identifier_standenv_proc (NODE_T *); static PROP_T genie_identity_relation (NODE_T *); static PROP_T genie_int_case (volatile NODE_T *); static PROP_T genie_frame_identifier (NODE_T *); static PROP_T genie_loop (volatile NODE_T *); static PROP_T genie_monadic (NODE_T *); static PROP_T genie_nihil (NODE_T *); static PROP_T genie_or_function (NODE_T *); static PROP_T genie_routine_text (NODE_T *); static PROP_T genie_row_function (NODE_T *); static PROP_T genie_rowing (NODE_T *); static PROP_T genie_rowing_ref_row_of_row (NODE_T *); static PROP_T genie_rowing_ref_row_row (NODE_T *); static PROP_T genie_rowing_row_of_row (NODE_T *); static PROP_T genie_rowing_row_row (NODE_T *); static PROP_T genie_selection_name_quick (NODE_T *); static PROP_T genie_selection (NODE_T *); static PROP_T genie_selection_value_quick (NODE_T *); static PROP_T genie_skip (NODE_T *); static PROP_T genie_slice_name_quick (NODE_T *); static PROP_T genie_slice (NODE_T *); static PROP_T genie_transpose_function (NODE_T *); static PROP_T genie_united_case (volatile NODE_T *); static PROP_T genie_uniting (NODE_T *); static PROP_T genie_unit (NODE_T *); static PROP_T genie_voiding_assignation_constant (NODE_T *); static PROP_T genie_voiding_assignation (NODE_T *); static PROP_T genie_voiding (NODE_T *); static PROP_T genie_widening_int_to_real (NODE_T *); static PROP_T genie_widening (NODE_T *); static PROP_T genie_assignation_quick (NODE_T * p); static PROP_T genie_loop (volatile NODE_T *); #if defined HAVE_PARALLEL_CLAUSE static PROP_T genie_parallel (NODE_T *); #endif /** @brief Nop for the genie, for instance '+' for INT or REAL. @param p Node in syntax tree. **/ void genie_idle (NODE_T * p) { (void) p; } /** @brief Unimplemented feature handler. @param p Node in syntax tree. **/ void genie_unimplemented (NODE_T * p) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_UNIMPLEMENTED); exit_genie (p, A68_RUNTIME_ERROR); } /** @brief PROC system = (STRING) INT @param p Node in syntax tree. **/ void genie_system (NODE_T * p) { int sys_ret_code, size; A68_REF cmd; A68_REF ref_z; POP_REF (p, &cmd); CHECK_INIT (p, INITIALISED (&cmd), MODE (STRING)); size = 1 + a68_string_size (p, cmd); ref_z = heap_generator (p, MODE (C_STRING), 1 + size); sys_ret_code = system (a_to_c_string (p, DEREF (char, &ref_z), cmd)); PUSH_PRIMITIVE (p, sys_ret_code, A68_INT); } /** @brief Set flags throughout tree. @param p Node in syntax tree. @param mask Mask to use. @param set Whether to SET or CLEAR. **/ void change_masks (NODE_T * p, unsigned mask, BOOL_T set) { for (; p != NO_NODE; FORWARD (p)) { change_masks (SUB (p), mask, set); if (LINE_NUMBER (p) > 0) { if (set == A68_TRUE) { STATUS_SET (p, mask); } else { STATUS_CLEAR (p, mask); } } } } /** @brief Leave interpretation. @param p Node in syntax tree. @param ret Exit code. **/ void exit_genie (NODE_T * p, int ret) { #if defined HAVE_CURSES genie_curses_end (p); #endif if (!in_execution) { return; } if (ret == A68_RUNTIME_ERROR && in_monitor) { return; } else if (ret == A68_RUNTIME_ERROR && OPTION_DEBUG (&program)) { diagnostics_to_terminal (TOP_LINE (&program), A68_RUNTIME_ERROR); single_step (p, (unsigned) BREAKPOINT_ERROR_MASK); in_execution = A68_FALSE; ret_line_number = LINE_NUMBER (p); ret_code = ret; longjmp (genie_exit_label, 1); } else { if ((ret & A68_FORCE_QUIT) != NULL_MASK) { ret &= ~A68_FORCE_QUIT; } #if defined HAVE_PARALLEL_CLAUSE if (!is_main_thread ()) { genie_set_exit_from_threads (ret); } else { in_execution = A68_FALSE; ret_line_number = LINE_NUMBER (p); ret_code = ret; longjmp (genie_exit_label, 1); } #else in_execution = A68_FALSE; ret_line_number = LINE_NUMBER (p); ret_code = ret; longjmp (genie_exit_label, 1); #endif } } /** @brief Genie init rng. **/ void genie_init_rng (void) { time_t t; if (time (&t) != -1) { struct tm *u = localtime (&t); int seed = TM_SEC (u) + 60 * (TM_MIN (u) + 60 * TM_HOUR (u)); init_rng ((long unsigned) seed); } } /** @brief Tie label to the clause it is defined in. @param p Node in syntax tree. **/ void tie_label_to_serial (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, SERIAL_CLAUSE)) { BOOL_T valid_follow; if (NEXT (p) == NO_NODE) { valid_follow = A68_TRUE; } else if (IS (NEXT (p), CLOSE_SYMBOL)) { valid_follow = A68_TRUE; } else if (IS (NEXT (p), END_SYMBOL)) { valid_follow = A68_TRUE; } else if (IS (NEXT (p), EDOC_SYMBOL)) { valid_follow = A68_TRUE; } else if (IS (NEXT (p), OD_SYMBOL)) { valid_follow = A68_TRUE; } else { valid_follow = A68_FALSE; } if (valid_follow) { JUMP_TO (TABLE (SUB (p))) = NO_NODE; } } tie_label_to_serial (SUB (p)); } } /** @brief Tie label to the clause it is defined in. @param p Node in syntax tree. @param unit Associated unit. **/ 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); } } /** @brief Tie label to the clause it is defined in. @param p Node in syntax tree. **/ 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)); } } /** @brief Fast way to indicate a mode. @param p Node in syntax tree. **/ static int mode_attribute (MOID_T * p) { if (IS (p, REF_SYMBOL)) { return (REF_SYMBOL); } else if (IS (p, PROC_SYMBOL)) { return (PROC_SYMBOL); } else if (IS (p, UNION_SYMBOL)) { return (UNION_SYMBOL); } else if (p == MODE (INT)) { return (MODE_INT); } else if (p == MODE (LONG_INT)) { return (MODE_LONG_INT); } else if (p == MODE (LONGLONG_INT)) { return (MODE_LONGLONG_INT); } else if (p == MODE (REAL)) { return (MODE_REAL); } else if (p == MODE (LONG_REAL)) { return (MODE_LONG_REAL); } else if (p == MODE (LONGLONG_REAL)) { return (MODE_LONGLONG_REAL); } else if (p == MODE (COMPLEX)) { return (MODE_COMPLEX); } else if (p == MODE (LONG_COMPLEX)) { return (MODE_LONG_COMPLEX); } else if (p == MODE (LONGLONG_COMPLEX)) { return (MODE_LONGLONG_COMPLEX); } else if (p == MODE (BOOL)) { return (MODE_BOOL); } else if (p == MODE (CHAR)) { return (MODE_CHAR); } else if (p == MODE (BITS)) { return (MODE_BITS); } else if (p == MODE (LONG_BITS)) { return (MODE_LONG_BITS); } else if (p == MODE (LONGLONG_BITS)) { return (MODE_LONGLONG_BITS); } else if (p == MODE (BYTES)) { return (MODE_BYTES); } else if (p == MODE (LONG_BYTES)) { return (MODE_LONG_BYTES); } else if (p == MODE (FILE)) { return (MODE_FILE); } else if (p == MODE (FORMAT)) { return (MODE_FORMAT); } else if (p == MODE (PIPE)) { return (MODE_PIPE); } else if (p == MODE (SOUND)) { return (MODE_SOUND); } else { return (MODE_NO_CHECK); } } /** @brief Perform tasks before interpretation. @param p Node in syntax tree. @param max_lev Maximum level found. @param compile_lib Handle to compiled library. **/ void genie_preprocess (NODE_T * p, int *max_lev, void *compile_lib) { #if defined HAVE_COMPILER static char * last_compile_name = NO_TEXT; static PROP_PROC * last_compile_unit = NO_PPROC; #endif for (; p != NO_NODE; FORWARD (p)) { if (STATUS_TEST (p, BREAKPOINT_MASK)) { if (!(STATUS_TEST (p, INTERRUPTIBLE_MASK))) { STATUS_CLEAR (p, BREAKPOINT_MASK); } } if (GINFO (p) != NO_GINFO) { IS_COERCION (GINFO (p)) = is_coercion (p); IS_NEW_LEXICAL_LEVEL (GINFO (p)) = is_new_lexical_level (p); /* The default */ UNIT (&GPROP (p)) = genie_unit; SOURCE (&GPROP (p)) = p; #if defined HAVE_COMPILER if (OPTION_OPTIMISE (&program) && COMPILE_NAME (GINFO (p)) != NO_TEXT && compile_lib != NULL) { if (COMPILE_NAME (GINFO (p)) == last_compile_name) { /* copy */ UNIT (&GPROP (p)) = last_compile_unit; } else { /* look up */ /* Next line provokes a warning that cannot be suppressed, not even by this POSIX workaround. Tant pis. */ * (void **) &(UNIT (&GPROP (p))) = dlsym (compile_lib, COMPILE_NAME (GINFO (p))); ABEND (UNIT (&GPROP (p)) == NULL, "compiler cannot resolve", dlerror ()); last_compile_name = COMPILE_NAME (GINFO (p)); last_compile_unit = UNIT (&GPROP (p)); } } #endif } if (MOID (p) != NO_MOID) { SIZE (MOID (p)) = moid_size (MOID (p)); DIGITS (MOID (p)) = moid_digits (MOID (p)); SHORT_ID (MOID (p)) = mode_attribute (MOID (p)); if (GINFO (p) != NO_GINFO) { NEED_DNS (GINFO (p)) = A68_FALSE; if (IS (MOID (p), REF_SYMBOL)) { NEED_DNS (GINFO (p)) = A68_TRUE; } else if (IS (MOID (p), PROC_SYMBOL)) { NEED_DNS (GINFO (p)) = A68_TRUE; } else if (IS (MOID (p), FORMAT_SYMBOL)) { NEED_DNS (GINFO (p)) = A68_TRUE; } } } if (TABLE (p) != NO_TABLE) { if (LEX_LEVEL (p) > *max_lev) { *max_lev = LEX_LEVEL (p); } } if (IS (p, FORMAT_TEXT)) { TAG_T *q = TAX (p); if (q != NO_TAG && NODE (q) != NO_NODE) { NODE (q) = p; } } else if (IS (p, DEFINING_IDENTIFIER)) { TAG_T *q = TAX (p); if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) { LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q)); } } else if (IS (p, IDENTIFIER)) { TAG_T *q = TAX (p); if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) { LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q)); OFFSET (GINFO (p)) = &stack_segment[FRAME_INFO_SIZE + OFFSET (q)]; } } else if (IS (p, OPERATOR)) { TAG_T *q = TAX (p); if (q != NO_TAG && NODE (q) != NO_NODE && TABLE (NODE (q)) != NO_TABLE) { LEVEL (GINFO (p)) = LEX_LEVEL (NODE (q)); OFFSET (GINFO (p)) = &stack_segment[FRAME_INFO_SIZE + OFFSET (q)]; } } if (SUB (p) != NO_NODE) { if (GINFO (p) != NO_GINFO) { GPARENT (SUB (p)) = p; } genie_preprocess (SUB (p), max_lev, compile_lib); } } } /** @brief Get outermost lexical level in the user program. @param p Node in syntax tree. **/ void get_global_level (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (LINE_NUMBER (p) != 0 && IS (p, UNIT)) { if (LEX_LEVEL (p) < global_level) { global_level = LEX_LEVEL (p); } } get_global_level (SUB (p)); } } /** @brief Free heap allocated by genie. @param p Node in syntax tree. **/ void free_genie_heap (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { free_genie_heap (SUB (p)); if (GINFO (p) != NO_GINFO && CONSTANT (GINFO (p)) != NO_CONSTANT) { free (CONSTANT (GINFO (p))); CONSTANT (GINFO (p)) = NO_CONSTANT; } } } /** @brief Driver for the interpreter. **/ void genie (void * compile_lib) { MOID_T *m; /* Fill in final info for modes */ for (m = TOP_MOID (&program); m != NO_MOID; FORWARD (m)) { SIZE (m) = moid_size (m); DIGITS (m) = moid_digits (m); SHORT_ID (m) = mode_attribute (m); } /* Preprocessing */ max_lex_lvl = 0; /* genie_lex_levels (TOP_NODE (&program), 1); */ genie_preprocess (TOP_NODE (&program), &max_lex_lvl, compile_lib); change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_FALSE); watchpoint_expression = NO_TEXT; frame_stack_limit = frame_end - storage_overhead; expr_stack_limit = stack_end - storage_overhead; if (OPTION_REGRESSION_TEST (&program)) { init_rng (1); } else { genie_init_rng (); } io_close_tty_line (); if (OPTION_TRACE (&program)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "genie: frame stack %dk, expression stack %dk, heap %dk, handles %dk\n", frame_stack_size / KILOBYTE, expr_stack_size / KILOBYTE, heap_size / KILOBYTE, handle_pool_size / KILOBYTE) >= 0); WRITE (STDOUT_FILENO, output_line); } install_signal_handlers (); set_default_event_procedure (&on_gc_event); do_confirm_exit = A68_TRUE; /* Dive into the program */ if (setjmp (genie_exit_label) == 0) { NODE_T *p = SUB (TOP_NODE (&program)); /* If we are to stop in the monitor, set a breakpoint on the first unit */ if (OPTION_DEBUG (&program)) { change_masks (TOP_NODE (&program), BREAKPOINT_TEMPORARY_MASK, A68_TRUE); WRITE (STDOUT_FILENO, "Execution begins ..."); } RESET_ERRNO; ret_code = 0; global_level = A68_MAX_INT; global_pointer = 0; get_global_level (p); frame_pointer = frame_start; stack_pointer = stack_start; FRAME_DYNAMIC_LINK (frame_pointer) = 0; FRAME_DNS (frame_pointer) = 0; FRAME_STATIC_LINK (frame_pointer) = 0; FRAME_NUMBER (frame_pointer) = 0; FRAME_TREE (frame_pointer) = (NODE_T *) p; FRAME_LEXICAL_LEVEL (frame_pointer) = LEX_LEVEL (p); FRAME_PARAMETER_LEVEL (frame_pointer) = LEX_LEVEL (p); FRAME_PARAMETERS (frame_pointer) = frame_pointer; initialise_frame (p); genie_init_heap (p); genie_init_transput (TOP_NODE (&program)); cputime_0 = seconds (); /* Here we go .. */ in_execution = A68_TRUE; last_unit = TOP_NODE (&program); #if ! defined HAVE_WIN32 (void) alarm (1); #endif /* ! defined HAVE_WIN32 */ if (OPTION_TRACE (&program)) { WIS (TOP_NODE (&program)); } (void) genie_enclosed (TOP_NODE (&program)); } else { /* Here we have jumped out of the interpreter. What happened? */ if (OPTION_DEBUG (&program)) { WRITE (STDOUT_FILENO, "Execution discontinued"); } if (ret_code == A68_RERUN) { diagnostics_to_terminal (TOP_LINE (&program), A68_RUNTIME_ERROR); genie (compile_lib); } else if (ret_code == A68_RUNTIME_ERROR) { if (OPTION_BACKTRACE (&program)) { int printed = 0; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\nStack backtrace") >= 0); WRITE (STDOUT_FILENO, output_line); stack_dump (STDOUT_FILENO, frame_pointer, 16, &printed); WRITE (STDOUT_FILENO, NEWLINE_STRING); } if (FILE_LISTING_OPENED (&program)) { int printed = 0; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\nStack backtrace") >= 0); WRITE (FILE_LISTING_FD (&program), output_line); stack_dump (FILE_LISTING_FD (&program), frame_pointer, 32, &printed); } } } in_execution = A68_FALSE; } /* This file contains interpreter ("genie") routines related to executing primitive A68 actions. The genie is self-optimising as when it traverses the tree, it stores terminals it ends up in at the root where traversing for that terminal started. Such piece of information is called a PROP. */ /** @brief Shows line where 'p' is at and draws a '-' beneath the position. @param f File number. @param p Node in syntax tree. **/ void where_in_source (FILE_T f, NODE_T * p) { write_source_line (f, LINE (INFO (p)), p, A68_NO_DIAGNOSTICS); } /* Since Algol 68 can pass procedures as parameters, we use static links rather than a display. */ /** @brief Initialise PROC and OP identities. @param p Starting node of a declaration. @param seq Chain to link nodes into. @param count Number of constants initialised. **/ static void genie_init_proc_op (NODE_T * p, NODE_T ** seq, int *count) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case OP_SYMBOL: case PROC_SYMBOL: case OPERATOR_PLAN: case DECLARER: { break; } case DEFINING_IDENTIFIER: case DEFINING_OPERATOR: { /* Store position so we need not search again */ NODE_T *save = *seq; (*seq) = p; SEQUENCE (*seq) = save; (*count)++; return; } default: { genie_init_proc_op (SUB (p), seq, count); break; } } } } /** @brief Initialise PROC and OP identity declarations. @param p Node in syntax tree. @param count Number of constants initialised. **/ void genie_find_proc_op (NODE_T * p, int *count) { for (; p != NO_NODE; FORWARD (p)) { if (GINFO (p) != NO_GINFO && IS_NEW_LEXICAL_LEVEL (GINFO (p))) { /* Don't enter a new lexical level - it will have its own initialisation */ return; } else if (IS (p, PROCEDURE_DECLARATION) || IS (p, BRIEF_OPERATOR_DECLARATION)) { genie_init_proc_op (SUB (p), &(SEQUENCE (TABLE (p))), count); return; } else { genie_find_proc_op (SUB (p), count); } } } /** @brief Initialise stack frame. @param p Node in syntax tree. **/ void initialise_frame (NODE_T * p) { if (INITIALISE_ANON (TABLE (p))) { TAG_T *_a_; INITIALISE_ANON (TABLE (p)) = A68_FALSE; for (_a_ = ANONYMOUS (TABLE (p)); _a_ != NO_TAG; FORWARD (_a_)) { if (PRIO (_a_) == ROUTINE_TEXT) { int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_))); A68_PROCEDURE *_z_ = (A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (_a_))); STATUS (_z_) = INIT_MASK; NODE (&(BODY (_z_))) = NODE (_a_); if (youngest > 0) { STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest); } else { ENVIRON (_z_) = 0; } LOCALE (_z_) = NO_HANDLE; MOID (_z_) = MOID (_a_); INITIALISE_ANON (TABLE (p)) = A68_TRUE; } else if (PRIO (_a_) == FORMAT_TEXT) { int youngest = YOUNGEST_ENVIRON (TAX (NODE (_a_))); A68_FORMAT *_z_ = (A68_FORMAT *) (FRAME_OBJECT (OFFSET (_a_))); STATUS (_z_) = INIT_MASK; BODY (_z_) = NODE (_a_); if (youngest > 0) { STATIC_LINK_FOR_FRAME (ENVIRON (_z_), 1 + youngest); } else { ENVIRON (_z_) = 0; } INITIALISE_ANON (TABLE (p)) = A68_TRUE; } } } if (PROC_OPS (TABLE (p))) { NODE_T *_q_; ADDR_T pop_sp; if (SEQUENCE (TABLE (p)) == NO_NODE) { int count = 0; genie_find_proc_op (p, &count); PROC_OPS (TABLE (p)) = (BOOL_T) (count > 0); } pop_sp = stack_pointer; for (_q_ = SEQUENCE (TABLE (p)); _q_ != NO_NODE; _q_ = SEQUENCE (_q_)) { NODE_T *u = NEXT_NEXT (_q_); if (IS (u, ROUTINE_TEXT)) { NODE_T *src = SOURCE (&(GPROP (u))); *(A68_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src)))); } else if ((IS (u, UNIT) && IS (SUB (u), ROUTINE_TEXT))) { NODE_T *src = SOURCE (&(GPROP (SUB (u)))); *(A68_PROCEDURE *) FRAME_OBJECT (OFFSET (TAX (_q_))) = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (src)))); } } } INITIALISE_FRAME (TABLE (p)) = (BOOL_T) (INITIALISE_ANON (TABLE (p)) || PROC_OPS (TABLE (p))); } /** @brief Whether item at "w" of mode "q" is initialised. @param p Node in syntax tree. @param w Pointer to object. @param q Mode of object. **/ void genie_check_initialisation (NODE_T * p, BYTE_T * w, MOID_T * q) { switch (SHORT_ID (q)) { case REF_SYMBOL: { A68_REF *z = (A68_REF *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case PROC_SYMBOL: { A68_PROCEDURE *z = (A68_PROCEDURE *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_INT: { A68_INT *z = (A68_INT *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_REAL: { A68_REAL *z = (A68_REAL *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_COMPLEX: { A68_REAL *r = (A68_REAL *) w; A68_REAL *i = (A68_REAL *) (w + SIZE_AL (A68_REAL)); CHECK_INIT (p, INITIALISED (r), q); CHECK_INIT (p, INITIALISED (i), q); return; } case MODE_LONG_INT: case MODE_LONGLONG_INT: case MODE_LONG_REAL: case MODE_LONGLONG_REAL: case MODE_LONG_BITS: case MODE_LONGLONG_BITS: { MP_T *z = (MP_T *) w; CHECK_INIT (p, (unsigned) z[0] & INIT_MASK, q); return; } case MODE_LONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_long_mp ()); CHECK_INIT (p, (unsigned) r[0] & INIT_MASK, q); CHECK_INIT (p, (unsigned) i[0] & INIT_MASK, q); return; } case MODE_LONGLONG_COMPLEX: { MP_T *r = (MP_T *) w; MP_T *i = (MP_T *) (w + size_longlong_mp ()); CHECK_INIT (p, (unsigned) r[0] & INIT_MASK, q); CHECK_INIT (p, (unsigned) i[0] & INIT_MASK, q); return; } case MODE_BOOL: { A68_BOOL *z = (A68_BOOL *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_CHAR: { A68_CHAR *z = (A68_CHAR *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_BITS: { A68_BITS *z = (A68_BITS *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_BYTES: { A68_BYTES *z = (A68_BYTES *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_LONG_BYTES: { A68_LONG_BYTES *z = (A68_LONG_BYTES *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_FILE: { A68_FILE *z = (A68_FILE *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_FORMAT: { A68_FORMAT *z = (A68_FORMAT *) w; CHECK_INIT (p, INITIALISED (z), q); return; } case MODE_PIPE: { A68_REF *pipe_read = (A68_REF *) w; A68_REF *pipe_write = (A68_REF *) (w + A68_REF_SIZE); A68_INT *pid = (A68_INT *) (w + 2 * A68_REF_SIZE); CHECK_INIT (p, INITIALISED (pipe_read), q); CHECK_INIT (p, INITIALISED (pipe_write), q); CHECK_INIT (p, INITIALISED (pid), q); return; } case MODE_SOUND: { A68_SOUND *z = (A68_SOUND *) w; CHECK_INIT (p, INITIALISED (z), q); return; } } } /** @brief Push constant stored in the tree. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_constant (NODE_T * p) { PUSH (p, CONSTANT (GINFO (p)), SIZE (GINFO (p))); return (GPROP (p)); } /** @brief Unite value in the stack and push result. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_uniting (NODE_T * p) { PROP_T self; ADDR_T sp = stack_pointer; MOID_T *u = MOID (p), *v = MOID (SUB (p)); int size = SIZE (u); if (ATTRIBUTE (v) != UNION_SYMBOL) { PUSH_UNION (p, (void *) unites_to (v, u)); EXECUTE_UNIT (SUB (p)); STACK_DNS (p, SUB (v), frame_pointer); } else { A68_UNION *m = (A68_UNION *) STACK_TOP; EXECUTE_UNIT (SUB (p)); STACK_DNS (p, SUB (v), frame_pointer); VALUE (m) = (void *) unites_to ((MOID_T *) VALUE (m), u); } stack_pointer = sp + size; UNIT (&self) = genie_uniting; SOURCE (&self) = p; return (self); } /** @brief Store widened constant as a constant. @param p Node in syntax tree. @param m Mode of object. @param self Propagator to set. **/ static void make_constant_widening (NODE_T * p, MOID_T * m, PROP_T * self) { if (SUB (p) != NO_NODE && CONSTANT (GINFO (SUB (p))) != NO_CONSTANT) { int size = SIZE (m); UNIT (self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((unsigned) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), (void *) (STACK_OFFSET (-size)), size); } } /** @brief (optimised) push INT widened to REAL @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_widening_int_to_real (NODE_T * p) { A68_INT *i = (A68_INT *) STACK_TOP; A68_REAL *z = (A68_REAL *) STACK_TOP; EXECUTE_UNIT (SUB (p)); INCREMENT_STACK_POINTER (p, SIZE_AL (A68_REAL) - SIZE (MODE (INT))); VALUE (z) = (double) VALUE (i); STATUS (z) = INIT_MASK; return (GPROP (p)); } /** @brief Widen value in the stack. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_widening (NODE_T * p) { #define COERCE_FROM_TO(p, a, b) (MOID (p) == (b) && MOID (SUB (p)) == (a)) PROP_T self; UNIT (&self) = genie_widening; SOURCE (&self) = p; /* INT widenings */ if (COERCE_FROM_TO (p, MODE (INT), MODE (REAL))) { (void) genie_widening_int_to_real (p); UNIT (&self) = genie_widening_int_to_real; make_constant_widening (p, MODE (REAL), &self); } else if (COERCE_FROM_TO (p, MODE (INT), MODE (LONG_INT))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_int_to_long_mp (p); make_constant_widening (p, MODE (LONG_INT), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_INT), MODE (LONGLONG_INT))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_long_mp_to_longlong_mp (p); make_constant_widening (p, MODE (LONGLONG_INT), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_INT), MODE (LONG_REAL))) { EXECUTE_UNIT (SUB (p)); /* 1-1 mapping */ make_constant_widening (p, MODE (LONG_REAL), &self); } else if (COERCE_FROM_TO (p, MODE (LONGLONG_INT), MODE (LONGLONG_REAL))) { EXECUTE_UNIT (SUB (p)); /* 1-1 mapping */ make_constant_widening (p, MODE (LONGLONG_REAL), &self); } /* REAL widenings */ else if (COERCE_FROM_TO (p, MODE (REAL), MODE (LONG_REAL))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_real_to_long_mp (p); make_constant_widening (p, MODE (LONG_REAL), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_REAL), MODE (LONGLONG_REAL))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_long_mp_to_longlong_mp (p); make_constant_widening (p, MODE (LONGLONG_REAL), &self); } else if (COERCE_FROM_TO (p, MODE (REAL), MODE (COMPLEX))) { EXECUTE_UNIT (SUB (p)); PUSH_PRIMITIVE (p, 0.0, A68_REAL); make_constant_widening (p, MODE (COMPLEX), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_REAL), MODE (LONG_COMPLEX))) { MP_T *z; int digits = DIGITS (MODE (LONG_REAL)); EXECUTE_UNIT (SUB (p)); STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; make_constant_widening (p, MODE (LONG_COMPLEX), &self); } else if (COERCE_FROM_TO (p, MODE (LONGLONG_REAL), MODE (LONGLONG_COMPLEX))) { MP_T *z; int digits = DIGITS (MODE (LONGLONG_REAL)); EXECUTE_UNIT (SUB (p)); STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; make_constant_widening (p, MODE (LONGLONG_COMPLEX), &self); } /* COMPLEX widenings */ else if (COERCE_FROM_TO (p, MODE (COMPLEX), MODE (LONG_COMPLEX))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_complex_to_long_complex (p); make_constant_widening (p, MODE (LONG_COMPLEX), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_COMPLEX), MODE (LONGLONG_COMPLEX))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_long_complex_to_longlong_complex (p); make_constant_widening (p, MODE (LONGLONG_COMPLEX), &self); } /* BITS widenings */ else if (COERCE_FROM_TO (p, MODE (BITS), MODE (LONG_BITS))) { EXECUTE_UNIT (SUB (p)); /* Treat unsigned as int, but that's ok */ genie_lengthen_int_to_long_mp (p); make_constant_widening (p, MODE (LONG_BITS), &self); } else if (COERCE_FROM_TO (p, MODE (LONG_BITS), MODE (LONGLONG_BITS))) { EXECUTE_UNIT (SUB (p)); genie_lengthen_long_mp_to_longlong_mp (p); make_constant_widening (p, MODE (LONGLONG_BITS), &self); } /* Miscellaneous widenings */ else if (COERCE_FROM_TO (p, MODE (BYTES), MODE (ROW_CHAR)) || COERCE_FROM_TO (p, MODE (BYTES), MODE (FLEX_ROW_CHAR))) { A68_BYTES z; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &z, A68_BYTES); PUSH_REF (p, c_string_to_row_char (p, VALUE (&z), BYTES_WIDTH)); } else if (COERCE_FROM_TO (p, MODE (LONG_BYTES), MODE (ROW_CHAR)) || COERCE_FROM_TO (p, MODE (LONG_BYTES), MODE (FLEX_ROW_CHAR))) { A68_LONG_BYTES z; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &z, A68_LONG_BYTES); PUSH_REF (p, c_string_to_row_char (p, VALUE (&z), LONG_BYTES_WIDTH)); } else if (COERCE_FROM_TO (p, MODE (BITS), MODE (ROW_BOOL)) || COERCE_FROM_TO (p, MODE (BITS), MODE (FLEX_ROW_BOOL))) { A68_BITS x; A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; int k; unsigned bit; BYTE_T *base; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &x, A68_BITS); z = heap_generator (p, MODE (ROW_BOOL), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_BOOL), BITS_WIDTH * SIZE (MODE (BOOL))); DIM (&arr) = 1; MOID (&arr) = MODE (BOOL); ELEM_SIZE (&arr) = SIZE (MODE (BOOL)); SLICE_OFFSET (&arr) = 0; FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = BITS_WIDTH; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &z); base = ADDRESS (&row) + SIZE (MODE (BOOL)) * (BITS_WIDTH - 1); bit = 1; for (k = BITS_WIDTH - 1; k >= 0; k--, base -= SIZE (MODE (BOOL)), bit <<= 1) { STATUS ((A68_BOOL *) base) = INIT_MASK; VALUE ((A68_BOOL *) base) = (BOOL_T) ((VALUE (&x) & bit) != 0 ? A68_TRUE : A68_FALSE); } PUSH_REF (p, z); } else if (COERCE_FROM_TO (p, MODE (LONG_BITS), MODE (ROW_BOOL)) || COERCE_FROM_TO (p, MODE (LONGLONG_BITS), MODE (ROW_BOOL)) || COERCE_FROM_TO (p, MODE (LONG_BITS), MODE (FLEX_ROW_BOOL)) || COERCE_FROM_TO (p, MODE (LONGLONG_BITS), MODE (FLEX_ROW_BOOL))) { MOID_T *m = MOID (SUB (p)); A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; int size = SIZE (m), k, width = get_mp_bits_width (m), words = get_mp_bits_words (m); unsigned *bits; BYTE_T *base; MP_T *x; ADDR_T pop_sp = stack_pointer; /* Calculate and convert BITS value */ EXECUTE_UNIT (SUB (p)); x = (MP_T *) STACK_OFFSET (-size); bits = stack_mp_bits (p, x, m); /* Make [] BOOL */ z = heap_generator (p, MODE (ROW_BOOL), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_BOOL), width * SIZE (MODE (BOOL))); DIM (&arr) = 1; MOID (&arr) = MODE (BOOL); ELEM_SIZE (&arr) = SIZE (MODE (BOOL)); SLICE_OFFSET (&arr) = 0; FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = width; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &z); base = ADDRESS (&row) + (width - 1) * SIZE (MODE (BOOL)); k = width; while (k > 0) { unsigned bit = 0x1; int j; for (j = 0; j < MP_BITS_BITS && k >= 0; j++) { STATUS ((A68_BOOL *) base) = INIT_MASK; VALUE ((A68_BOOL *) base) = (BOOL_T) ((bits[words - 1] & bit) ? A68_TRUE : A68_FALSE); base -= SIZE (MODE (BOOL)); bit <<= 1; k--; } words--; } if (CONSTANT (GINFO (SUB (p))) != NO_CONSTANT) { UNIT (&self) = genie_constant; BLOCK_GC_HANDLE (&z); CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) A68_REF_SIZE); SIZE (GINFO (p)) = A68_REF_SIZE; COPY (CONSTANT (GINFO (p)), &z, A68_REF_SIZE); } stack_pointer = pop_sp; PUSH_REF (p, z); } else { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CANNOT_WIDEN, MOID (SUB (p)), MOID (p)); exit_genie (p, A68_RUNTIME_ERROR); } return (self); #undef COERCE_FROM_TO } /** @brief Cast a jump to a PROC VOID without executing the jump. @param p Node in syntax tree. **/ static void genie_proceduring (NODE_T * p) { A68_PROCEDURE z; NODE_T *jump = SUB (p); NODE_T *q = SUB (jump); NODE_T *label = (IS (q, GOTO_SYMBOL) ? NEXT (q) : q); STATUS (&z) = INIT_MASK; NODE (&(BODY (&z))) = jump; STATIC_LINK_FOR_FRAME (ENVIRON (&z), 1 + TAG_LEX_LEVEL (TAX (label))); LOCALE (&z) = NO_HANDLE; MOID (&z) = MODE (PROC_VOID); PUSH_PROCEDURE (p, z); } /** @brief (optimised) dereference value of a unit @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_dereferencing_quick (NODE_T * p) { A68_REF *z = (A68_REF *) STACK_TOP; ADDR_T pop_sp = stack_pointer; BYTE_T *stack_top = STACK_TOP; EXECUTE_UNIT (SUB (p)); stack_pointer = pop_sp; CHECK_REF (p, *z, MOID (SUB (p))); PUSH (p, ADDRESS (z), SIZE (MOID (p))); genie_check_initialisation (p, stack_top, MOID (p)); return (GPROP (p)); } /** @brief Dereference an identifier. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_dereference_frame_identifier (NODE_T * p) { A68_REF *z; MOID_T *deref = SUB_MOID (p); BYTE_T *stack_top = STACK_TOP; FRAME_GET (z, A68_REF, p); PUSH (p, ADDRESS (z), SIZE (deref)); genie_check_initialisation (p, stack_top, deref); return (GPROP (p)); } /** @brief Dereference an identifier. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_dereference_generic_identifier (NODE_T * p) { A68_REF *z; MOID_T *deref = SUB_MOID (p); BYTE_T *stack_top = STACK_TOP; FRAME_GET (z, A68_REF, p); CHECK_REF (p, *z, MOID (SUB (p))); PUSH (p, ADDRESS (z), SIZE (deref)); genie_check_initialisation (p, stack_top, deref); return (GPROP (p)); } /** @brief Slice REF [] A to A. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_dereference_slice_name_quick (NODE_T * p) { NODE_T *q, *prim = SUB (p); A68_ARRAY *a; A68_TUPLE *t; A68_REF *z; MOID_T *ref_mode = MOID (p); MOID_T *deref_mode = SUB (ref_mode); int size = SIZE (deref_mode), row_index; ADDR_T pop_sp = stack_pointer; BYTE_T *stack_top = STACK_TOP; /* Get REF [] */ z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (prim); stack_pointer = pop_sp; CHECK_REF (p, *z, ref_mode); GET_DESCRIPTOR (a, t, DEREF (A68_ROW, z)); for (row_index = 0, q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) { A68_INT *j = (A68_INT *) STACK_TOP; int k; EXECUTE_UNIT (q); k = VALUE (j); if (k < LWB (t) || k > UPB (t)) { diagnostic_node (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (q, A68_RUNTIME_ERROR); } row_index += (SPAN (t) * k - SHIFT (t)); stack_pointer = pop_sp; } /* Push element */ PUSH (p, &((ADDRESS (&(ARRAY (a))))[ROW_ELEMENT (a, row_index)]), size); genie_check_initialisation (p, stack_top, deref_mode); return (GPROP (p)); } /** @brief Dereference SELECTION from a name. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_dereference_selection_name_quick (NODE_T * p) { NODE_T *selector = SUB (p); MOID_T *struct_mode = MOID (NEXT (selector)); MOID_T *result_mode = SUB_MOID (selector); int size = SIZE (result_mode); A68_REF *z = (A68_REF *) STACK_TOP; ADDR_T pop_sp = stack_pointer; BYTE_T *stack_top; EXECUTE_UNIT (NEXT (selector)); CHECK_REF (selector, *z, struct_mode); OFFSET (z) += OFFSET (NODE_PACK (SUB (selector))); stack_pointer = pop_sp; stack_top = STACK_TOP; PUSH (p, ADDRESS (z), size); genie_check_initialisation (p, stack_top, result_mode); return (GPROP (p)); } /** @brief Dereference name in the stack. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_dereferencing (NODE_T * p) { A68_REF z; PROP_T self; EXECUTE_UNIT_2 (SUB (p), self); POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); PUSH (p, ADDRESS (&z), SIZE (MOID (p))); genie_check_initialisation (p, STACK_OFFSET (-SIZE (MOID (p))), MOID (p)); if (UNIT (&self) == genie_frame_identifier) { if (IS_IN_FRAME (&z)) { UNIT (&self) = genie_dereference_frame_identifier; } else { UNIT (&self) = genie_dereference_generic_identifier; } UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self); } else if (UNIT (&self) == genie_slice_name_quick) { UNIT (&self) = genie_dereference_slice_name_quick; UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self); } else if (UNIT (&self) == genie_selection_name_quick) { UNIT (&self) = genie_dereference_selection_name_quick; UNIT (&PROP (GINFO (SOURCE (&self)))) = UNIT (&self); } else { UNIT (&self) = genie_dereferencing_quick; SOURCE (&self) = p; } return (self); } /** @brief Deprocedure PROC in the stack. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_deproceduring (NODE_T * p) { PROP_T self; A68_PROCEDURE *z; ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; NODE_T *proc = SUB (p); MOID_T *proc_mode = MOID (proc); UNIT (&self) = genie_deproceduring; SOURCE (&self) = p; /* Get procedure */ z = (A68_PROCEDURE *) STACK_TOP; EXECUTE_UNIT (proc); stack_pointer = pop_sp; genie_check_initialisation (p, (BYTE_T *) z, proc_mode); genie_call_procedure (p, proc_mode, proc_mode, MODE (VOID), z, pop_sp, pop_fp); STACK_DNS (p, MOID (p), frame_pointer); return (self); } /** @brief Voiden value in the stack. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_voiding (NODE_T * p) { PROP_T self, source; ADDR_T sp_for_voiding = stack_pointer; SOURCE (&self) = p; EXECUTE_UNIT_2 (SUB (p), source); stack_pointer = sp_for_voiding; if (UNIT (&source) == genie_assignation_quick) { UNIT (&self) = genie_voiding_assignation; SOURCE (&self) = SOURCE (&source); } else if (UNIT (&source) == genie_assignation_constant) { UNIT (&self) = genie_voiding_assignation_constant; SOURCE (&self) = SOURCE (&source); } else { UNIT (&self) = genie_voiding; } return (self); } /** @brief Coerce value in the stack. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_coercion (NODE_T * p) { PROP_T self; UNIT (&self) = genie_coercion; SOURCE (&self) = p; switch (ATTRIBUTE (p)) { case VOIDING: { self = genie_voiding (p); break; } case UNITING: { self = genie_uniting (p); break; } case WIDENING: { self = genie_widening (p); break; } case ROWING: { self = genie_rowing (p); break; } case DEREFERENCING: { self = genie_dereferencing (p); break; } case DEPROCEDURING: { self = genie_deproceduring (p); break; } case PROCEDURING: { genie_proceduring (p); break; } } GPROP (p) = self; return (self); } /** @brief Push argument units. @param p Node in syntax tree. @param seq Chain to link nodes into. **/ static void genie_argument (NODE_T * p, NODE_T ** seq) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { EXECUTE_UNIT (p); STACK_DNS (p, MOID (p), frame_pointer); SEQUENCE (*seq) = p; (*seq) = p; return; } else if (IS (p, TRIMMER)) { return; } else { genie_argument (SUB (p), seq); } } } /** @brief Evaluate partial call. @param p Node in syntax tree. @param pr_mode Full mode of procedure object. @param pproc Mode of resulting proc. @param pmap Mode of the locale. @param z Procedure object to call. @param pop_sp Stack pointer value to restore. @param pop_fp Frame pointer value to restore. **/ void genie_partial_call (NODE_T * p, MOID_T * pr_mode, MOID_T * pproc, MOID_T * pmap, A68_PROCEDURE z, ADDR_T pop_sp, ADDR_T pop_fp) { int voids = 0; BYTE_T *u, *v; PACK_T *s, *t; A68_REF ref; A68_HANDLE *loc; /* Get locale for the new procedure descriptor. Copy is necessary */ if (LOCALE (&z) == NO_HANDLE) { int size = 0; for (s = PACK (pr_mode); s != NO_PACK; FORWARD (s)) { size += (SIZE (MODE (BOOL)) + SIZE (MOID (s))); } ref = heap_generator (p, pr_mode, size); loc = REF_HANDLE (&ref); } else { int size = SIZE (LOCALE (&z)); ref = heap_generator (p, pr_mode, size); loc = REF_HANDLE (&ref); COPY (POINTER (loc), POINTER (LOCALE (&z)), size); } /* Move arguments from stack to locale using pmap */ u = POINTER (loc); s = PACK (pr_mode); v = STACK_ADDRESS (pop_sp); t = PACK (pmap); for (; t != NO_PACK && s != NO_PACK; FORWARD (t)) { /* Skip already initialised arguments */ while (u != NULL && VALUE ((A68_BOOL *) & u[0])) { u = &(u[SIZE (MODE (BOOL)) + SIZE (MOID (s))]); FORWARD (s); } if (u != NULL && MOID (t) == MODE (VOID)) { /* Move to next field in locale */ voids++; u = &(u[SIZE (MODE (BOOL)) + SIZE (MOID (s))]); FORWARD (s); } else { /* Move argument from stack to locale */ A68_BOOL w; STATUS (&w) = INIT_MASK; VALUE (&w) = A68_TRUE; *(A68_BOOL *) & u[0] = w; COPY (&(u[SIZE (MODE (BOOL))]), v, SIZE (MOID (t))); u = &(u[SIZE (MODE (BOOL)) + SIZE (MOID (s))]); v = &(v[SIZE (MOID (t))]); FORWARD (s); } } stack_pointer = pop_sp; LOCALE (&z) = loc; /* Is closure complete? */ if (voids == 0) { /* Closure is complete. Push locale onto the stack and call procedure body */ stack_pointer = pop_sp; u = POINTER (loc); v = STACK_ADDRESS (stack_pointer); s = PACK (pr_mode); for (; s != NO_PACK; FORWARD (s)) { int size = SIZE (MOID (s)); COPY (v, &u[SIZE (MODE (BOOL))], size); u = &(u[SIZE (MODE (BOOL)) + size]); v = &(v[SIZE (MOID (s))]); INCREMENT_STACK_POINTER (p, size); } genie_call_procedure (p, pr_mode, pproc, MODE (VOID), &z, pop_sp, pop_fp); } else { /* Closure is not complete. Return procedure body */ PUSH_PROCEDURE (p, z); } } /** @brief Closure and deproceduring of routines with PARAMSETY. @param p Node in syntax tree. @param pr_mode Full mode of procedure object. @param pproc Mode of resulting proc. @param pmap Mode of the locale. @param z Procedure object to call. @param pop_sp Stack pointer value to restore. @param pop_fp Frame pointer value to restore. **/ void genie_call_procedure (NODE_T * p, MOID_T * pr_mode, MOID_T * pproc, MOID_T * pmap, A68_PROCEDURE * z, ADDR_T pop_sp, ADDR_T pop_fp) { if (pmap != MODE (VOID) && pr_mode != pmap) { genie_partial_call (p, pr_mode, pproc, pmap, *z, pop_sp, pop_fp); } else if (STATUS (z) & STANDENV_PROC_MASK) { (void) ((*(PROCEDURE (&(BODY (z))))) (p)); } else if (STATUS (z) & SKIP_PROCEDURE_MASK) { stack_pointer = pop_sp; genie_push_undefined (p, SUB ((MOID (z)))); } else { NODE_T *body = NODE (&(BODY (z))); if (IS (body, ROUTINE_TEXT)) { NODE_T *entry = SUB (body); PACK_T *args = PACK (pr_mode); ADDR_T fp0 = 0; /* Copy arguments from stack to frame */ OPEN_PROC_FRAME (entry, ENVIRON (z)); INIT_STATIC_FRAME (entry); FRAME_DNS (frame_pointer) = pop_fp; for (; args != NO_PACK; FORWARD (args)) { int size = SIZE (MOID (args)); COPY ((FRAME_OBJECT (fp0)), STACK_ADDRESS (pop_sp + fp0), size); fp0 += size; } stack_pointer = pop_sp; ARGSIZE (GINFO (p)) = fp0; /* Interpret routine text */ if (DIM (pr_mode) > 0) { /* With PARAMETERS */ entry = NEXT (NEXT_NEXT (entry)); } else { /* Without PARAMETERS */ entry = NEXT_NEXT (entry); } EXECUTE_UNIT_TRACE (entry); if (frame_pointer == finish_frame_pointer) { change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE); } CLOSE_FRAME; STACK_DNS (p, SUB (pr_mode), frame_pointer); } else { OPEN_PROC_FRAME (body, ENVIRON (z)); INIT_STATIC_FRAME (body); FRAME_DNS (frame_pointer) = pop_fp; EXECUTE_UNIT_TRACE (body); if (frame_pointer == finish_frame_pointer) { change_masks (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK, A68_TRUE); } CLOSE_FRAME; STACK_DNS (p, SUB (pr_mode), frame_pointer); } } } /** @brief Call event routine. @param p Node in syntax tree. @param m Mode of procedure. @param proc Procedure to call. @param pop_sp Stack pointer at call. @param pop_fp Frame pointer at call. @return A propagator for this action. **/ void genie_call_event_routine (NODE_T *p, MOID_T *m, A68_PROCEDURE *proc, ADDR_T pop_sp, ADDR_T pop_fp) { if (NODE (&(BODY (proc))) != NO_NODE) { A68_PROCEDURE save = *proc; set_default_event_procedure (proc); genie_call_procedure (p, MOID (&save), m, m, &save, pop_sp, pop_fp); (*proc) = save; } } /** @brief Call PROC with arguments and push result. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_call_standenv_quick (NODE_T * p) { NODE_T *pr = SUB (p), *q = SEQUENCE (p); TAG_T *proc = TAX (SOURCE (&GPROP (pr))); /* Get arguments */ for (; q != NO_NODE; q = SEQUENCE (q)) { EXECUTE_UNIT (q); STACK_DNS (p, MOID (q), frame_pointer); } (void) ((*(PROCEDURE (proc))) (p)); return (GPROP (p)); } /** @brief Call PROC with arguments and push result. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_call_quick (NODE_T * p) { A68_PROCEDURE z; NODE_T *proc = SUB (p); ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; /* Get procedure */ EXECUTE_UNIT (proc); POP_OBJECT (proc, &z, A68_PROCEDURE); genie_check_initialisation (p, (BYTE_T *) &z, MOID (proc)); /* Get arguments */ if (SEQUENCE (p) == NO_NODE && ! STATUS_TEST (p, SEQUENCE_MASK)) { NODE_T top_seq; NODE_T *seq = &top_seq; GINFO_T g; GINFO (&top_seq) = &g; genie_argument (NEXT (proc), &seq); SEQUENCE (p) = SEQUENCE (&top_seq); STATUS_SET (p, SEQUENCE_MASK); } else { NODE_T *q = SEQUENCE (p); for (; q != NO_NODE; q = SEQUENCE (q)) { EXECUTE_UNIT (q); STACK_DNS (p, MOID (q), frame_pointer); } } genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp); return (GPROP (p)); } /** @brief Call PROC with arguments and push result. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_call (NODE_T * p) { PROP_T self; A68_PROCEDURE z; NODE_T *proc = SUB (p); ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; UNIT (&self) = genie_call_quick; SOURCE (&self) = p; /* Get procedure */ EXECUTE_UNIT (proc); POP_OBJECT (proc, &z, A68_PROCEDURE); genie_check_initialisation (p, (BYTE_T *) &z, MOID (proc)); /* Get arguments */ if (SEQUENCE (p) == NO_NODE && ! STATUS_TEST (p, SEQUENCE_MASK)) { NODE_T top_seq; NODE_T *seq = &top_seq; GINFO_T g; GINFO (&top_seq) = &g; genie_argument (NEXT (proc), &seq); SEQUENCE (p) = SEQUENCE (&top_seq); STATUS_SET (p, SEQUENCE_MASK); } else { NODE_T *q = SEQUENCE (p); for (; q != NO_NODE; q = SEQUENCE (q)) { EXECUTE_UNIT (q); } } genie_call_procedure (p, MOID (&z), PARTIAL_PROC (GINFO (proc)), PARTIAL_LOCALE (GINFO (proc)), &z, pop_sp, pop_fp); if (PARTIAL_LOCALE (GINFO (proc)) != MODE (VOID) && MOID (&z) != PARTIAL_LOCALE (GINFO (proc))) { /* skip */ ; } else if (STATUS (&z) & STANDENV_PROC_MASK) { if (UNIT (&GPROP (proc)) == genie_identifier_standenv_proc) { UNIT (&self) = genie_call_standenv_quick; } } return (self); } /** @brief Construct a descriptor "ref_new" for a trim of "ref_old". @param p Node in syntax tree. @param ref_new New descriptor. @param ref_old Old descriptor. @param offset Calculates the offset of the trim. **/ static void genie_trimmer (NODE_T * p, BYTE_T * *ref_new, BYTE_T * *ref_old, int *offset) { if (p != NO_NODE) { if (IS (p, UNIT)) { A68_INT k; A68_TUPLE *t; EXECUTE_UNIT (p); POP_OBJECT (p, &k, A68_INT); t = (A68_TUPLE *) * ref_old; CHECK_INDEX (p, &k, t); (*offset) += SPAN (t) * VALUE (&k) - SHIFT (t); /* * (*ref_old) += SIZE_AL (A68_TUPLE); */ (*ref_old) += sizeof (A68_TUPLE); } else if (IS (p, TRIMMER)) { A68_INT k; NODE_T *q; int L, U, D; A68_TUPLE *old_tup = (A68_TUPLE *) * ref_old; A68_TUPLE *new_tup = (A68_TUPLE *) * ref_new; /* TRIMMER is (l:u@r) with all units optional or (empty) */ q = SUB (p); if (q == NO_NODE) { L = LWB (old_tup); U = UPB (old_tup); D = 0; } else { BOOL_T absent = A68_TRUE; /* Lower index */ if (q != NO_NODE && IS (q, UNIT)) { EXECUTE_UNIT (q); POP_OBJECT (p, &k, A68_INT); if (VALUE (&k) < LWB (old_tup)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } L = VALUE (&k); FORWARD (q); absent = A68_FALSE; } else { L = LWB (old_tup); } if (q != NO_NODE && (IS (q, COLON_SYMBOL) || IS (q, DOTDOT_SYMBOL))) { FORWARD (q); absent = A68_FALSE; } /* Upper index */ if (q != NO_NODE && IS (q, UNIT)) { EXECUTE_UNIT (q); POP_OBJECT (p, &k, A68_INT); if (VALUE (&k) > UPB (old_tup)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } U = VALUE (&k); FORWARD (q); absent = A68_FALSE; } else { U = UPB (old_tup); } if (q != NO_NODE && IS (q, AT_SYMBOL)) { FORWARD (q); } /* Revised lower bound */ if (q != NO_NODE && IS (q, UNIT)) { EXECUTE_UNIT (q); POP_OBJECT (p, &k, A68_INT); D = L - VALUE (&k); FORWARD (q); } else { D = (absent ? 0 : L - 1); } } LWB (new_tup) = L - D; UPB (new_tup) = U - D; /* (L - D) + (U - L) */ SPAN (new_tup) = SPAN (old_tup); SHIFT (new_tup) = SHIFT (old_tup) - D * SPAN (new_tup); (*ref_old) += sizeof (A68_TUPLE); (*ref_new) += sizeof (A68_TUPLE); } else { genie_trimmer (SUB (p), ref_new, ref_old, offset); genie_trimmer (NEXT (p), ref_new, ref_old, offset); } } } /** @brief Calculation of subscript. @param p Node in syntax tree. @param tup Pointer to TUPLE variable. @param sum Calculates the index of the subscript. @param seq Chain to link nodes into. **/ void genie_subscript (NODE_T * p, A68_TUPLE ** tup, int *sum, NODE_T ** seq) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case UNIT: { A68_INT *k; A68_TUPLE *t = *tup; EXECUTE_UNIT (p); POP_ADDRESS (p, k, A68_INT); CHECK_INDEX (p, k, t); (*tup)++; (*sum) += (SPAN (t) * VALUE (k) - SHIFT (t)); SEQUENCE (*seq) = p; (*seq) = p; return; } case GENERIC_ARGUMENT: case GENERIC_ARGUMENT_LIST: { genie_subscript (SUB (p), tup, sum, seq); } } } } /** @brief Slice REF [] A to REF A. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_slice_name_quick (NODE_T * p) { NODE_T *q, *pr = SUB (p); A68_REF *z = (A68_REF *) STACK_TOP; A68_ARRAY *a; ADDR_T pop_sp, scope; A68_TUPLE *t; int sindex; /* Get row and save row from garbage collector */ EXECUTE_UNIT (pr); CHECK_REF (p, *z, MOID (SUB (p))); GET_DESCRIPTOR (a, t, DEREF (A68_ROW, z)); pop_sp = stack_pointer; for (sindex = 0, q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) { A68_INT *j = (A68_INT *) STACK_TOP; int k; EXECUTE_UNIT (q); k = VALUE (j); if (k < LWB (t) || k > UPB (t)) { diagnostic_node (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (q, A68_RUNTIME_ERROR); } sindex += (SPAN (t) * k - SHIFT (t)); stack_pointer = pop_sp; } /* Leave reference to element on the stack, preserving scope */ scope = REF_SCOPE (z); *z = ARRAY (a); OFFSET (z) += ROW_ELEMENT (a, sindex); REF_SCOPE (z) = scope; return (GPROP (p)); } /** @brief Push slice of a rowed object. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_slice (NODE_T * p) { PROP_T self, primary; ADDR_T pop_sp, scope = PRIMAL_SCOPE; BOOL_T slice_of_name = (BOOL_T) (IS (MOID (SUB (p)), REF_SYMBOL)); MOID_T *result_mode = slice_of_name ? SUB_MOID (p) : MOID (p); NODE_T *indexer = NEXT_SUB (p); UNIT (&self) = genie_slice; SOURCE (&self) = p; pop_sp = stack_pointer; /* Get row */ EXECUTE_UNIT_2 (SUB (p), primary); /* In case of slicing a REF [], we need the [] internally, so dereference */ if (slice_of_name) { A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); scope = REF_SCOPE (&z); PUSH_REF (p, * DEREF (A68_REF, &z)); } if (ANNOTATION (indexer) == SLICE) { /* SLICING subscripts one element from an array */ A68_REF z; A68_ARRAY *a; A68_TUPLE *t; int sindex; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); GET_DESCRIPTOR (a, t, &z); if (SEQUENCE (p) == NO_NODE && ! STATUS_TEST (p, SEQUENCE_MASK)) { NODE_T top_seq; NODE_T *seq = &top_seq; GINFO_T g; GINFO (&top_seq) = &g; sindex = 0; genie_subscript (indexer, &t, &sindex, &seq); SEQUENCE (p) = SEQUENCE (&top_seq); STATUS_SET (p, SEQUENCE_MASK); } else { NODE_T *q; for (sindex = 0, q = SEQUENCE (p); q != NO_NODE; t++, q = SEQUENCE (q)) { A68_INT *j = (A68_INT *) STACK_TOP; int k; EXECUTE_UNIT (q); k = VALUE (j); if (k < LWB (t) || k > UPB (t)) { diagnostic_node (A68_RUNTIME_ERROR, q, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (q, A68_RUNTIME_ERROR); } sindex += (SPAN (t) * k - SHIFT (t)); } } /* Slice of a name yields a name */ stack_pointer = pop_sp; if (slice_of_name) { A68_REF name = ARRAY (a); OFFSET (&name) += ROW_ELEMENT (a, sindex); REF_SCOPE (&name) = scope; PUSH_REF (p, name); if (STATUS_TEST (p, SEQUENCE_MASK)) { UNIT (&self) = genie_slice_name_quick; SOURCE (&self) = p; } } else { BYTE_T *stack_top = STACK_TOP; PUSH (p, &((ADDRESS (&(ARRAY (a))))[ROW_ELEMENT (a, sindex)]), SIZE (result_mode)); genie_check_initialisation (p, stack_top, result_mode); } return (self); } else if (ANNOTATION (indexer) == TRIMMER) { /* Trimming selects a subarray from an array */ int offset; A68_REF z, ref_desc_copy; A68_ARRAY *old_des, *new_des; BYTE_T *ref_new, *ref_old; ref_desc_copy = heap_generator (p, MOID (p), SIZE_AL (A68_ARRAY) + DIM (DEFLEX (result_mode)) * SIZE_AL (A68_TUPLE)); /* Get descriptor */ POP_REF (p, &z); /* Get indexer */ CHECK_REF (p, z, MOID (SUB (p))); old_des = DEREF (A68_ARRAY, &z); new_des = DEREF (A68_ARRAY, &ref_desc_copy); ref_old = ADDRESS (&z) + SIZE_AL (A68_ARRAY); ref_new = ADDRESS (&ref_desc_copy) + SIZE_AL (A68_ARRAY); DIM (new_des) = DIM (DEFLEX (result_mode)); MOID (new_des) = MOID (old_des); ELEM_SIZE (new_des) = ELEM_SIZE (old_des); offset = SLICE_OFFSET (old_des); genie_trimmer (indexer, &ref_new, &ref_old, &offset); SLICE_OFFSET (new_des) = offset; FIELD_OFFSET (new_des) = FIELD_OFFSET (old_des); ARRAY (new_des) = ARRAY (old_des); /* Trim of a name is a name */ if (slice_of_name) { A68_REF ref_new2 = heap_generator (p, MOID (p), A68_REF_SIZE); * DEREF (A68_REF, &ref_new2) = ref_desc_copy; REF_SCOPE (&ref_new2) = scope; PUSH_REF (p, ref_new2); } else { PUSH_REF (p, ref_desc_copy); } return (self); } else { ABEND (A68_TRUE, "impossible state in genie_slice", NO_TEXT); return (self); } } /** @brief Push value of denotation. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_denotation (NODE_T * p) { MOID_T *moid = MOID (p); PROP_T self; UNIT (&self) = genie_denotation; SOURCE (&self) = p; if (moid == MODE (INT)) { /* INT denotation */ A68_INT z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } UNIT (&self) = genie_constant; STATUS (&z) = INIT_MASK; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE (MODE (INT))); SIZE (GINFO (p)) = SIZE (MODE (INT)); COPY (CONSTANT (GINFO (p)), &z, SIZE (MODE (INT))); PUSH_PRIMITIVE (p, VALUE ((A68_INT *) (CONSTANT (GINFO (p)))), A68_INT); } else if (moid == MODE (REAL)) { /* REAL denotation */ A68_REAL z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } STATUS (&z) = INIT_MASK; UNIT (&self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_AL (A68_REAL)); SIZE (GINFO (p)) = SIZE_AL (A68_REAL); COPY (CONSTANT (GINFO (p)), &z, SIZE_AL (A68_REAL)); PUSH_PRIMITIVE (p, VALUE ((A68_REAL *) (CONSTANT (GINFO (p)))), A68_REAL); } else if (moid == MODE (LONG_INT) || moid == MODE (LONGLONG_INT)) { /* [LONG] LONG INT denotation */ int digits = DIGITS (moid); MP_T *z; int size = SIZE (moid); NODE_T *number; if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) { number = NEXT_SUB (p); } else { number = SUB (p); } STACK_MP (z, p, digits); if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } z[0] = (MP_T) INIT_MASK; UNIT (&self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), z, size); } else if (moid == MODE (LONG_REAL) || moid == MODE (LONGLONG_REAL)) { /* [LONG] LONG REAL denotation */ int digits = DIGITS (moid); MP_T *z; int size = SIZE (moid); NODE_T *number; if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) { number = NEXT_SUB (p); } else { number = SUB (p); } STACK_MP (z, p, digits); if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } z[0] = (MP_T) INIT_MASK; UNIT (&self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), z, size); } else if (moid == MODE (BITS)) { /* BITS denotation */ A68_BITS z; NODE_T *s = IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p); if (genie_string_to_value_internal (p, moid, NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } UNIT (&self) = genie_constant; STATUS (&z) = INIT_MASK; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) SIZE_AL (A68_BITS)); SIZE (GINFO (p)) = SIZE_AL (A68_BITS); COPY (CONSTANT (GINFO (p)), &z, SIZE_AL (A68_BITS)); PUSH_PRIMITIVE (p, VALUE ((A68_BITS *) (CONSTANT (GINFO (p)))), A68_BITS); } else if (moid == MODE (LONG_BITS) || moid == MODE (LONGLONG_BITS)) { /* [LONG] LONG BITS denotation */ int digits = DIGITS (moid); MP_T *z; int size = SIZE (moid); NODE_T *number; if (IS (SUB (p), SHORTETY) || IS (SUB (p), LONGETY)) { number = NEXT_SUB (p); } else { number = SUB (p); } STACK_MP (z, p, digits); if (genie_string_to_value_internal (p, moid, NSYMBOL (number), (BYTE_T *) z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_IN_DENOTATION, moid); exit_genie (p, A68_RUNTIME_ERROR); } z[0] = (MP_T) INIT_MASK; UNIT (&self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), z, size); } else if (moid == MODE (BOOL)) { /* BOOL denotation */ A68_BOOL z; ASSERT (genie_string_to_value_internal (p, MODE (BOOL), NSYMBOL (p), (BYTE_T *) & z) == A68_TRUE); PUSH_PRIMITIVE (p, VALUE (&z), A68_BOOL); } else if (moid == MODE (CHAR)) { /* CHAR denotation */ PUSH_PRIMITIVE (p, TO_UCHAR (NSYMBOL (p)[0]), A68_CHAR); } else if (moid == MODE (ROW_CHAR)) { /* [] CHAR denotation - permanent string in the heap */ A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; z = c_to_a_string (p, NSYMBOL (p), DEFAULT_WIDTH); GET_DESCRIPTOR (arr, tup, &z); BLOCK_GC_HANDLE (&z); BLOCK_GC_HANDLE (&(ARRAY (arr))); UNIT (&self) = genie_constant; CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) A68_REF_SIZE); SIZE (GINFO (p)) = A68_REF_SIZE; COPY (CONSTANT (GINFO (p)), &z, A68_REF_SIZE); PUSH_REF (p, *(A68_REF *) (CONSTANT (GINFO (p)))); } else if (moid == MODE (VOID)) { /* VOID denotation: EMPTY */ ; } return (self); } /** @brief Push a local identifier. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_frame_identifier (NODE_T * p) { BYTE_T *z; FRAME_GET (z, BYTE_T, p); PUSH (p, z, SIZE (MOID (p))); return (GPROP (p)); } /** @brief Push standard environ routine as PROC. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_identifier_standenv_proc (NODE_T * p) { A68_PROCEDURE z; TAG_T *q = TAX (p); STATUS (&z) = (STATUS_MASK) (INIT_MASK | STANDENV_PROC_MASK); PROCEDURE (&(BODY (&z))) = PROCEDURE (q); ENVIRON (&z) = 0; LOCALE (&z) = NO_HANDLE; MOID (&z) = MOID (p); PUSH_PROCEDURE (p, z); return (GPROP (p)); } /** @brief (optimised) push identifier from standard environ @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_identifier_standenv (NODE_T * p) { (void) ((*(PROCEDURE (TAX (p)))) (p)); return (GPROP (p)); } /** @brief Push identifier onto the stack. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_identifier (NODE_T * p) { static PROP_T self; TAG_T *q = TAX (p); SOURCE (&self) = p; if (A68G_STANDENV_PROC (q)) { if (IS (MOID (q), PROC_SYMBOL)) { (void) genie_identifier_standenv_proc (p); UNIT (&self) = genie_identifier_standenv_proc; } else { (void) genie_identifier_standenv (p); UNIT (&self) = genie_identifier_standenv; } } else if (STATUS_TEST (q, CONSTANT_MASK)) { int size = SIZE (MOID (p)); BYTE_T *sp_0 = STACK_TOP; (void) genie_frame_identifier (p); CONSTANT (GINFO (p)) = (void *) get_heap_space ((size_t) size); SIZE (GINFO (p)) = size; COPY (CONSTANT (GINFO (p)), (void *) sp_0, size); UNIT (&self) = genie_constant; } else { (void) genie_frame_identifier (p); UNIT (&self) = genie_frame_identifier; } return (self); } /** @brief Push result of cast (coercions are deeper in the tree). @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_cast (NODE_T * p) { PROP_T self; EXECUTE_UNIT (NEXT_SUB (p)); UNIT (&self) = genie_cast; SOURCE (&self) = p; return (self); } /** @brief Execute assertion. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_assertion (NODE_T * p) { PROP_T self; if (STATUS_TEST (p, ASSERT_MASK)) { A68_BOOL z; EXECUTE_UNIT (NEXT_SUB (p)); POP_OBJECT (p, &z, A68_BOOL); if (VALUE (&z) == A68_FALSE) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_FALSE_ASSERTION); exit_genie (p, A68_RUNTIME_ERROR); } } UNIT (&self) = genie_assertion; SOURCE (&self) = p; return (self); } /** @brief Push format text. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_format_text (NODE_T * p) { static PROP_T self; A68_FORMAT z = *(A68_FORMAT *) (FRAME_OBJECT (OFFSET (TAX (p)))); PUSH_FORMAT (p, z); UNIT (&self) = genie_format_text; SOURCE (&self) = p; return (self); } /** @brief SELECTION from a value @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_selection_value_quick (NODE_T * p) { NODE_T *selector = SUB (p); MOID_T *result_mode = MOID (selector); ADDR_T old_stack_pointer = stack_pointer; int size = SIZE (result_mode); int offset = OFFSET (NODE_PACK (SUB (selector))); EXECUTE_UNIT (NEXT (selector)); stack_pointer = old_stack_pointer; if (offset > 0) { MOVE (STACK_TOP, STACK_OFFSET (offset), (unsigned) size); genie_check_initialisation (p, STACK_TOP, result_mode); } INCREMENT_STACK_POINTER (selector, size); return (GPROP (p)); } /** @brief SELECTION from a name @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_selection_name_quick (NODE_T * p) { NODE_T *selector = SUB (p); MOID_T *struct_mode = MOID (NEXT (selector)); A68_REF *z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (NEXT (selector)); CHECK_REF (selector, *z, struct_mode); OFFSET (z) += OFFSET (NODE_PACK (SUB (selector))); return (GPROP (p)); } /** @brief Push selection from secondary. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_selection (NODE_T * p) { NODE_T *selector = SUB (p); PROP_T self; MOID_T *struct_mode = MOID (NEXT (selector)), *result_mode = MOID (selector); BOOL_T selection_of_name = (BOOL_T) (IS (struct_mode, REF_SYMBOL)); SOURCE (&self) = p; UNIT (&self) = genie_selection; EXECUTE_UNIT (NEXT (selector)); /* Multiple selections */ if (selection_of_name && (IS (SUB (struct_mode), FLEX_SYMBOL) || IS (SUB (struct_mode), ROW_SYMBOL))) { A68_REF *row1, row2, row3; int dims, desc_size; POP_ADDRESS (selector, row1, A68_REF); CHECK_REF (p, *row1, struct_mode); row1 = DEREF (A68_REF, row1); dims = DIM (DEFLEX (SUB (struct_mode))); desc_size = SIZE_AL (A68_ARRAY) + dims * SIZE_AL (A68_TUPLE); row2 = heap_generator (selector, result_mode, desc_size); MOVE (ADDRESS (&row2), DEREF (BYTE_T, row1), (unsigned) desc_size); MOID ((DEREF (A68_ARRAY, &row2))) = SUB_SUB (result_mode); FIELD_OFFSET (DEREF (A68_ARRAY, &row2)) += OFFSET (NODE_PACK (SUB (selector))); row3 = heap_generator (selector, result_mode, A68_REF_SIZE); * DEREF (A68_REF, &row3) = row2; PUSH_REF (selector, row3); UNIT (&self) = genie_selection; } else if (struct_mode != NO_MOID && (IS (struct_mode, FLEX_SYMBOL) || IS (struct_mode, ROW_SYMBOL))) { A68_REF *row1, row2; int dims, desc_size; POP_ADDRESS (selector, row1, A68_REF); dims = DIM (DEFLEX (struct_mode)); desc_size = SIZE_AL (A68_ARRAY) + dims * SIZE_AL (A68_TUPLE); row2 = heap_generator (selector, result_mode, desc_size); MOVE (ADDRESS (&row2), DEREF (BYTE_T, row1), (unsigned) desc_size); MOID ((DEREF (A68_ARRAY, &row2))) = SUB (result_mode); FIELD_OFFSET (DEREF (A68_ARRAY, &row2)) += OFFSET (NODE_PACK (SUB (selector))); PUSH_REF (selector, row2); UNIT (&self) = genie_selection; } /* Normal selections */ else if (selection_of_name && IS (SUB (struct_mode), STRUCT_SYMBOL)) { A68_REF *z = (A68_REF *) (STACK_OFFSET (-A68_REF_SIZE)); CHECK_REF (selector, *z, struct_mode); OFFSET (z) += OFFSET (NODE_PACK (SUB (selector))); UNIT (&self) = genie_selection_name_quick; } else if (IS (struct_mode, STRUCT_SYMBOL)) { DECREMENT_STACK_POINTER (selector, SIZE (struct_mode)); MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (SUB (selector)))), (unsigned) SIZE (result_mode)); genie_check_initialisation (p, STACK_TOP, result_mode); INCREMENT_STACK_POINTER (selector, SIZE (result_mode)); UNIT (&self) = genie_selection_value_quick; } return (self); } /** @brief Push selection from primary. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_field_selection (NODE_T * p) { PROP_T self; ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; NODE_T *entry = p; A68_REF *z = (A68_REF *) STACK_TOP; A68_PROCEDURE *w = (A68_PROCEDURE *) STACK_TOP; SOURCE (&self) = entry; UNIT (&self) = genie_field_selection; EXECUTE_UNIT (SUB (p)); for (p = SEQUENCE (SUB (p)); p != NO_NODE; p = SEQUENCE (p)) { BOOL_T coerce = A68_TRUE; MOID_T *m = MOID (p); MOID_T *result_mode = MOID (NODE_PACK (p)); while (coerce) { if (IS (m, REF_SYMBOL) && ISNT (SUB (m), STRUCT_SYMBOL)) { int size = SIZE (SUB (m)); stack_pointer = pop_sp; CHECK_REF (p, *z, m); PUSH (p, ADDRESS (z), size); genie_check_initialisation (p, STACK_OFFSET (-size), MOID (p)); m = SUB (m); } else if (IS (m, PROC_SYMBOL)) { genie_check_initialisation (p, (BYTE_T *) w, m); genie_call_procedure (p, m, m, MODE (VOID), w, pop_sp, pop_fp); STACK_DNS (p, MOID (p), frame_pointer); m = SUB (m); } else { coerce = A68_FALSE; } } if (IS (m, REF_SYMBOL) && IS (SUB (m), STRUCT_SYMBOL)) { CHECK_REF (p, *z, m); OFFSET (z) += OFFSET (NODE_PACK (p)); } else if (IS (m, STRUCT_SYMBOL)) { stack_pointer = pop_sp; MOVE (STACK_TOP, STACK_OFFSET (OFFSET (NODE_PACK (p))), (unsigned) SIZE (result_mode)); INCREMENT_STACK_POINTER (p, SIZE (result_mode)); } } return (self); } /** @brief Call operator. @param p Node in syntax tree. @param pop_sp Stack pointer value to restore. **/ void genie_call_operator (NODE_T * p, ADDR_T pop_sp) { A68_PROCEDURE *z; ADDR_T pop_fp = frame_pointer; MOID_T *pr_mode = MOID (TAX (p)); FRAME_GET (z, A68_PROCEDURE, p); genie_call_procedure (p, pr_mode, MOID (z), pr_mode, z, pop_sp, pop_fp); STACK_DNS (p, SUB (pr_mode), frame_pointer); } /** @brief Push result of monadic formula OP "u". @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_monadic (NODE_T * p) { NODE_T *op = SUB (p); NODE_T *u = NEXT (op); PROP_T self; ADDR_T sp = stack_pointer; EXECUTE_UNIT (u); STACK_DNS (u, MOID (u), frame_pointer); if (PROCEDURE (TAX (op)) != NO_GPROC) { (void) ((*(PROCEDURE (TAX (op)))) (op)); } else { genie_call_operator (op, sp); } UNIT (&self) = genie_monadic; SOURCE (&self) = p; return (self); } /** @brief Push result of formula. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_dyadic_quick (NODE_T * p) { NODE_T *u = SUB (p); NODE_T *op = NEXT (u); NODE_T *v = NEXT (op); EXECUTE_UNIT (u); STACK_DNS (u, MOID (u), frame_pointer); EXECUTE_UNIT (v); STACK_DNS (v, MOID (v), frame_pointer); (void) ((*(PROCEDURE (TAX (op)))) (op)); return (GPROP (p)); } /** @brief Push result of formula. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_dyadic (NODE_T * p) { NODE_T *u = SUB (p); NODE_T *op = NEXT (u); NODE_T *v = NEXT (op); ADDR_T pop_sp = stack_pointer; EXECUTE_UNIT (u); STACK_DNS (u, MOID (u), frame_pointer); EXECUTE_UNIT (v); STACK_DNS (v, MOID (v), frame_pointer); if (PROCEDURE (TAX (op)) != NO_GPROC) { (void) ((*(PROCEDURE (TAX (op)))) (op)); } else { genie_call_operator (op, pop_sp); } return (GPROP (p)); } /** @brief Push result of formula. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_formula (NODE_T * p) { PROP_T self, lhs, rhs; NODE_T *u = SUB (p); NODE_T *op = NEXT (u); ADDR_T pop_sp = stack_pointer; UNIT (&self) = genie_formula; SOURCE (&self) = p; EXECUTE_UNIT_2 (u, lhs); STACK_DNS (u, MOID (u), frame_pointer); if (op != NO_NODE) { NODE_T *v = NEXT (op); GPROC *proc = PROCEDURE (TAX (op)); EXECUTE_UNIT_2 (v, rhs); STACK_DNS (v, MOID (v), frame_pointer); UNIT (&self) = genie_dyadic; if (proc != NO_GPROC) { (void) ((*(proc)) (op)); UNIT (&self) = genie_dyadic_quick; } else { genie_call_operator (op, pop_sp); } return (self); } else if (UNIT (&lhs) == genie_monadic) { return (lhs); } return (self); } /** @brief Push NIL. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_nihil (NODE_T * p) { PROP_T self; PUSH_REF (p, nil_ref); UNIT (&self) = genie_nihil; SOURCE (&self) = p; return (self); } /** @brief Assign a value to a name and voiden. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_voiding_assignation_constant (NODE_T * p) { NODE_T *dst = SUB (p); NODE_T *src = SOURCE (&PROP (GINFO (NEXT_NEXT (dst)))); ADDR_T pop_sp = stack_pointer; A68_REF *z = (A68_REF *) STACK_TOP; PROP_T self; UNIT (&self) = genie_voiding_assignation_constant; SOURCE (&self) = p; EXECUTE_UNIT (dst); CHECK_REF (p, *z, MOID (p)); COPY (ADDRESS (z), CONSTANT (GINFO (src)), SIZE (GINFO (src))); stack_pointer = pop_sp; return (self); } /** @brief Assign a value to a name and voiden. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_voiding_assignation (NODE_T * p) { NODE_T *dst = SUB (p); NODE_T *src = NEXT_NEXT (dst); MOID_T *src_mode = SUB_MOID (dst); ADDR_T pop_sp = stack_pointer, pop_fp = FRAME_DNS (frame_pointer); A68_REF z; BOOL_T caution; PROP_T self; UNIT (&self) = genie_voiding_assignation; SOURCE (&self) = p; EXECUTE_UNIT (dst); POP_OBJECT (p, &z, A68_REF); caution = (BOOL_T) IS_IN_HEAP (&z); if (caution) { } CHECK_REF (p, z, MOID (p)); FRAME_DNS (frame_pointer) = REF_SCOPE (&z); EXECUTE_UNIT (src); STACK_DNS (src, src_mode, REF_SCOPE (&z)); FRAME_DNS (frame_pointer) = pop_fp; stack_pointer = pop_sp; if (HAS_ROWS (src_mode)) { genie_clone_stack (p, src_mode, &z, &z); } else { COPY_ALIGNED (ADDRESS (&z), STACK_TOP, SIZE (src_mode)); } if (caution) { } return (self); } /** @brief Assign a value to a name and push the name. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_assignation_constant (NODE_T * p) { NODE_T *dst = SUB (p); NODE_T *src = SOURCE (&PROP (GINFO (NEXT_NEXT (dst)))); A68_REF *z = (A68_REF *) STACK_TOP; PROP_T self; UNIT (&self) = genie_assignation_constant; SOURCE (&self) = p; EXECUTE_UNIT (dst); CHECK_REF (p, *z, MOID (p)); COPY (ADDRESS (z), CONSTANT (GINFO (src)), SIZE (GINFO (src))); return (self); } /** @brief Assign a value to a name and push the name. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_assignation_quick (NODE_T * p) { PROP_T self; NODE_T *dst = SUB (p); NODE_T *src = NEXT_NEXT (dst); MOID_T *src_mode = SUB_MOID (dst); int size = SIZE (src_mode); ADDR_T pop_fp = FRAME_DNS (frame_pointer); A68_REF *z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (dst); CHECK_REF (p, *z, MOID (p)); FRAME_DNS (frame_pointer) = REF_SCOPE (z); EXECUTE_UNIT (src); STACK_DNS (src, src_mode, REF_SCOPE (z)); FRAME_DNS (frame_pointer) = pop_fp; DECREMENT_STACK_POINTER (p, size); if (HAS_ROWS (src_mode)) { genie_clone_stack (p, src_mode, z, z); } else { COPY (ADDRESS (z), STACK_TOP, size); } UNIT (&self) = genie_assignation_quick; SOURCE (&self) = p; return (self); } /** @brief Assign a value to a name and push the name. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_assignation (NODE_T * p) { PROP_T self, srp; NODE_T *dst = SUB (p); NODE_T *src = NEXT_NEXT (dst); MOID_T *src_mode = SUB_MOID (dst); int size = SIZE (src_mode); ADDR_T pop_fp = FRAME_DNS (frame_pointer); A68_REF *z = (A68_REF *) STACK_TOP; EXECUTE_UNIT (dst); CHECK_REF (p, *z, MOID (p)); FRAME_DNS (frame_pointer) = REF_SCOPE (z); EXECUTE_UNIT_2 (src, srp); STACK_DNS (src, src_mode, REF_SCOPE (z)); FRAME_DNS (frame_pointer) = pop_fp; DECREMENT_STACK_POINTER (p, size); if (HAS_ROWS (src_mode)) { genie_clone_stack (p, src_mode, z, z); } else { COPY (ADDRESS (z), STACK_TOP, size); } if (UNIT (&srp) == genie_constant) { UNIT (&self) = genie_assignation_constant; } else { UNIT (&self) = genie_assignation_quick; } SOURCE (&self) = p; return (self); } /** @brief Push equality of two REFs. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_identity_relation (NODE_T * p) { PROP_T self; NODE_T *lhs = SUB (p), *rhs = NEXT_NEXT (lhs); A68_REF x, y; UNIT (&self) = genie_identity_relation; SOURCE (&self) = p; EXECUTE_UNIT (lhs); POP_REF (p, &y); EXECUTE_UNIT (rhs); POP_REF (p, &x); if (IS (NEXT_SUB (p), IS_SYMBOL)) { PUSH_PRIMITIVE (p, (BOOL_T) (ADDRESS (&x) == ADDRESS (&y)), A68_BOOL); } else { PUSH_PRIMITIVE (p, (BOOL_T) (ADDRESS (&x) != ADDRESS (&y)), A68_BOOL); } return (self); } /** @brief Push result of ANDF. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_and_function (NODE_T * p) { PROP_T self; A68_BOOL x; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &x, A68_BOOL); if (VALUE (&x) == A68_TRUE) { EXECUTE_UNIT (NEXT_NEXT (SUB (p))); } else { PUSH_PRIMITIVE (p, A68_FALSE, A68_BOOL); } UNIT (&self) = genie_and_function; SOURCE (&self) = p; return (self); } /** @brief Push result of ORF. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_or_function (NODE_T * p) { PROP_T self; A68_BOOL x; EXECUTE_UNIT (SUB (p)); POP_OBJECT (p, &x, A68_BOOL); if (VALUE (&x) == A68_FALSE) { EXECUTE_UNIT (NEXT_NEXT (SUB (p))); } else { PUSH_PRIMITIVE (p, A68_TRUE, A68_BOOL); } UNIT (&self) = genie_or_function; SOURCE (&self) = p; return (self); } /** @brief Push routine text. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_routine_text (NODE_T * p) { static PROP_T self; A68_PROCEDURE z = *(A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (p)))); PUSH_PROCEDURE (p, z); UNIT (&self) = genie_routine_text; SOURCE (&self) = p; return (self); } /** @brief Push an undefined value of the required mode. @param p Node in syntax tree. @param u Mode of object to push. **/ void genie_push_undefined (NODE_T * p, MOID_T * u) { /* For primitive modes we push an initialised value */ if (u == MODE (VOID)) { /* skip */ ; } else if (u == MODE (INT)) { PUSH_PRIMITIVE (p, 1, A68_INT); /* Because users write [~] INT ! */ } else if (u == MODE (REAL)) { PUSH_PRIMITIVE (p, (rng_53_bit ()), A68_REAL); } else if (u == MODE (BOOL)) { PUSH_PRIMITIVE (p, (BOOL_T) (rng_53_bit () < 0.5), A68_BOOL); } else if (u == MODE (CHAR)) { PUSH_PRIMITIVE (p, (char) (32 + 96 * rng_53_bit ()), A68_CHAR); } else if (u == MODE (BITS)) { PUSH_PRIMITIVE (p, (unsigned) (rng_53_bit () * A68_MAX_UNT), A68_BITS); } else if (u == MODE (COMPLEX)) { PUSH_COMPLEX (p, rng_53_bit (), rng_53_bit ()); } else if (u == MODE (BYTES)) { PUSH_BYTES (p, "SKIP"); } else if (u == MODE (LONG_BYTES)) { PUSH_LONG_BYTES (p, "SKIP"); } else if (u == MODE (STRING)) { PUSH_REF (p, empty_string (p)); } else if (u == MODE (LONG_INT) || u == MODE (LONGLONG_INT)) { int digits = DIGITS (u); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; } else if (u == MODE (LONG_REAL) || u == MODE (LONGLONG_REAL)) { int digits = DIGITS (u); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; } else if (u == MODE (LONG_BITS) || u == MODE (LONGLONG_BITS)) { int digits = DIGITS (u); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; } else if (u == MODE (LONG_COMPLEX) || u == MODE (LONGLONG_COMPLEX)) { int digits = DIGITSC (u); MP_T *z; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; STACK_MP (z, p, digits); SET_MP_ZERO (z, digits); z[0] = (MP_T) INIT_MASK; } else if (IS (u, REF_SYMBOL)) { /* All REFs are NIL */ PUSH_REF (p, nil_ref); } else if (IS (u, ROW_SYMBOL) || IS (u, FLEX_SYMBOL)) { /* [] AMODE or FLEX [] AMODE */ A68_REF er = empty_row (p, u); STATUS (&er) |= SKIP_ROW_MASK; PUSH_REF (p, er); } else if (IS (u, STRUCT_SYMBOL)) { /* STRUCT */ PACK_T *v; for (v = PACK (u); v != NO_PACK; FORWARD (v)) { genie_push_undefined (p, MOID (v)); } } else if (IS (u, UNION_SYMBOL)) { /* UNION */ ADDR_T sp = stack_pointer; PUSH_UNION (p, MOID (PACK (u))); genie_push_undefined (p, MOID (PACK (u))); stack_pointer = sp + SIZE (u); } else if (IS (u, PROC_SYMBOL)) { /* PROC */ A68_PROCEDURE z; STATUS (&z) = (STATUS_MASK) (INIT_MASK | SKIP_PROCEDURE_MASK); (NODE (&BODY (&z))) = NO_NODE; ENVIRON (&z) = 0; LOCALE (&z) = NO_HANDLE; MOID (&z) = u; PUSH_PROCEDURE (p, z); } else if (u == MODE (FORMAT)) { /* FORMAT etc. - what arbitrary FORMAT could mean anything at all? */ A68_FORMAT z; STATUS (&z) = (STATUS_MASK) (INIT_MASK | SKIP_FORMAT_MASK); BODY (&z) = NO_NODE; ENVIRON (&z) = 0; PUSH_FORMAT (p, z); } else if (u == MODE (SIMPLOUT)) { ADDR_T sp = stack_pointer; PUSH_UNION (p, MODE (STRING)); PUSH_REF (p, c_to_a_string (p, "SKIP", DEFAULT_WIDTH)); stack_pointer = sp + SIZE (u); } else if (u == MODE (SIMPLIN)) { ADDR_T sp = stack_pointer; PUSH_UNION (p, MODE (REF_STRING)); genie_push_undefined (p, MODE (REF_STRING)); stack_pointer = sp + SIZE (u); } else if (u == MODE (REF_FILE)) { PUSH_REF (p, skip_file); } else if (u == MODE (FILE)) { A68_REF *z = (A68_REF *) STACK_TOP; int size = SIZE (MODE (FILE)); ADDR_T pop_sp = stack_pointer; PUSH_REF (p, skip_file); stack_pointer = pop_sp; PUSH (p, ADDRESS (z), size); } else if (u == MODE (CHANNEL)) { PUSH_OBJECT (p, skip_channel, A68_CHANNEL); } else if (u == MODE (PIPE)) { genie_push_undefined (p, MODE (REF_FILE)); genie_push_undefined (p, MODE (REF_FILE)); genie_push_undefined (p, MODE (INT)); } else if (u == MODE (SOUND)) { A68_SOUND *z = (A68_SOUND *) STACK_TOP; int size = SIZE (MODE (SOUND)); INCREMENT_STACK_POINTER (p, size); FILL (z, 0, size); STATUS (z) = INIT_MASK; } else { BYTE_T *_sp_ = STACK_TOP; int size = SIZE_AL (u); INCREMENT_STACK_POINTER (p, size); FILL (_sp_, 0, size); } } /** @brief Push an undefined value of the required mode. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_skip (NODE_T * p) { PROP_T self; if (MOID (p) != MODE (VOID)) { genie_push_undefined (p, MOID (p)); } UNIT (&self) = genie_skip; SOURCE (&self) = p; return (self); } /** @brief Jump to the serial clause where the label is at. @param p Node in syntax tree. **/ static void genie_jump (NODE_T * p) { /* Stack pointer and frame pointer were saved at target serial clause */ NODE_T *jump = SUB (p); NODE_T *label = (IS (jump, GOTO_SYMBOL)) ? NEXT (jump) : jump; ADDR_T target_frame_pointer = frame_pointer; jmp_buf *jump_stat = NO_JMP_BUF; /* Find the stack frame this jump points to */ BOOL_T found = A68_FALSE; while (target_frame_pointer > 0 && !found) { found = (BOOL_T) ((TAG_TABLE (TAX (label)) == TABLE (FRAME_TREE (target_frame_pointer))) && FRAME_JUMP_STAT (target_frame_pointer) != NO_JMP_BUF); if (!found) { target_frame_pointer = FRAME_STATIC_LINK (target_frame_pointer); } } /* Beam us up, Scotty! */ #if defined HAVE_PARALLEL_CLAUSE { int curlev = running_par_level, tarlev = PAR_LEVEL (NODE (TAX (label))); if (curlev == tarlev) { /* A jump within the same thread */ jump_stat = FRAME_JUMP_STAT (target_frame_pointer); JUMP_TO (TABLE (TAX (label))) = UNIT (TAX (label)); longjmp (*(jump_stat), 1); } else if (curlev > 0 && tarlev == 0) { /* A jump out of all parallel clauses back into the main program */ genie_abend_all_threads (p, FRAME_JUMP_STAT (target_frame_pointer), label); ABEND (A68_TRUE, "should not return from genie_abend_all_threads", NO_TEXT); } else { /* A jump between threads is forbidden in Algol68G */ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_LABEL_IN_PAR_CLAUSE); exit_genie (p, A68_RUNTIME_ERROR); } } #else jump_stat = FRAME_JUMP_STAT (target_frame_pointer); JUMP_TO (TAG_TABLE (TAX (label))) = UNIT (TAX (label)); longjmp (*(jump_stat), 1); #endif } /** @brief Execute a unit, tertiary, secondary or primary. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_unit (NODE_T * p) { if (IS_COERCION (GINFO (p))) { GLOBAL_PROP (&program) = genie_coercion (p); } else { switch (ATTRIBUTE (p)) { case DECLARATION_LIST: { genie_declaration (SUB (p)); UNIT (&GLOBAL_PROP (&program)) = genie_unit; SOURCE (&GLOBAL_PROP (&program)) = p; break; } case UNIT: { EXECUTE_UNIT_2 (SUB (p), GLOBAL_PROP (&program)); break; } case TERTIARY: case SECONDARY: case PRIMARY: { GLOBAL_PROP (&program) = genie_unit (SUB (p)); break; } /* Ex primary */ case ENCLOSED_CLAUSE: { GLOBAL_PROP (&program) = genie_enclosed ((volatile NODE_T *) p); break; } case IDENTIFIER: { GLOBAL_PROP (&program) = genie_identifier (p); break; } case CALL: { GLOBAL_PROP (&program) = genie_call (p); break; } case SLICE: { GLOBAL_PROP (&program) = genie_slice (p); break; } case DENOTATION: { GLOBAL_PROP (&program) = genie_denotation (p); break; } case CAST: { GLOBAL_PROP (&program) = genie_cast (p); break; } case FORMAT_TEXT: { GLOBAL_PROP (&program) = genie_format_text (p); break; } /* Ex secondary */ case GENERATOR: { GLOBAL_PROP (&program) = genie_generator (p); break; } case SELECTION: { GLOBAL_PROP (&program) = genie_selection (p); break; } /* Ex tertiary */ case FORMULA: { GLOBAL_PROP (&program) = genie_formula (p); break; } case MONADIC_FORMULA: { GLOBAL_PROP (&program) = genie_monadic (p); break; } case NIHIL: { GLOBAL_PROP (&program) = genie_nihil (p); break; } case DIAGONAL_FUNCTION: { GLOBAL_PROP (&program) = genie_diagonal_function (p); break; } case TRANSPOSE_FUNCTION: { GLOBAL_PROP (&program) = genie_transpose_function (p); break; } case ROW_FUNCTION: { GLOBAL_PROP (&program) = genie_row_function (p); break; } case COLUMN_FUNCTION: { GLOBAL_PROP (&program) = genie_column_function (p); break; } /* Ex unit */ case ASSIGNATION: { GLOBAL_PROP (&program) = genie_assignation (p); break; } case IDENTITY_RELATION: { GLOBAL_PROP (&program) = genie_identity_relation (p); break; } case ROUTINE_TEXT: { GLOBAL_PROP (&program) = genie_routine_text (p); break; } case SKIP: { GLOBAL_PROP (&program) = genie_skip (p); break; } case JUMP: { UNIT (&GLOBAL_PROP (&program)) = genie_unit; SOURCE (&GLOBAL_PROP (&program)) = p; genie_jump (p); break; } case AND_FUNCTION: { GLOBAL_PROP (&program) = genie_and_function (p); break; } case OR_FUNCTION: { GLOBAL_PROP (&program) = genie_or_function (p); break; } case ASSERTION: { GLOBAL_PROP (&program) = genie_assertion (p); break; } case CODE_CLAUSE: { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_CODE); exit_genie (p, A68_RUNTIME_ERROR); break; } } } return (GPROP (p) = GLOBAL_PROP (&program)); } /** @brief Execution of serial clause without labels. @param p Node in syntax tree. @param pop_sp Value to restore stack pointer. @param seq Chain to link nodes into. **/ void genie_serial_units_no_label (NODE_T * p, int pop_sp, NODE_T ** seq) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case DECLARATION_LIST: case UNIT: { EXECUTE_UNIT_TRACE (p); SEQUENCE (*seq) = p; (*seq) = p; return; } case SEMI_SYMBOL: { /* Voiden the expression stack */ stack_pointer = pop_sp; SEQUENCE (*seq) = p; (*seq) = p; break; } default: { genie_serial_units_no_label (SUB (p), pop_sp, seq); break; } } } } /** @brief Execution of serial clause with labels. @param p Node in syntax tree. @param jump_to Indicates node to jump to after jump. @param exit_buf Jump buffer for EXITs. @param pop_sp Stack pointer at call. **/ void genie_serial_units (NODE_T * p, NODE_T ** jump_to, jmp_buf * exit_buf, int pop_sp) { LOW_STACK_ALERT (p); for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case DECLARATION_LIST: case UNIT: { if (*jump_to == NO_NODE) { EXECUTE_UNIT_TRACE (p); } else if (p == *jump_to) { /* If we dropped in this clause from a jump then this unit is the target */ *jump_to = NO_NODE; EXECUTE_UNIT_TRACE (p); } return; } case EXIT_SYMBOL: { if (*jump_to == NO_NODE) { longjmp (*exit_buf, 1); } break; } case SEMI_SYMBOL: { if (*jump_to == NO_NODE) { /* Voiden the expression stack */ stack_pointer = pop_sp; } break; } default: { genie_serial_units (SUB (p), jump_to, exit_buf, pop_sp); break; } } } } /** @brief Execute serial clause. @param p Node in syntax tree. @param exit_buf Jump buffer for EXITs. **/ void genie_serial_clause (NODE_T * p, jmp_buf * exit_buf) { if (LABELS (TABLE (p)) == NO_TAG) { /* No labels in this clause */ if (SEQUENCE (p) == NO_NODE && ! STATUS_TEST (p, SEQUENCE_MASK)) { NODE_T top_seq; NODE_T *seq = &top_seq; GINFO_T g; GINFO (&top_seq) = &g; genie_serial_units_no_label (SUB (p), stack_pointer, &seq); SEQUENCE (p) = SEQUENCE (&top_seq); STATUS_SET (p, SEQUENCE_MASK); STATUS_SET (p, SERIAL_MASK); if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) { STATUS_SET (p, OPTIMAL_MASK); } } else { /* A linear list without labels */ NODE_T *q; ADDR_T pop_sp = stack_pointer; STATUS_SET (p, SERIAL_CLAUSE); for (q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) { switch (ATTRIBUTE (q)) { case DECLARATION_LIST: case UNIT: { EXECUTE_UNIT_TRACE (q); break; } case SEMI_SYMBOL: { stack_pointer = pop_sp; break; } } } } } else { /* Labels in this clause */ jmp_buf jump_stat; ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; ADDR_T pop_dns = FRAME_DNS (frame_pointer); FRAME_JUMP_STAT (frame_pointer) = &jump_stat; if (!setjmp (jump_stat)) { NODE_T *jump_to = NO_NODE; genie_serial_units (SUB (p), &jump_to, exit_buf, stack_pointer); } else { /* HIjol! Restore state and look for indicated unit */ NODE_T *jump_to = JUMP_TO (TABLE (p)); stack_pointer = pop_sp; frame_pointer = pop_fp; FRAME_DNS (frame_pointer) = pop_dns; genie_serial_units (SUB (p), &jump_to, exit_buf, stack_pointer); } } } /** @brief Execute enquiry clause. @param p Node in syntax tree. **/ void genie_enquiry_clause (NODE_T * p) { if (SEQUENCE (p) == NO_NODE && ! STATUS_TEST (p, SEQUENCE_MASK)) { NODE_T top_seq; NODE_T *seq = &top_seq; GINFO_T g; GINFO (&top_seq) = &g; genie_serial_units_no_label (SUB (p), stack_pointer, &seq); SEQUENCE (p) = SEQUENCE (&top_seq); STATUS_SET (p, SEQUENCE_MASK); if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) { STATUS_SET (p, OPTIMAL_MASK); } } else { /* A linear list without labels (of course, it's an enquiry clause) */ NODE_T *q; ADDR_T pop_sp = stack_pointer; STATUS_SET (p, SERIAL_MASK); for (q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) { switch (ATTRIBUTE (q)) { case DECLARATION_LIST: case UNIT: { EXECUTE_UNIT_TRACE (q); break; } case SEMI_SYMBOL: { stack_pointer = pop_sp; break; } } } } } /** @brief Execute collateral units. @param p Node in syntax tree. @param count Counts collateral units. **/ static void genie_collateral_units (NODE_T * p, int *count) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { EXECUTE_UNIT_TRACE (p); STACK_DNS (p, MOID (p), FRAME_DNS (frame_pointer)); (*count)++; return; } else { genie_collateral_units (SUB (p), count); } } } /** @brief Execute collateral clause. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_collateral (NODE_T * p) { PROP_T self; /* VOID clause and STRUCT display */ if (MOID (p) == MODE (VOID) || IS (MOID (p), STRUCT_SYMBOL)) { int count = 0; genie_collateral_units (SUB (p), &count); } else { /* Row display */ A68_REF new_display; int count = 0; ADDR_T sp = stack_pointer; MOID_T *m = MOID (p); genie_collateral_units (SUB (p), &count); if (DIM (DEFLEX (m)) == 1) { /* [] AMODE display */ new_display = genie_make_row (p, SLICE (DEFLEX (m)), count, sp); stack_pointer = sp; INCREMENT_STACK_POINTER (p, A68_REF_SIZE); *(A68_REF *) STACK_ADDRESS (sp) = new_display; } else { /* [,,] AMODE display, we concatenate 1 + (n-1) to n dimensions */ new_display = genie_make_rowrow (p, m, count, sp); stack_pointer = sp; INCREMENT_STACK_POINTER (p, A68_REF_SIZE); *(A68_REF *) STACK_ADDRESS (sp) = new_display; } } UNIT (&self) = genie_collateral; SOURCE (&self) = p; return (self); } /** @brief Execute unit from integral-case in-part. @param p Node in syntax tree. @param k Value of enquiry clause. @param count Unit counter. @return Whether a unit was executed. **/ BOOL_T genie_int_case_unit (NODE_T * p, int k, int *count) { if (p == NO_NODE) { return (A68_FALSE); } else { if (IS (p, UNIT)) { if (k == *count) { EXECUTE_UNIT_TRACE (p); return (A68_TRUE); } else { (*count)++; return (A68_FALSE); } } else { if (genie_int_case_unit (SUB (p), k, count)) { return (A68_TRUE); } else { return (genie_int_case_unit (NEXT (p), k, count)); } } } } /** @brief Execute unit from united-case in-part. @param p Node in syntax tree. @param m Mode of enquiry clause. @return Whether a unit was executed. **/ static BOOL_T genie_united_case_unit (NODE_T * p, MOID_T * m) { if (p == NO_NODE) { return (A68_FALSE); } else { if (IS (p, SPECIFIER)) { MOID_T *spec_moid = MOID (NEXT_SUB (p)); BOOL_T equal_modes; if (m != NO_MOID) { if (IS (spec_moid, UNION_SYMBOL)) { equal_modes = is_unitable (m, spec_moid, SAFE_DEFLEXING); } else { equal_modes = (BOOL_T) (m == spec_moid); } } else { equal_modes = A68_FALSE; } if (equal_modes) { NODE_T *q = NEXT_NEXT (SUB (p)); OPEN_STATIC_FRAME (p); INIT_STATIC_FRAME (p); if (IS (q, IDENTIFIER)) { if (IS (spec_moid, UNION_SYMBOL)) { COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_TOP, SIZE (spec_moid)); } else { COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_OFFSET (A68_UNION_SIZE), SIZE (spec_moid)); } } EXECUTE_UNIT_TRACE (NEXT_NEXT (p)); CLOSE_FRAME; return (A68_TRUE); } else { return (A68_FALSE); } } else { if (genie_united_case_unit (SUB (p), m)) { return (A68_TRUE); } else { return (genie_united_case_unit (NEXT (p), m)); } } } } /** @brief Execute identity declaration. @param p Node in syntax tree. **/ void genie_identity_dec (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (ISNT (p, DEFINING_IDENTIFIER)) { genie_identity_dec (SUB (p)); } else { A68_REF loc; NODE_T *src = NEXT_NEXT (p); MOID_T *src_mode = MOID (p); unsigned size = (unsigned) SIZE (src_mode); BYTE_T *stack_top = STACK_TOP; ADDR_T pop_sp = stack_pointer; ADDR_T pop_dns = FRAME_DNS (frame_pointer); FRAME_DNS (frame_pointer) = frame_pointer; EXECUTE_UNIT_TRACE (src); genie_check_initialisation (src, stack_top, src_mode); STACK_DNS (src, src_mode, frame_pointer); FRAME_DNS (frame_pointer) = pop_dns; /* Make a temporary REF to the object in the frame */ STATUS (&loc) = (STATUS_MASK) (INIT_MASK | IN_FRAME_MASK); REF_HANDLE (&loc) = &nil_handle; OFFSET (&loc) = frame_pointer + FRAME_INFO_SIZE + OFFSET (TAX (p)); REF_SCOPE (&loc) = frame_pointer; ABEND (ADDRESS (&loc) != FRAME_OBJECT (OFFSET (TAX (p))), ERROR_INTERNAL_CONSISTENCY, NO_TEXT); /* Initialise the tag, value is in the stack */ if (HAS_ROWS (src_mode)) { stack_pointer = pop_sp; genie_clone_stack (p, src_mode, &loc, &nil_ref); } else if (UNIT (&GPROP (src)) == genie_constant) { STATUS_SET (TAX (p), CONSTANT_MASK); POP_ALIGNED (p, ADDRESS (&loc), size); } else { POP_ALIGNED (p, ADDRESS (&loc), size); } return; } } } /** @brief Execute variable declaration. @param p Node in syntax tree. @param declarer Pointer to the declarer. @param sp Stack pointer. **/ void genie_variable_dec (NODE_T * p, NODE_T ** declarer, ADDR_T sp) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, VARIABLE_DECLARATION)) { genie_variable_dec (SUB (p), declarer, sp); } else { if (IS (p, DECLARER)) { (*declarer) = SUB (p); genie_generator_bounds (*declarer); FORWARD (p); } if (IS (p, DEFINING_IDENTIFIER)) { MOID_T *ref_mode = MOID (p); TAG_T *tag = TAX (p); int leap = (HEAP (tag) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL); A68_REF *z; PREEMPTIVE_GC; z = (A68_REF *) (FRAME_OBJECT (OFFSET (TAX (p)))); genie_generator_internal (*declarer, ref_mode, BODY (tag), leap, sp); POP_REF (p, z); if (NEXT (p) != NO_NODE && IS (NEXT (p), ASSIGN_SYMBOL)) { NODE_T *src = NEXT_NEXT (p); MOID_T *src_mode = SUB_MOID (p); ADDR_T pop_sp = stack_pointer; ADDR_T pop_dns = FRAME_DNS (frame_pointer); FRAME_DNS (frame_pointer) = frame_pointer; EXECUTE_UNIT_TRACE (src); STACK_DNS (src, src_mode, frame_pointer); FRAME_DNS (frame_pointer) = pop_dns; stack_pointer = pop_sp; if (HAS_ROWS (src_mode)) { genie_clone_stack (p, src_mode, z, z); } else { MOVE (ADDRESS (z), STACK_TOP, (unsigned) SIZE (src_mode)); } } } } } } /** @brief Execute PROC variable declaration. @param p Node in syntax tree. **/ void genie_proc_variable_dec (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case DEFINING_IDENTIFIER: { ADDR_T sp_for_voiding = stack_pointer; MOID_T *ref_mode = MOID (p); TAG_T *tag = TAX (p); int leap = (HEAP (tag) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL); A68_REF *z = (A68_REF *) (FRAME_OBJECT (OFFSET (TAX (p)))); genie_generator_internal (p, ref_mode, BODY (tag), leap, stack_pointer); POP_REF (p, z); if (NEXT (p) != NO_NODE && IS (NEXT (p), ASSIGN_SYMBOL)) { MOID_T *src_mode = SUB_MOID (p); ADDR_T pop_sp = stack_pointer; ADDR_T pop_dns = FRAME_DNS (frame_pointer); FRAME_DNS (frame_pointer) = frame_pointer; EXECUTE_UNIT_TRACE (NEXT_NEXT (p)); STACK_DNS (p, SUB (ref_mode), frame_pointer); FRAME_DNS (frame_pointer) = pop_dns; stack_pointer = pop_sp; MOVE (ADDRESS (z), STACK_TOP, (unsigned) SIZE (src_mode)); } stack_pointer = sp_for_voiding; /* Voiding */ return; } default: { genie_proc_variable_dec (SUB (p)); break; } } } } /** @brief Execute operator declaration. @param p Node in syntax tree. **/ void genie_operator_dec (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case DEFINING_OPERATOR: { A68_PROCEDURE *z = (A68_PROCEDURE *) (FRAME_OBJECT (OFFSET (TAX (p)))); ADDR_T pop_dns = FRAME_DNS (frame_pointer); FRAME_DNS (frame_pointer) = frame_pointer; EXECUTE_UNIT_TRACE (NEXT_NEXT (p)); STACK_DNS (p, MOID (p), frame_pointer); FRAME_DNS (frame_pointer) = pop_dns; POP_PROCEDURE (p, z); return; } default: { genie_operator_dec (SUB (p)); break; } } } } /** @brief Execute declaration. @param p Node in syntax tree. **/ void genie_declaration (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { switch (ATTRIBUTE (p)) { case MODE_DECLARATION: case PROCEDURE_DECLARATION: case BRIEF_OPERATOR_DECLARATION: case PRIORITY_DECLARATION: { /* Already resolved */ return; } case IDENTITY_DECLARATION: { genie_identity_dec (SUB (p)); break; } case OPERATOR_DECLARATION: { genie_operator_dec (SUB (p)); break; } case VARIABLE_DECLARATION: { NODE_T *declarer = NO_NODE; ADDR_T pop_sp = stack_pointer; genie_variable_dec (SUB (p), &declarer, stack_pointer); /* Voiding to remove garbage from declarers */ stack_pointer = pop_sp; break; } case PROCEDURE_VARIABLE_DECLARATION: { ADDR_T pop_sp = stack_pointer; genie_proc_variable_dec (SUB (p)); stack_pointer = pop_sp; break; } default: { genie_declaration (SUB (p)); break; } } } } /* #define LABEL_FREE(p) {\ NODE_T *_m_q; ADDR_T pop_sp = stack_pointer;\ for (_m_q = SEQUENCE (p); _m_q != NO_NODE; _m_q = SEQUENCE (_m_q)) {\ switch (ATTRIBUTE (_m_q)) {\ case DECLARATION_LIST: case UNIT: {\ EXECUTE_UNIT_TRACE (_m_q);\ break;\ }\ case SEMI_SYMBOL: {\ stack_pointer = pop_sp;\ break;\ }}}} */ #define LABEL_FREE(p) {\ NODE_T *_m_q; ADDR_T pop_sp_lf = stack_pointer;\ for (_m_q = SEQUENCE (p); _m_q != NO_NODE; _m_q = SEQUENCE (_m_q)) {\ if (IS (_m_q, UNIT) || IS (_m_q, DECLARATION_LIST)) {\ EXECUTE_UNIT_TRACE (_m_q);\ }\ if (SEQUENCE (_m_q) != NO_NODE) {\ stack_pointer = pop_sp_lf;\ _m_q = SEQUENCE (_m_q);\ }\ }} #define SERIAL_CLAUSE(p)\ if (STATUS_TEST (p, OPTIMAL_MASK)) {\ EXECUTE_UNIT (SEQUENCE (p));\ } else if (STATUS_TEST (p, SERIAL_MASK)) {\ LABEL_FREE (p);\ } else {\ if (!setjmp (exit_buf)) {\ genie_serial_clause ((NODE_T *) p, (jmp_buf *) exit_buf);\ }} #define SERIAL_CLAUSE_TRACE(p)\ if (STATUS_TEST (p, OPTIMAL_MASK)) {\ EXECUTE_UNIT_TRACE (SEQUENCE (p));\ } else if (STATUS_TEST (p, SERIAL_MASK)) {\ LABEL_FREE (p);\ } else {\ if (!setjmp (exit_buf)) {\ genie_serial_clause ((NODE_T *) p, (jmp_buf *) exit_buf);\ }} #define ENQUIRY_CLAUSE(p)\ if (STATUS_TEST (p, OPTIMAL_MASK)) {\ EXECUTE_UNIT (SEQUENCE (p));\ } else if (STATUS_TEST (p, SERIAL_MASK)) {\ LABEL_FREE (p);\ } else {\ genie_enquiry_clause ((NODE_T *) p);\ } /** @brief Execute integral-case-clause. @param p Node in syntax tree. **/ static PROP_T genie_int_case (volatile NODE_T * p) { volatile int unit_count; volatile BOOL_T found_unit; jmp_buf exit_buf; A68_INT k; volatile NODE_T *q = SUB (p); volatile MOID_T *yield = MOID (q); /* CASE or OUSE */ OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_GLOBAL_POINTER ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); ENQUIRY_CLAUSE (NEXT_SUB (q)); POP_OBJECT (q, &k, A68_INT); /* IN */ FORWARD (q); OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); unit_count = 1; found_unit = genie_int_case_unit (NEXT_SUB ((NODE_T *) q), (int) VALUE (&k), (int *) &unit_count); CLOSE_FRAME; /* OUT */ if (!found_unit) { FORWARD (q); switch (ATTRIBUTE (q)) { case CHOICE: case OUT_PART: { OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); SERIAL_CLAUSE (NEXT_SUB (q)); CLOSE_FRAME; break; } case CLOSE_SYMBOL: case ESAC_SYMBOL: { if (yield != MODE (VOID)) { genie_push_undefined ((NODE_T *) q, (MOID_T *) yield); } break; } default: { MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield; (void) genie_int_case (q); break; } } } /* ESAC */ CLOSE_FRAME; return (GPROP (p)); } /** @brief Execute united-case-clause. @param p Node in syntax tree. **/ static PROP_T genie_united_case (volatile NODE_T * p) { volatile BOOL_T found_unit = A68_FALSE; volatile MOID_T *um; volatile ADDR_T pop_sp; jmp_buf exit_buf; volatile NODE_T *q = SUB (p); volatile MOID_T *yield = MOID (q); /* CASE or OUSE */ OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_GLOBAL_POINTER ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); pop_sp = stack_pointer; ENQUIRY_CLAUSE (NEXT_SUB (q)); stack_pointer = pop_sp; um = (volatile MOID_T *) VALUE ((A68_UNION *) STACK_TOP); /* IN */ FORWARD (q); if (um != NO_MOID) { OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); found_unit = genie_united_case_unit (NEXT_SUB ((NODE_T *) q), (MOID_T *) um); CLOSE_FRAME; } else { found_unit = A68_FALSE; } /* OUT */ if (!found_unit) { FORWARD (q); switch (ATTRIBUTE (q)) { case CHOICE: case OUT_PART: { OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); SERIAL_CLAUSE (NEXT_SUB (q)); CLOSE_FRAME; break; } case CLOSE_SYMBOL: case ESAC_SYMBOL: { if (yield != MODE (VOID)) { genie_push_undefined ((NODE_T *) q, (MOID_T *) yield); } break; } default: { MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield; (void) genie_united_case (q); break; } } } /* ESAC */ CLOSE_FRAME; return (GPROP (p)); } /** @brief Execute conditional-clause. @param p Node in syntax tree. **/ static PROP_T genie_conditional (volatile NODE_T * p) { volatile int pop_sp = stack_pointer; jmp_buf exit_buf; volatile NODE_T *q = SUB (p); volatile MOID_T *yield = MOID (q); /* IF or ELIF */ OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_GLOBAL_POINTER ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); ENQUIRY_CLAUSE (NEXT_SUB (q)); stack_pointer = pop_sp; FORWARD (q); if (VALUE ((A68_BOOL *) STACK_TOP) == A68_TRUE) { /* THEN */ OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); SERIAL_CLAUSE (NEXT_SUB (q)); CLOSE_FRAME; } else { /* ELSE */ FORWARD (q); switch (ATTRIBUTE (q)) { case CHOICE: case ELSE_PART: { OPEN_STATIC_FRAME ((NODE_T *) SUB (q)); INIT_STATIC_FRAME ((NODE_T *) SUB (q)); SERIAL_CLAUSE (NEXT_SUB (q)); CLOSE_FRAME; break; } case CLOSE_SYMBOL: case FI_SYMBOL: { if (yield != MODE (VOID)) { genie_push_undefined ((NODE_T *) q, (MOID_T *) yield); } break; } default: { MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield; (void) genie_conditional (q); break; } } } /* FI */ CLOSE_FRAME; return (GPROP (p)); } /* INCREMENT_COUNTER procures that the counter only increments if there is a for-part or a to-part. Otherwise an infinite loop would trigger overflow when the anonymous counter reaches max int, which is strange behaviour. */ #define INCREMENT_COUNTER\ if (!(for_part == NO_NODE && to_part == NO_NODE)) {\ CHECK_INT_ADDITION ((NODE_T *) p, counter, by);\ counter += by;\ } /** @brief Execute loop-clause. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_loop (volatile NODE_T * p) { volatile ADDR_T pop_sp = stack_pointer; volatile int from, by, to, counter; volatile BOOL_T siga, conditional; /* Next line provokes inevitably: warning: variable 'for_part' might be clobbered by 'longjmp' or 'vfork' warning: variable 'to_part' might be clobbered by 'longjmp' or 'vfork' This warning can be safely ignored. */ volatile NODE_T *for_part = NO_NODE, *to_part = NO_NODE, *q = NO_NODE; jmp_buf exit_buf; /* FOR identifier */ if (IS (p, FOR_PART)) { for_part = NEXT_SUB (p); FORWARD (p); } /* FROM unit */ if (IS (p, FROM_PART)) { EXECUTE_UNIT (NEXT_SUB (p)); stack_pointer = pop_sp; from = VALUE ((A68_INT *) STACK_TOP); FORWARD (p); } else { from = 1; } /* BY unit */ if (IS (p, BY_PART)) { EXECUTE_UNIT (NEXT_SUB (p)); stack_pointer = pop_sp; by = VALUE ((A68_INT *) STACK_TOP); FORWARD (p); } else { by = 1; } /* TO unit, DOWNTO unit */ if (IS (p, TO_PART)) { if (IS (SUB (p), DOWNTO_SYMBOL)) { by = -by; } EXECUTE_UNIT (NEXT_SUB (p)); stack_pointer = pop_sp; to = VALUE ((A68_INT *) STACK_TOP); to_part = p; FORWARD (p); } else { to = (by >= 0 ? A68_MAX_INT : -A68_MAX_INT); } q = NEXT_SUB (p); /* Here the loop part starts. We open the frame only once and reinitialise if necessary */ OPEN_STATIC_FRAME ((NODE_T *) q); INIT_GLOBAL_POINTER ((NODE_T *) q); INIT_STATIC_FRAME ((NODE_T *) q); counter = from; /* Does the loop contain conditionals? */ if (IS (p, WHILE_PART)) { conditional = A68_TRUE; } else if (IS (p, DO_PART) || IS (p, ALT_DO_PART)) { NODE_T *until_part = NEXT_SUB (p); if (IS (until_part, SERIAL_CLAUSE)) { until_part = NEXT (until_part); } conditional = (BOOL_T) (until_part != NO_NODE && IS (until_part, UNTIL_PART)); } else { conditional = A68_FALSE; } if (conditional) { /* [FOR ...] [WHILE ...] DO [...] [UNTIL ...] OD */ siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0)); while (siga) { if (for_part != NO_NODE) { A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part)))); STATUS (z) = INIT_MASK; VALUE (z) = counter; } stack_pointer = pop_sp; if (IS (p, WHILE_PART)) { ENQUIRY_CLAUSE (q); stack_pointer = pop_sp; siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) != A68_FALSE); } if (siga) { /* Next line provokes inevitably: warning: variable 'do_p' might be clobbered by 'longjmp' or 'vfork' This warning can be safely ignored. */ volatile NODE_T *do_part = p, *until_part; if (IS (p, WHILE_PART)) { do_part = NEXT_SUB (NEXT (p)); OPEN_STATIC_FRAME ((NODE_T *) do_part); INIT_STATIC_FRAME ((NODE_T *) do_part); } else { do_part = NEXT_SUB (p); } if (IS (do_part, SERIAL_CLAUSE)) { SERIAL_CLAUSE_TRACE (do_part); until_part = NEXT (do_part); } else { until_part = do_part; } /* UNTIL part */ if (until_part != NO_NODE && IS (until_part, UNTIL_PART)) { NODE_T *v = NEXT_SUB (until_part); OPEN_STATIC_FRAME ((NODE_T *) v); INIT_STATIC_FRAME ((NODE_T *) v); stack_pointer = pop_sp; ENQUIRY_CLAUSE (v); stack_pointer = pop_sp; siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) == A68_FALSE); CLOSE_FRAME; } if (IS (p, WHILE_PART)) { CLOSE_FRAME; } /* Increment counter */ if (siga) { INCREMENT_COUNTER; siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0)); } /* The genie cannot take things to next iteration: re-initialise stack frame */ if (siga) { FRAME_CLEAR (AP_INCREMENT (TABLE (q))); if (INITIALISE_FRAME (TABLE (q))) { initialise_frame ((NODE_T *) q); } } } } } else { /* [FOR ...] DO ... OD */ siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0)); while (siga) { if (for_part != NO_NODE) { A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part)))); STATUS (z) = INIT_MASK; VALUE (z) = counter; } stack_pointer = pop_sp; SERIAL_CLAUSE_TRACE (q); INCREMENT_COUNTER; siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0)); /* The genie cannot take things to next iteration: re-initialise stack frame */ if (siga) { FRAME_CLEAR (AP_INCREMENT (TABLE (q))); if (INITIALISE_FRAME (TABLE (q))) { initialise_frame ((NODE_T *) q); } } } } /* OD */ CLOSE_FRAME; stack_pointer = pop_sp; return (GPROP (p)); } #undef INCREMENT_COUNTER #undef LOOP_OVERFLOW /** @brief Execute closed clause. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_closed (volatile NODE_T * p) { jmp_buf exit_buf; volatile NODE_T *q = NEXT_SUB (p); OPEN_STATIC_FRAME ((NODE_T *) q); INIT_GLOBAL_POINTER ((NODE_T *) q); INIT_STATIC_FRAME ((NODE_T *) q); SERIAL_CLAUSE (q); CLOSE_FRAME; return (GPROP (p)); } /** @brief Execute enclosed clause. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_enclosed (volatile NODE_T * p) { PROP_T self; UNIT (&self) = (PROP_PROC *) genie_enclosed; SOURCE (&self) = (NODE_T *) p; switch (ATTRIBUTE (p)) { case PARTICULAR_PROGRAM: { self = genie_enclosed (SUB (p)); break; } case ENCLOSED_CLAUSE: { self = genie_enclosed (SUB (p)); break; } case CLOSED_CLAUSE: { self = genie_closed ((NODE_T *) p); if (UNIT (&self) == genie_unit) { UNIT (&self) = (PROP_PROC *) genie_closed; SOURCE (&self) = (NODE_T *) p; } break; } #if defined HAVE_PARALLEL_CLAUSE case PARALLEL_CLAUSE: { (void) genie_parallel ((NODE_T *) NEXT_SUB (p)); break; } #endif case COLLATERAL_CLAUSE: { (void) genie_collateral ((NODE_T *) p); break; } case CONDITIONAL_CLAUSE: { MOID (SUB ((NODE_T *) p)) = MOID (p); (void) genie_conditional (p); UNIT (&self) = (PROP_PROC *) genie_conditional; SOURCE (&self) = (NODE_T *) p; break; } case CASE_CLAUSE: { MOID (SUB ((NODE_T *) p)) = MOID (p); (void) genie_int_case (p); UNIT (&self) = (PROP_PROC *) genie_int_case; SOURCE (&self) = (NODE_T *) p; break; } case CONFORMITY_CLAUSE: { MOID (SUB ((NODE_T *) p)) = MOID (p); (void) genie_united_case (p); UNIT (&self) = (PROP_PROC *) genie_united_case; SOURCE (&self) = (NODE_T *) p; break; } case LOOP_CLAUSE: { (void) genie_loop (SUB ((NODE_T *) p)); UNIT (&self) = (PROP_PROC *) genie_loop; SOURCE (&self) = SUB ((NODE_T *) p); break; } } GPROP (p) = self; return (self); } /* Routines for handling stowed objects. An A68G row is a reference to a descriptor in the heap: ... A68_REF row -> A68_ARRAY ----+ ARRAY: Description of row, ref to elements A68_TUPLE 1 | TUPLE: Bounds, one for every dimension ... | A68_TUPLE dim | ... | ... | Element 1 <---+ Element: Sequential row elements, in the heap ... Not always contiguous - trims! Element n */ /** @brief Size of a row. @param tup First tuple. @param dim Dimension of row. @return See brief description. **/ int get_row_size (A68_TUPLE * tup, int dim) { int span = 1, k; for (k = 0; k < dim; k++) { int stride = ROW_SIZE (&tup[k]); ABEND ((stride > 0 && span > A68_MAX_INT / stride), ERROR_INVALID_SIZE, "get_row_size"); span *= stride; } return (span); } /** @brief Initialise index for FORALL constructs. @param tup First tuple. @param dim Dimension of row. **/ void initialise_internal_index (A68_TUPLE * tup, int dim) { int k; for (k = 0; k < dim; k++) { A68_TUPLE *ref = &tup[k]; K (ref) = LWB (ref); } } /** @brief Calculate index. @param tup First tuple. @param dim Dimension of row. @return See brief description. **/ ADDR_T calculate_internal_index (A68_TUPLE * tup, int dim) { ADDR_T iindex = 0; int k; for (k = 0; k < dim; k++) { A68_TUPLE *ref = &tup[k]; iindex += (SPAN (ref) * K (ref) - SHIFT (ref)); } return (iindex); } /** @brief Increment index for FORALL constructs. @param tup First tuple. @param dim Dimension of row. @return Whether maximum (index + 1) is reached. **/ BOOL_T increment_internal_index (A68_TUPLE * tup, int dim) { BOOL_T carry = A68_TRUE; int k; for (k = dim - 1; k >= 0 && carry; k--) { A68_TUPLE *ref = &tup[k]; if (K (ref) < UPB (ref)) { (K (ref))++; carry = A68_FALSE; } else { K (ref) = LWB (ref); } } return (carry); } /** @brief Print index. @param f File descriptor. @param tup First tuple. @param dim Dimension of row. **/ void print_internal_index (FILE_T f, A68_TUPLE * tup, int dim) { int k; for (k = 0; k < dim; k++) { A68_TUPLE *ref = &tup[k]; char buf[BUFFER_SIZE]; ASSERT (snprintf (buf, SNPRINTF_SIZE, "%d", K (ref)) >= 0); WRITE (f, buf); if (k < dim - 1) { WRITE (f, ", "); } } } /** @brief Convert C string to A68 [] CHAR. @param p Node in syntax tree. @param str String to convert. @param width Width of string. @return Pointer to [] CHAR. **/ A68_REF c_string_to_row_char (NODE_T * p, char *str, int width) { A68_REF z, row; A68_ARRAY arr; A68_TUPLE tup; BYTE_T *base; int str_size, k; str_size = (int) strlen (str); z = heap_generator (p, MODE (ROW_CHAR), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_CHAR), width * SIZE_AL (A68_CHAR)); DIM (&arr) = 1; MOID (&arr) = MODE (CHAR); ELEM_SIZE (&arr) = SIZE_AL (A68_CHAR); SLICE_OFFSET (&arr) = 0; FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = width; SPAN (&tup) = 1; SHIFT (&tup) = LWB (&tup); K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &z); base = ADDRESS (&row); for (k = 0; k < width; k++) { A68_CHAR *ch = (A68_CHAR *) & (base[k * SIZE_AL (A68_CHAR)]); STATUS (ch) = INIT_MASK; VALUE (ch) = TO_UCHAR (str[k]); } return (z); } /** @brief Convert C string to A68 string. @param p Node in syntax tree. @param str String to convert. @param width Width of string (if different from strlen (str)). @return A68 string **/ A68_REF c_to_a_string (NODE_T * p, char *str, int width) { if (str == NO_TEXT) { return (empty_string (p)); } else { if (width == DEFAULT_WIDTH) { return (c_string_to_row_char (p, str, (int) strlen (str))); } else { return (c_string_to_row_char (p, str, (int) width)); } } } /** @brief Size of a string. @param p Node in syntax tree. @param row Row, pointer to descriptor. @return See brief description. **/ int a68_string_size (NODE_T * p, A68_REF row) { (void) p; if (INITIALISED (&row)) { A68_ARRAY *arr; A68_TUPLE *tup; GET_DESCRIPTOR (arr, tup, &row); return (ROW_SIZE (tup)); } else { return (0); } } /** @brief Convert A68 string to C string. @param p Node in syntax tree. @param str String to store result. @param row STRING to convert @return Str. **/ char *a_to_c_string (NODE_T * p, char *str, A68_REF row) { /* Assume "str" to be long enough - caller's responsibility! */ (void) p; if (INITIALISED (&row)) { A68_ARRAY *arr; A68_TUPLE *tup; int size, n = 0; GET_DESCRIPTOR (arr, tup, &row); size = ROW_SIZE (tup); if (size > 0) { int k; BYTE_T *base_address = ADDRESS (&ARRAY (arr)); for (k = LWB (tup); k <= UPB (tup); k++) { int addr = INDEX_1_DIM (arr, tup, k); A68_CHAR *ch = (A68_CHAR *) & (base_address[addr]); CHECK_INIT (p, INITIALISED (ch), MODE (CHAR)); str[n++] = (char) VALUE (ch); } } str[n] = NULL_CHAR; return (str); } else { return (NO_TEXT); } } /** @brief Return an empty row. @param p Node in syntax tree. @param u Mode of row. @return Fat pointer to descriptor. **/ A68_REF empty_row (NODE_T * p, MOID_T * u) { A68_REF dsc; A68_ARRAY *arr; A68_TUPLE *tup; MOID_T *v; int dim, k; if (IS (u, FLEX_SYMBOL)) { u = SUB (u); } v = SUB (u); dim = DIM (u); dsc = heap_generator (p, u, SIZE_AL (A68_ARRAY) + dim * SIZE_AL (A68_TUPLE)); GET_DESCRIPTOR (arr, tup, &dsc); DIM (arr) = dim; MOID (arr) = SLICE (u); ELEM_SIZE (arr) = moid_size (SLICE (u)); SLICE_OFFSET (arr) = 0; FIELD_OFFSET (arr) = 0; if (IS (v, ROW_SYMBOL) || IS (v, FLEX_SYMBOL)) { /* [] AMODE or FLEX [] AMODE */ ARRAY (arr) = heap_generator (p, v, A68_REF_SIZE); * DEREF (A68_REF,&ARRAY (arr)) = empty_row (p, v); } else { ARRAY (arr) = nil_ref; } STATUS (&ARRAY (arr)) = (STATUS_MASK) (INIT_MASK | IN_HEAP_MASK); for (k = 0; k < dim; k++) { LWB (&tup[k]) = 1; UPB (&tup[k]) = 0; SPAN (&tup[k]) = 1; SHIFT (&tup[k]) = LWB (tup); } return (dsc); } /** @brief An empty string, FLEX [1 : 0] CHAR. @param p Node in syntax tree. @return Fat pointer to descriptor. **/ A68_REF empty_string (NODE_T * p) { return (empty_row (p, MODE (STRING))); } /** @brief Make [,, ..] MODE from [, ..] MODE. @param p Node in syntax tree. @param rmod Row of mode. @param len Number of elements. @param sp Stack pointer. @return Fat pointer to descriptor. **/ A68_REF genie_make_rowrow (NODE_T * p, MOID_T * rmod, int len, ADDR_T sp) { MOID_T *nmod = IS (rmod, FLEX_SYMBOL) ? SUB (rmod) : rmod; MOID_T *emod = SUB (nmod); A68_REF nrow, orow; A68_ARRAY *narr, *oarr; A68_TUPLE *ntup, *otup; int j, k, span, odim = DIM (nmod) - 1; /* Make the new descriptor */ nrow = heap_generator (p, rmod, SIZE_AL (A68_ARRAY) + DIM (nmod) * SIZE_AL (A68_TUPLE)); GET_DESCRIPTOR (narr, ntup, &nrow); DIM (narr) = DIM (nmod); MOID (narr) = emod; ELEM_SIZE (narr) = SIZE (emod); SLICE_OFFSET (narr) = 0; FIELD_OFFSET (narr) = 0; if (len == 0) { /* There is a vacuum on the stack */ for (k = 0; k < odim; k++) { LWB (&ntup[k + 1]) = 1; UPB (&ntup[k + 1]) = 0; SPAN (&ntup[k + 1]) = 1; SHIFT (&ntup[k + 1]) = LWB (&ntup[k + 1]); } LWB (ntup) = 1; UPB (ntup) = 0; SPAN (ntup) = 0; SHIFT (ntup) = 0; ARRAY (narr) = nil_ref; return (nrow); } else if (len > 0) { A68_ARRAY *x = NO_ARRAY; /* Arrays in the stack must have equal bounds */ for (j = 1; j < len; j++) { A68_REF vrow, rrow; A68_TUPLE *vtup, *rtup; rrow = *(A68_REF *) STACK_ADDRESS (sp); vrow = *(A68_REF *) STACK_ADDRESS (sp + j * A68_REF_SIZE); GET_DESCRIPTOR (x, rtup, &rrow); GET_DESCRIPTOR (x, vtup, &vrow); for (k = 0; k < odim; k++, rtup++, vtup++) { if ((UPB (rtup) != UPB (vtup)) || (LWB (rtup) != LWB (vtup))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } } } /* Fill descriptor of new row with info from (arbitrary) first one */ orow = *(A68_REF *) STACK_ADDRESS (sp); GET_DESCRIPTOR (x, otup, &orow); for (span = 1, k = 0; k < odim; k++) { A68_TUPLE *nt = &ntup[k + 1], *ot = &otup[k]; LWB (nt) = LWB (ot); UPB (nt) = UPB (ot); SPAN (nt) = span; SHIFT (nt) = LWB (nt) * SPAN (nt); span *= ROW_SIZE (nt); } LWB (ntup) = 1; UPB (ntup) = len; SPAN (ntup) = span; SHIFT (ntup) = LWB (ntup) * SPAN (ntup); ARRAY (narr) = heap_generator (p, rmod, len * span * ELEM_SIZE (narr)); for (j = 0; j < len; j++) { /* new[j,, ] := old[, ] */ BOOL_T done; GET_DESCRIPTOR (oarr, otup, (A68_REF *) STACK_ADDRESS (sp + j * A68_REF_SIZE)); initialise_internal_index (otup, odim); initialise_internal_index (&ntup[1], odim); done = A68_FALSE; while (!done) { A68_REF src = ARRAY (oarr), dst = ARRAY (narr); ADDR_T oindex, nindex; oindex = calculate_internal_index (otup, odim); nindex = j * SPAN (ntup) + calculate_internal_index (&ntup[1], odim); OFFSET (&src) += ROW_ELEMENT (oarr, oindex); OFFSET (&dst) += ROW_ELEMENT (narr, nindex); if (HAS_ROWS (emod)) { A68_REF none = genie_clone (p, emod, &nil_ref, &src); MOVE (ADDRESS (&dst), ADDRESS (&none), SIZE (emod)); } else { MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (emod)); } done = increment_internal_index (otup, odim) | increment_internal_index (&ntup[1], odim); } } } return (nrow); } /** @brief Make a row of 'len' objects that are in the stack. @param p Node in syntax tree. @param elem_mode Mode of element. @param len Number of elements in the stack. @param sp Stack pointer. @return Fat pointer to descriptor. **/ A68_REF genie_make_row (NODE_T * p, MOID_T * elem_mode, int len, ADDR_T sp) { A68_REF new_row, new_arr; A68_ARRAY *arr; A68_TUPLE *tup; int k; new_row = heap_generator (p, MOID (p), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); new_arr = heap_generator (p, MOID (p), len * SIZE (elem_mode)); GET_DESCRIPTOR (arr, tup, &new_row); DIM (arr) = 1; MOID (arr) = elem_mode; ELEM_SIZE (arr) = SIZE (elem_mode); SLICE_OFFSET (arr) = 0; FIELD_OFFSET (arr) = 0; ARRAY (arr) = new_arr; LWB (tup) = 1; UPB (tup) = len; SPAN (tup)= 1; SHIFT (tup) = LWB (tup); for (k = 0; k < len * ELEM_SIZE (arr); k += ELEM_SIZE (arr)) { A68_REF dst = new_arr, src; OFFSET (&dst) += k; STATUS (&src) = (STATUS_MASK) (INIT_MASK | IN_STACK_MASK); OFFSET (&src) = sp + k; REF_HANDLE (&src) = &nil_handle; if (HAS_ROWS (elem_mode)) { A68_REF new_one = genie_clone (p, elem_mode, &nil_ref, &src); MOVE (ADDRESS (&dst), ADDRESS (&new_one), SIZE (elem_mode)); } else { MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (elem_mode)); } } return (new_row); } /** @brief Make REF [1 : 1] [] MODE from REF [] MODE. @param p Node in syntax tree. @param dst_mode Destination mode. @param src_mode Source mode. @param sp Stack pointer. @return Fat pointer to descriptor. **/ A68_REF genie_make_ref_row_of_row (NODE_T * p, MOID_T * dst_mode, MOID_T * src_mode, ADDR_T sp) { A68_REF new_row, name, array; A68_ARRAY *arr; A68_TUPLE *tup; dst_mode = DEFLEX (dst_mode); src_mode = DEFLEX (src_mode); array = *(A68_REF *) STACK_ADDRESS (sp); /* ROWING NIL yields NIL */ if (IS_NIL (array)) { return (nil_ref); } new_row = heap_generator (p, SUB (dst_mode), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); name = heap_generator (p, dst_mode, A68_REF_SIZE); GET_DESCRIPTOR (arr, tup, &new_row); DIM (arr) = 1; MOID (arr) = src_mode; ELEM_SIZE (arr) = SIZE (src_mode); SLICE_OFFSET (arr) = 0; FIELD_OFFSET (arr) = 0; ARRAY (arr) = array; LWB (tup) = 1; UPB (tup) = 1; SPAN (tup) = 1; SHIFT (tup) = LWB (tup); * DEREF (A68_REF, &name) = new_row; return (name); } /** @brief Make REF [1 : 1, ..] MODE from REF [..] MODE. @param p Node in syntax tree. @param dst_mode Destination mode. @param src_mode Source mode. @param sp Stack pointer. @return Fat pointer to descriptor. **/ A68_REF genie_make_ref_row_row (NODE_T * p, MOID_T * dst_mode, MOID_T * src_mode, ADDR_T sp) { A68_REF name, new_row, old_row; A68_ARRAY *new_arr, *old_arr; A68_TUPLE *new_tup, *old_tup; int k; dst_mode = DEFLEX (dst_mode); src_mode = DEFLEX (src_mode); name = *(A68_REF *) STACK_ADDRESS (sp); /* ROWING NIL yields NIL */ if (IS_NIL (name)) { return (nil_ref); } old_row = * DEREF (A68_REF, &name); GET_DESCRIPTOR (old_arr, old_tup, &old_row); /* Make new descriptor */ new_row = heap_generator (p, dst_mode, SIZE_AL (A68_ARRAY) + DIM (SUB (dst_mode)) * SIZE_AL (A68_TUPLE)); name = heap_generator (p, dst_mode, A68_REF_SIZE); GET_DESCRIPTOR (new_arr, new_tup, &new_row); DIM (new_arr) = DIM (SUB (dst_mode)); MOID (new_arr) = MOID (old_arr); ELEM_SIZE (new_arr) = ELEM_SIZE (old_arr); SLICE_OFFSET (new_arr) = 0; FIELD_OFFSET (new_arr) = 0; ARRAY (new_arr) = ARRAY (old_arr); /* Fill out the descriptor */ LWB (&(new_tup[0])) = 1; UPB (&(new_tup[0])) = 1; SPAN (&(new_tup[0])) = 1; SHIFT (&(new_tup[0])) = LWB (&(new_tup[0])); for (k = 0; k < DIM (SUB (src_mode)); k++) { new_tup[k + 1] = old_tup[k]; } /* Yield the new name */ * DEREF (A68_REF, &name) = new_row; return (name); } /** @brief Coercion to [1 : 1, ] MODE. @param p Node in syntax tree. @return Propagator for this action. **/ static PROP_T genie_rowing_row_row (NODE_T * p) { A68_REF row; ADDR_T sp = stack_pointer; EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), frame_pointer); row = genie_make_rowrow (p, MOID (p), 1, sp); stack_pointer = sp; PUSH_REF (p, row); return (GPROP (p)); } /** @brief Coercion to [1 : 1] [] MODE. @param p Node in syntax tree. @return Propagator for this action. **/ static PROP_T genie_rowing_row_of_row (NODE_T * p) { A68_REF row; ADDR_T sp = stack_pointer; EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), frame_pointer); row = genie_make_row (p, SLICE (MOID (p)), 1, sp); stack_pointer = sp; PUSH_REF (p, row); return (GPROP (p)); } /** @brief Coercion to REF [1 : 1, ..] MODE. @param p Node in syntax tree. @return Propagator for this action. **/ static PROP_T genie_rowing_ref_row_row (NODE_T * p) { A68_REF name; ADDR_T sp = stack_pointer; MOID_T *dst = MOID (p), *src = MOID (SUB (p)); EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), frame_pointer); stack_pointer = sp; name = genie_make_ref_row_row (p, dst, src, sp); PUSH_REF (p, name); return (GPROP (p)); } /** @brief REF [1 : 1] [] MODE from [] MODE @param p Node in syntax tree. @return Propagator for this action. **/ static PROP_T genie_rowing_ref_row_of_row (NODE_T * p) { A68_REF name; ADDR_T sp = stack_pointer; MOID_T *dst = MOID (p), *src = MOID (SUB (p)); EXECUTE_UNIT (SUB (p)); STACK_DNS (p, MOID (SUB (p)), frame_pointer); stack_pointer = sp; name = genie_make_ref_row_of_row (p, dst, src, sp); PUSH_REF (p, name); return (GPROP (p)); } /** @brief Rowing coercion. @param p Node in syntax tree. @return Propagator for this action. **/ static PROP_T genie_rowing (NODE_T * p) { PROP_T self; if (IS (MOID (p), REF_SYMBOL)) { /* REF ROW, decide whether we want A->[] A or [] A->[,] A */ MOID_T *mode = SUB_MOID (p); if (DIM (DEFLEX (mode)) >= 2) { (void) genie_rowing_ref_row_row (p); UNIT (&self) = genie_rowing_ref_row_row; SOURCE (&self) = p; } else { (void) genie_rowing_ref_row_of_row (p); UNIT (&self) = genie_rowing_ref_row_of_row; SOURCE (&self) = p; } } else { /* ROW, decide whether we want A->[] A or [] A->[,] A */ if (DIM (DEFLEX (MOID (p))) >= 2) { (void) genie_rowing_row_row (p); UNIT (&self) = genie_rowing_row_row; SOURCE (&self) = p; } else { (void) genie_rowing_row_of_row (p); UNIT (&self) = genie_rowing_row_of_row; SOURCE (&self) = p; } } return (self); } /** @brief Clone a compounded value refered to by 'old'. @param p Node in syntax tree. @param m Mode of object. @param old Fat pointer to old object. @param tmp Used for bound checks, NIL if irrelevant. @return Fat pointer to descriptor or structured value. **/ A68_REF genie_clone (NODE_T * p, MOID_T *m, A68_REF *tmp, A68_REF *old) { /* This complex routine is needed as arrays are not always contiguous. The routine takes a REF to the value and returns a REF to the clone. */ if (m == MODE (SOUND)) { /* REF SOUND */ A68_REF nsound; A68_SOUND *w; int size; BYTE_T *owd; nsound = heap_generator (p, m, SIZE (m)); w = DEREF (A68_SOUND, &nsound); size = A68_SOUND_DATA_SIZE (w); COPY ((BYTE_T *) w, ADDRESS (old), SIZE (MODE (SOUND))); owd = ADDRESS (&(DATA (w))); DATA (w) = heap_generator (p, MODE (SOUND_DATA), size); COPY (ADDRESS (&(DATA (w))), owd, size); return (nsound); } else if (IS (m, STRUCT_SYMBOL)) { /* REF STRUCT */ PACK_T *fds; A68_REF nstruct; nstruct = heap_generator (p, m, SIZE (m)); for (fds = PACK (m); fds != NO_PACK; FORWARD (fds)) { MOID_T *fm = MOID (fds); A68_REF of = *old, nf = nstruct, tf = *tmp; OFFSET (&of) += OFFSET (fds); OFFSET (&nf) += OFFSET (fds); if (! IS_NIL (tf)) { OFFSET (&tf) += OFFSET (fds); } if (HAS_ROWS (fm)) { A68_REF a68_clone = genie_clone (p, fm, &tf, &of); MOVE (ADDRESS (&nf), ADDRESS (&a68_clone), SIZE (fm)); } else { MOVE (ADDRESS (&nf), ADDRESS (&of), SIZE (fm)); } } return (nstruct); } else if (IS (m, UNION_SYMBOL)) { /* REF UNION */ A68_REF nunion, src, dst, tmpu; A68_UNION *u; MOID_T *um; nunion = heap_generator (p, m, SIZE (m)); src = *old; u = DEREF (A68_UNION, &src); um = (MOID_T *) VALUE (u); OFFSET (&src) += UNION_OFFSET; dst = nunion; * DEREF (A68_UNION, &dst) = *u; OFFSET (&dst) += UNION_OFFSET; /* A union has formal members, so tmp is irrelevant */ tmpu = nil_ref; if (um != NO_MOID && HAS_ROWS (um)) { A68_REF a68_clone = genie_clone (p, um, &tmpu, &src); MOVE (ADDRESS (&dst), ADDRESS (&a68_clone), SIZE (um)); } else if (um != NO_MOID) { MOVE (ADDRESS (&dst), ADDRESS (&src), SIZE (um)); } return (nunion); } else if (IF_ROW (m)) { /* REF [FLEX] [] */ A68_REF nrow, ntmp, heap; A68_ARRAY *oarr, *narr, *tarr; A68_TUPLE *otup, *ntup, *ttup = NO_TUPLE, *op, *np, *tp; MOID_T *em = SUB (IS (m, FLEX_SYMBOL) ? SUB (m) : m); int k, span; BOOL_T check_bounds; /* Make new array */ GET_DESCRIPTOR (oarr, otup, DEREF (A68_REF, old)); nrow = heap_generator (p, m, SIZE_AL (A68_ARRAY) + DIM (oarr) * SIZE_AL (A68_TUPLE)); /* Now fill the new descriptor */ GET_DESCRIPTOR (narr, ntup, &nrow); DIM (narr) = DIM (oarr); MOID (narr) = MOID (oarr); ELEM_SIZE (narr) = ELEM_SIZE (oarr); SLICE_OFFSET (narr) = 0; FIELD_OFFSET (narr) = 0; /* Get size and copy bounds; check in case of a row. This is just song and dance to comply with the RR. */ check_bounds = A68_FALSE; if (IS_NIL (*tmp)) { ntmp = nil_ref; } else { A68_REF *z = DEREF (A68_REF, tmp); if (!IS_NIL (*z)) { GET_DESCRIPTOR (tarr, ttup, z); ntmp = ARRAY (tarr); check_bounds = IS (m, ROW_SYMBOL); } } for (span = 1, k = 0; k < DIM (oarr); k++) { op = &otup[k]; np = &ntup[k]; if (check_bounds) { tp = &ttup[k]; if (UPB (tp) != UPB (op) || LWB (tp) != LWB (op)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } } LWB (np) = LWB (op); UPB (np) = UPB (op); SPAN (np) = span; SHIFT (np) = LWB (np) * SPAN (np); span *= ROW_SIZE (np); } /* Make a new array with at least a ghost element */ if (span == 0) { ARRAY (narr) = heap_generator (p, em, ELEM_SIZE (narr)); } else { ARRAY (narr) = heap_generator (p, em, span * ELEM_SIZE (narr)); } /* Copy the ghost element if there are no elements */ if (span == 0 && HAS_ROWS (em)) { A68_REF nold, ndst, a68_clone; nold = ARRAY (oarr); OFFSET (&nold) += ROW_ELEMENT (oarr, 0); ndst = ARRAY (narr); OFFSET (&ndst) += ROW_ELEMENT (narr, 0); a68_clone = genie_clone (p, em, &ntmp, &nold); MOVE (ADDRESS (&ndst), ADDRESS (&a68_clone), SIZE (em)); } else if (span > 0) { /* The n-dimensional copier */ BOOL_T done = A68_FALSE; initialise_internal_index (otup, DIM (oarr)); initialise_internal_index (ntup, DIM (narr)); while (!done) { A68_REF nold = ARRAY (oarr); A68_REF ndst = ARRAY (narr); ADDR_T oindex = calculate_internal_index (otup, DIM (oarr)); ADDR_T nindex = calculate_internal_index (ntup, DIM (narr)); OFFSET (&nold) += ROW_ELEMENT (oarr, oindex); OFFSET (&ndst) += ROW_ELEMENT (narr, nindex); if (HAS_ROWS (em)) { A68_REF a68_clone; a68_clone = genie_clone (p, em, &ntmp, &nold); MOVE (ADDRESS (&ndst), ADDRESS (&a68_clone), SIZE (em)); } else { MOVE (ADDRESS (&ndst), ADDRESS (&nold), SIZE (em)); } /* Increase pointers */ done = increment_internal_index (otup, DIM (oarr)) | increment_internal_index (ntup, DIM (narr)); } } heap = heap_generator (p, m, A68_REF_SIZE); * DEREF (A68_REF, &heap) = nrow; return (heap); } return (nil_ref); } /** @brief Store into a row, fi. trimmed destinations . @param p Node in syntax tree. @param m Mode of object. @param dst REF destination @param old REF old object @return Dst. **/ A68_REF genie_store (NODE_T * p, MOID_T *m, A68_REF *dst, A68_REF *old) { /* This complex routine is needed as arrays are not always contiguous. The routine takes a REF to the value and returns a REF to the clone. */ if (IF_ROW (m)) { /* REF [FLEX] [] */ A68_ARRAY *old_arr, *new_arr; A68_TUPLE *old_tup, *new_tup, *old_p, *new_p; MOID_T *em = SUB (IS (m, FLEX_SYMBOL) ? SUB (m) : m); int k, span; BOOL_T done = A68_FALSE; GET_DESCRIPTOR (old_arr, old_tup, DEREF (A68_REF, old)); GET_DESCRIPTOR (new_arr, new_tup, DEREF (A68_REF, dst)); /* Get size and check bounds. This is just song and dance to comply with the RR. */ for (span = 1, k = 0; k < DIM (old_arr); k++) { old_p = &old_tup[k]; new_p = &new_tup[k]; if ((UPB (new_p) != UPB (old_p) || LWB (new_p) != LWB (old_p))) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIFFERENT_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } span *= ROW_SIZE (new_p); } if (span > 0) { initialise_internal_index (old_tup, DIM (old_arr)); initialise_internal_index (new_tup, DIM (new_arr)); while (!done) { A68_REF new_old = ARRAY (old_arr); A68_REF new_dst = ARRAY (new_arr); ADDR_T old_index = calculate_internal_index (old_tup, DIM (old_arr)); ADDR_T new_index = calculate_internal_index (new_tup, DIM (new_arr)); OFFSET (&new_old) += ROW_ELEMENT (old_arr, old_index); OFFSET (&new_dst) += ROW_ELEMENT (new_arr, new_index); MOVE (ADDRESS (&new_dst), ADDRESS (&new_old), SIZE (em)); done = increment_internal_index (old_tup, DIM (old_arr)) | increment_internal_index (new_tup, DIM (new_arr)); } } return (*dst); } return (nil_ref); } /** @brief Assignment of complex objects in the stack. @param p Node in syntax tree. @param dst REF to destination @param tmp REF to template for bounds checks @param srcm Mode of source. **/ static void genie_clone_stack (NODE_T *p, MOID_T *srcm, A68_REF *dst, A68_REF *tmp) { /* STRUCT, UNION, [FLEX] [] or SOUND */ A68_REF stack, *src, a68_clone; STATUS (&stack) = (STATUS_MASK) (INIT_MASK | IN_STACK_MASK); OFFSET (&stack) = stack_pointer; REF_HANDLE (&stack) = &nil_handle; src = DEREF (A68_REF, &stack); if (IS (srcm, ROW_SYMBOL) && !IS_NIL (*tmp)) { if (STATUS (src) & SKIP_ROW_MASK) { return; } a68_clone = genie_clone (p, srcm, tmp, &stack); (void) genie_store (p, srcm, dst, &a68_clone); } else { a68_clone = genie_clone (p, srcm, tmp, &stack); MOVE (ADDRESS (dst), ADDRESS (&a68_clone), SIZE (srcm)); } } /** @brief Push description for diagonal of square matrix. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_diagonal_function (NODE_T * p) { NODE_T *q = SUB (p); ADDR_T scope = PRIMAL_SCOPE; PROP_T self; A68_ROW row, new_row; int k = 0; BOOL_T name = (BOOL_T) (IS (MOID (p), REF_SYMBOL)); A68_ARRAY *arr, new_arr; A68_TUPLE *tup1, *tup2, new_tup; MOID_T *m; if (IS (q, TERTIARY)) { A68_INT x; EXECUTE_UNIT (q); POP_OBJECT (p, &x, A68_INT); k = VALUE (&x); FORWARD (q); } EXECUTE_UNIT (NEXT (q)); m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q))); if (name) { A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); scope = REF_SCOPE (&z); PUSH_REF (p, * DEREF (A68_REF, &z)); } POP_OBJECT (p, &row, A68_ROW); GET_DESCRIPTOR2 (arr, tup1, tup2, &row); if (ROW_SIZE (tup1) != ROW_SIZE (tup2)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_NO_SQUARE_MATRIX, m); exit_genie (p, A68_RUNTIME_ERROR); } if (ABS (k) >= ROW_SIZE (tup1)) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS); exit_genie (p, A68_RUNTIME_ERROR); } m = (name ? SUB_MOID (p) : MOID (p)); new_row = heap_generator (p, m, SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); DIM (&new_arr) = 1; MOID (&new_arr) = m; ELEM_SIZE (&new_arr) = ELEM_SIZE (arr); SLICE_OFFSET (&new_arr) = SLICE_OFFSET (arr); FIELD_OFFSET (&new_arr) = FIELD_OFFSET (arr); ARRAY (&new_arr) = ARRAY (arr); LWB (&new_tup) = 1; UPB (&new_tup) = ROW_SIZE (tup1) - ABS (k); SHIFT (&new_tup) = SHIFT (tup1) + SHIFT (tup2) - k * SPAN (tup2); if (k < 0) { SHIFT (&new_tup) -= (-k) * (SPAN (tup1) + SPAN (tup2)); } SPAN (&new_tup) = SPAN (tup1) + SPAN (tup2); K (&new_tup) = 0; PUT_DESCRIPTOR (new_arr, new_tup, &new_row); if (name) { A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE); * DEREF (A68_REF, &ref_new) = new_row; REF_SCOPE (&ref_new) = scope; PUSH_REF (p, ref_new); } else { PUSH_OBJECT (p, new_row, A68_ROW); } UNIT (&self) = genie_diagonal_function; SOURCE (&self) = p; return (self); } /** @brief Push description for transpose of matrix. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_transpose_function (NODE_T * p) { NODE_T *q = SUB (p); ADDR_T scope = PRIMAL_SCOPE; PROP_T self; A68_ROW row, new_row; BOOL_T name = (BOOL_T) (IS (MOID (p), REF_SYMBOL)); A68_ARRAY *arr, new_arr; A68_TUPLE *tup1, *tup2, new_tup1, new_tup2; MOID_T *m; EXECUTE_UNIT (NEXT (q)); m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q))); if (name) { A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); scope = REF_SCOPE (&z); PUSH_REF (p, * DEREF (A68_REF, &z)); } POP_OBJECT (p, &row, A68_ROW); GET_DESCRIPTOR2 (arr, tup1, tup2, &row); new_row = heap_generator (p, m, SIZE_AL (A68_ARRAY) + 2 * SIZE_AL (A68_TUPLE)); new_arr = *arr; new_tup1 = *tup2; new_tup2 = *tup1; PUT_DESCRIPTOR2 (new_arr, new_tup1, new_tup2, &new_row); if (name) { A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE); * DEREF (A68_REF, &ref_new) = new_row; REF_SCOPE (&ref_new) = scope; PUSH_REF (p, ref_new); } else { PUSH_OBJECT (p, new_row, A68_ROW); } UNIT (&self) = genie_transpose_function; SOURCE (&self) = p; return (self); } /** @brief Push description for row vector. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_row_function (NODE_T * p) { NODE_T *q = SUB (p); ADDR_T scope = PRIMAL_SCOPE; PROP_T self; A68_ROW row, new_row; int k = 1; BOOL_T name = (BOOL_T) (IS (MOID (p), REF_SYMBOL)); A68_ARRAY *arr, new_arr; A68_TUPLE tup1, tup2, *tup; MOID_T *m; if (IS (q, TERTIARY)) { A68_INT x; EXECUTE_UNIT (q); POP_OBJECT (p, &x, A68_INT); k = VALUE (&x); FORWARD (q); } EXECUTE_UNIT (NEXT (q)); m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q))); if (name) { A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); scope = REF_SCOPE (&z); PUSH_REF (p, * DEREF (A68_REF, &z)); } POP_OBJECT (p, &row, A68_ROW); GET_DESCRIPTOR (arr, tup, &row); if (DIM (arr) != 1) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_NO_VECTOR, m, PRIMARY); exit_genie (p, A68_RUNTIME_ERROR); } m = (name ? SUB_MOID (p) : MOID (p)); new_row = heap_generator (p, m, SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); DIM (&new_arr) = 2; MOID (&new_arr) = m; ELEM_SIZE (&new_arr) = ELEM_SIZE (arr); SLICE_OFFSET (&new_arr) = SLICE_OFFSET (arr); FIELD_OFFSET (&new_arr) = FIELD_OFFSET (arr); ARRAY (&new_arr) = ARRAY (arr); LWB (&tup1) = k; UPB (&tup1) = k; SPAN (&tup1) = 1; SHIFT (&tup1) = k * SPAN (&tup1); K (&tup1) = 0; LWB (&tup2) = 1; UPB (&tup2) = ROW_SIZE (tup); SPAN (&tup2) = SPAN (tup); SHIFT (&tup2) = SPAN (tup); K (&tup2) = 0; PUT_DESCRIPTOR2 (new_arr, tup1, tup2, &new_row); if (name) { A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE); * DEREF (A68_REF, &ref_new) = new_row; REF_SCOPE (&ref_new) = scope; PUSH_REF (p, ref_new); } else { PUSH_OBJECT (p, new_row, A68_ROW); } UNIT (&self) = genie_row_function; SOURCE (&self) = p; return (self); } /** @brief Push description for column vector. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_column_function (NODE_T * p) { NODE_T *q = SUB (p); ADDR_T scope = PRIMAL_SCOPE; PROP_T self; A68_ROW row, new_row; int k = 1; BOOL_T name = (BOOL_T) (IS (MOID (p), REF_SYMBOL)); A68_ARRAY *arr, new_arr; A68_TUPLE tup1, tup2, *tup; MOID_T *m; if (IS (q, TERTIARY)) { A68_INT x; EXECUTE_UNIT (q); POP_OBJECT (p, &x, A68_INT); k = VALUE (&x); FORWARD (q); } EXECUTE_UNIT (NEXT (q)); m = (name ? SUB_MOID (NEXT (q)) : MOID (NEXT (q))); if (name) { A68_REF z; POP_REF (p, &z); CHECK_REF (p, z, MOID (SUB (p))); scope = REF_SCOPE (&z); PUSH_REF (p, * DEREF (A68_REF, &z)); } POP_OBJECT (p, &row, A68_ROW); GET_DESCRIPTOR (arr, tup, &row); m = (name ? SUB_MOID (p) : MOID (p)); new_row = heap_generator (p, m, SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); DIM (&new_arr) = 2; MOID (&new_arr) = m; ELEM_SIZE (&new_arr) = ELEM_SIZE (arr); SLICE_OFFSET (&new_arr) = SLICE_OFFSET (arr); FIELD_OFFSET (&new_arr) = FIELD_OFFSET (arr); ARRAY (&new_arr) = ARRAY (arr); LWB (&tup1) = 1; UPB (&tup1) = ROW_SIZE (tup); SPAN (&tup1) = SPAN (tup); SHIFT (&tup1) = SPAN (tup); K (&tup1) = 0; LWB (&tup2) = k; UPB (&tup2) = k; SPAN (&tup2) = 1; SHIFT (&tup2) = k * SPAN (&tup2); K (&tup2) = 0; PUT_DESCRIPTOR2 (new_arr, tup1, tup2, &new_row); if (name) { A68_REF ref_new = heap_generator (p, MOID (p), A68_REF_SIZE); * DEREF (A68_REF, &ref_new) = new_row; REF_SCOPE (&ref_new) = scope; PUSH_REF (p, ref_new); } else { PUSH_OBJECT (p, new_row, A68_ROW); } UNIT (&self) = genie_column_function; SOURCE (&self) = p; return (self); } /** @brief Strcmp for qsort. @param a String. @param b String. @return A - b. **/ int qstrcmp (const void *a, const void *b) { return (strcmp (*(char *const *) a, *(char *const *) b)); } /** @brief Sort row of string. @param p Node in syntax tree. **/ void genie_sort_row_string (NODE_T * p) { A68_REF z; A68_ARRAY *arr; A68_TUPLE *tup; ADDR_T pop_sp; int size; POP_REF (p, &z); pop_sp = stack_pointer; CHECK_REF (p, z, MODE (ROW_STRING)); GET_DESCRIPTOR (arr, tup, &z); size = ROW_SIZE (tup); if (size > 0) { A68_REF row, *base_ref; A68_ARRAY arrn; A68_TUPLE tupn; int j, k; BYTE_T *base = ADDRESS (&ARRAY (arr)); char **ptrs = (char **) malloc ((size_t) (size * (int) sizeof (char *))); if (ptrs == NO_VAR) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } /* Copy C-strings into the stack and sort */ for (j = 0, k = LWB (tup); k <= UPB (tup); j++, k++) { int addr = INDEX_1_DIM (arr, tup, k); A68_REF ref = *(A68_REF *) & (base[addr]); int len; CHECK_REF (p, ref, MODE (STRING)); len = A68_ALIGN (a68_string_size (p, ref) + 1); if (stack_pointer + len > expr_stack_limit) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW); exit_genie (p, A68_RUNTIME_ERROR); } ptrs[j] = (char *) STACK_TOP; ASSERT (a_to_c_string (p, (char *) STACK_TOP, ref) != NO_TEXT); INCREMENT_STACK_POINTER (p, len); } qsort (ptrs, (size_t) size, sizeof (char *), qstrcmp); /* Construct an array of sorted strings */ z = heap_generator (p, MODE (ROW_STRING), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_STRING), size * SIZE (MODE (STRING))); DIM (&arrn) = 1; MOID (&arrn) = MODE (STRING); ELEM_SIZE (&arrn) = SIZE (MODE (STRING)); SLICE_OFFSET (&arrn) = 0; FIELD_OFFSET (&arrn) = 0; ARRAY (&arrn) = row; LWB (&tupn) = 1; UPB (&tupn) = size; SHIFT (&tupn) = LWB (&tupn); SPAN (&tupn) = 1; K (&tupn) = 0; PUT_DESCRIPTOR (arrn, tupn, &z); base_ref = DEREF (A68_REF, &row); for (k = 0; k < size; k++) { base_ref[k] = c_to_a_string (p, ptrs[k], DEFAULT_WIDTH); } free (ptrs); stack_pointer = pop_sp; PUSH_REF (p, z); } else { /* This is how we sort an empty row of strings .. */ stack_pointer = pop_sp; PUSH_REF (p, empty_row (p, MODE (ROW_STRING))); } } /* Generator and garbage collector routines. The generator allocates space in stack or heap and initialises dynamically sized objects. A mark-and-gc garbage collector defragments the heap. When called, it walks the stack frames and marks the heap space that is still active. This marking process is called "colouring" here since we "pour paint" into the heap. The active blocks are then joined, the non-active blocks are forgotten. When colouring the heap, "cookies" are placed in objects as to find circular references. Algol68G introduces several anonymous tags in the symbol tables that save temporary REF or ROW results, so that they do not get prematurely swept. The genie is not smart enough to handle every heap clog, e.g. when copying STOWED objects. This seems not very elegant, but garbage collectors in general cannot solve all core management problems. To avoid many of the "unforeseen" heap clogs, we try to keep heap occupation low by garbage collecting occasionally, before it fills up completely. If this automatic mechanism does not help, one can always invoke the garbage collector by calling "gc heap" from Algol 68 source text. Mark-and-gc is simple but since it walks recursive structures, it could exhaust the C-stack (segment violation). A rough check is in place. */ void colour_object (BYTE_T *, MOID_T *); void gc_heap (NODE_T *, ADDR_T); int garbage_collects, garbage_bytes_freed; int free_handle_count, max_handle_count; A68_HANDLE *free_handles, *busy_handles; double garbage_seconds; #define DEF_NODE(p) (NEXT_NEXT (NODE (TAX (p)))) #define MAX(u, v) ((u) = ((u) > (v) ? (u) : (v))) void genie_generator_stowed (NODE_T *, BYTE_T *, NODE_T **, ADDR_T *); /* Total freed is kept in a LONG INT */ MP_T garbage_total_freed[LONG_MP_DIGITS + 2]; static MP_T garbage_freed[LONG_MP_DIGITS + 2]; /** @brief PROC VOID gc heap @param p Node in syntax tree. **/ void genie_gc_heap (NODE_T * p) { gc_heap (p, frame_pointer); } /** @brief PROC VOID preemptive gc heap @param p Node in syntax tree. **/ void genie_preemptive_gc_heap (NODE_T * p) { PREEMPTIVE_GC; } /** @brief INT blocks @param p Node in syntax tree. **/ void genie_block (NODE_T * p) { PUSH_PRIMITIVE (p, 0, A68_INT); } /** @brief INT collections @param p Node in syntax tree. **/ void genie_garbage_collections (NODE_T * p) { PUSH_PRIMITIVE (p, garbage_collects, A68_INT); } /** @brief LONG INT garbage @param p Node in syntax tree. **/ void genie_garbage_freed (NODE_T * p) { PUSH (p, garbage_total_freed, moid_size (MODE (LONG_INT))); } /** @brief REAL collect seconds @param p Node in syntax tree. **/ void genie_garbage_seconds (NODE_T * p) { /* Note that this timing is a rough cut */ PUSH_PRIMITIVE (p, garbage_seconds, A68_REAL); } /** @brief Size available for an object in the heap. @return Size available in bytes. **/ int heap_available (void) { return (heap_size - heap_pointer); } /** @brief Initialise heap management. @param p Node in syntax tree. **/ void genie_init_heap (NODE_T * p) { A68_HANDLE *z; int k, max; (void) p; if (heap_segment == NO_BYTE) { diagnostic_node (A68_RUNTIME_ERROR, TOP_NODE (&program), ERROR_OUT_OF_CORE); exit_genie (TOP_NODE (&program), A68_RUNTIME_ERROR); } if (handle_segment == NO_BYTE) { diagnostic_node (A68_RUNTIME_ERROR, TOP_NODE (&program), ERROR_OUT_OF_CORE); exit_genie (TOP_NODE (&program), A68_RUNTIME_ERROR); } garbage_seconds = 0; SET_MP_ZERO (garbage_total_freed, LONG_MP_DIGITS); garbage_collects = 0; ABEND (fixed_heap_pointer >= (heap_size - MIN_MEM_SIZE), ERROR_OUT_OF_CORE, NO_TEXT); heap_pointer = fixed_heap_pointer; heap_is_fluid = A68_FALSE; /* Assign handle space */ z = (A68_HANDLE *) handle_segment; free_handles = z; busy_handles = NO_HANDLE; max = (int) handle_pool_size / (int) sizeof (A68_HANDLE); free_handle_count = max; max_handle_count = max; for (k = 0; k < max; k++) { STATUS (&(z[k])) = NULL_MASK; POINTER (&(z[k])) = NO_BYTE; SIZE (&(z[k])) = 0; NEXT (&z[k]) = (k == max - 1 ? NO_HANDLE : &z[k + 1]); PREVIOUS (&z[k]) = (k == 0 ? NO_HANDLE : &z[k - 1]); } } /** @brief Whether mode must be coloured. @param m Moid to colour. @return See brief description. **/ static BOOL_T moid_needs_colouring (MOID_T * m) { if (IS (m, REF_SYMBOL)) { return (A68_TRUE); } else if (IS (m, PROC_SYMBOL)) { return (A68_TRUE); } else if (IS (m, FLEX_SYMBOL) || IS (m, ROW_SYMBOL)) { return (A68_TRUE); } else if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL)) { PACK_T *p = PACK (m); for (; p != NO_PACK; FORWARD (p)) { if (moid_needs_colouring (MOID (p))) { return (A68_TRUE); } } return (A68_FALSE); } else { return (A68_FALSE); } } /** @brief Colour all elements of a row. @param z Fat pointer to descriptor. @param m Mode of row. **/ static void colour_row_elements (A68_REF * z, MOID_T * m) { A68_ARRAY *arr; A68_TUPLE *tup; GET_DESCRIPTOR (arr, tup, z); if (get_row_size (tup, DIM (arr)) == 0) { /* Empty rows have a ghost elements */ BYTE_T *elem = ADDRESS (&ARRAY (arr)); colour_object (&elem[0], SUB (m)); } else { /* The multi-dimensional garbage collector */ BYTE_T *elem = ADDRESS (&ARRAY (arr)); BOOL_T done = A68_FALSE; initialise_internal_index (tup, DIM (arr)); while (!done) { ADDR_T iindex = calculate_internal_index (tup, DIM (arr)); ADDR_T addr = ROW_ELEMENT (arr, iindex); colour_object (&elem[addr], SUB (m)); done = increment_internal_index (tup, DIM (arr)); } } } /** @brief Colour an (active) object. @param item Pointer to item to colour. @param m Mode of item. **/ void colour_object (BYTE_T * item, MOID_T * m) { if (item == NO_BYTE || m == NO_MOID) { return; } if (!moid_needs_colouring (m)) { return; } /* Deeply recursive objects might exhaust the stack */ LOW_STACK_ALERT (NO_NODE); if (IS (m, REF_SYMBOL)) { /* REF AMODE colour pointer and object to which it refers */ A68_REF *z = (A68_REF *) item; if (INITIALISED (z) && IS_IN_HEAP (z)) { if (STATUS_TEST (REF_HANDLE (z), COOKIE_MASK)) { return; } STATUS_SET (REF_HANDLE (z), (COOKIE_MASK | COLOUR_MASK)); if (!IS_NIL (*z)) { colour_object (ADDRESS (z), SUB (m)); } STATUS_CLEAR (REF_HANDLE (z), COOKIE_MASK); } } else if (IS (m, FLEX_SYMBOL) || IS (m, ROW_SYMBOL) || m == MODE (STRING)) { /* Claim the descriptor and the row itself */ A68_REF *z = (A68_REF *) item; if (INITIALISED (z) && IS_IN_HEAP (z)) { A68_ARRAY *arr; A68_TUPLE *tup; if (STATUS_TEST (REF_HANDLE (z), COOKIE_MASK)) { return; } /* An array is ALWAYS in the heap */ STATUS_SET (REF_HANDLE (z), (COOKIE_MASK | COLOUR_MASK)); GET_DESCRIPTOR (arr, tup, z); if (REF_HANDLE (&(ARRAY (arr))) != NO_HANDLE) { /* Assume its initialisation */ MOID_T *n = DEFLEX (m); STATUS_SET (REF_HANDLE (&(ARRAY (arr))), COLOUR_MASK); if (moid_needs_colouring (SUB (n))) { colour_row_elements (z, n); } } /* STATUS_CLEAR (REF_HANDLE (z), COOKIE_MASK); */ } } else if (IS (m, STRUCT_SYMBOL)) { /* STRUCTures - colour fields */ PACK_T *p = PACK (m); for (; p != NO_PACK; FORWARD (p)) { colour_object (&item[OFFSET (p)], MOID (p)); } } else if (IS (m, UNION_SYMBOL)) { /* UNIONs - a united object may contain a value that needs colouring */ A68_UNION *z = (A68_UNION *) item; if (INITIALISED (z)) { MOID_T *united_moid = (MOID_T *) VALUE (z); colour_object (&item[A68_UNION_SIZE], united_moid); } } else if (IS (m, PROC_SYMBOL)) { /* PROCs - save a locale and the objects it points to */ A68_PROCEDURE *z = (A68_PROCEDURE *) item; if (INITIALISED (z) && LOCALE (z) != NO_HANDLE && !(STATUS_TEST (LOCALE (z), COOKIE_MASK))) { BYTE_T *u = POINTER (LOCALE (z)); PACK_T *s = PACK (MOID (z)); STATUS_SET (LOCALE (z), (COOKIE_MASK | COLOUR_MASK)); for (; s != NO_PACK; FORWARD (s)) { if (VALUE ((A68_BOOL *) & u[0]) == A68_TRUE) { colour_object (&u[SIZE (MODE (BOOL))], MOID (s)); } u = &(u[SIZE (MODE (BOOL)) + SIZE (MOID (s))]); } STATUS_CLEAR (LOCALE (z), COOKIE_MASK); } } else if (m == MODE (SOUND)) { /* Claim the data of a SOUND object, that is in the heap */ A68_SOUND *w = (A68_SOUND *) item; if (INITIALISED (w)) { STATUS_SET (REF_HANDLE (&(DATA (w))), (COOKIE_MASK | COLOUR_MASK)); } } } /** @brief Colour active objects in the heap. @param fp Running frame pointer. **/ static void colour_heap (ADDR_T fp) { while (fp != 0) { NODE_T *p = FRAME_TREE (fp); TABLE_T *q = TABLE (p); if (q != NO_TABLE) { TAG_T *i; for (i = IDENTIFIERS (q); i != NO_TAG; FORWARD (i)) { colour_object (FRAME_LOCAL (fp, OFFSET (i)), MOID (i)); } for (i = ANONYMOUS (q); i != NO_TAG; FORWARD (i)) { if (PRIO (i) == GENERATOR) { colour_object (FRAME_LOCAL (fp, OFFSET (i)), MOID (i)); } } } fp = FRAME_DYNAMIC_LINK (fp); } } /** @brief Join all active blocks in the heap. **/ static void defragment_heap (void) { A68_HANDLE *z; /* Free handles */ z = busy_handles; while (z != NO_HANDLE) { if (!(STATUS_TEST (z, COLOUR_MASK)) && !(STATUS_TEST (z, BLOCK_GC_MASK))) { A68_HANDLE *y = NEXT (z); if (PREVIOUS (z) == NO_HANDLE) { busy_handles = NEXT (z); } else { NEXT (PREVIOUS (z)) = NEXT (z); } if (NEXT (z) != NO_HANDLE) { PREVIOUS (NEXT (z)) = PREVIOUS (z); } NEXT (z) = free_handles; PREVIOUS (z) = NO_HANDLE; if (NEXT (z) != NO_HANDLE) { PREVIOUS (NEXT (z)) = z; } free_handles = z; STATUS_CLEAR (z, ALLOCATED_MASK); garbage_bytes_freed += SIZE (z); free_handle_count++; z = y; } else { FORWARD (z); } } /* There can be no uncoloured allocated handle */ for (z = busy_handles; z != NO_HANDLE; FORWARD (z)) { ABEND (!(STATUS_TEST (z, COLOUR_MASK)) && !(STATUS_TEST (z, BLOCK_GC_MASK)), "bad GC consistency", NO_TEXT); } /* Defragment the heap */ heap_pointer = fixed_heap_pointer; for (z = busy_handles; z != NO_HANDLE && NEXT (z) != NO_HANDLE; FORWARD (z)) { ; } for (; z != NO_HANDLE; BACKWARD (z)) { BYTE_T *dst = HEAP_ADDRESS (heap_pointer); if (dst != POINTER (z)) { MOVE (dst, POINTER (z), (unsigned) SIZE (z)); } STATUS_CLEAR (z, (COLOUR_MASK | COOKIE_MASK)); POINTER (z) = dst; heap_pointer += (SIZE (z)); ABEND (heap_pointer % A68_ALIGNMENT != 0, ERROR_ALIGNMENT, NO_TEXT); } } /** @brief Clean up garbage and defragment the heap. @param p Node in syntax tree. @param fp Running frame pointer. **/ void gc_heap (NODE_T * p, ADDR_T fp) { /* Must start with fp = current frame_pointer */ A68_HANDLE *z; double t0, t1; #if defined HAVE_PARALLEL_CLAUSE if (pthread_equal (FRAME_THREAD_ID (frame_pointer), main_thread_id) ==0) { return; } #endif t0 = seconds (); /* Unfree handles are subject to inspection */ for (z = busy_handles; z != NO_HANDLE; FORWARD (z)) { STATUS_CLEAR (z, (COLOUR_MASK | COOKIE_MASK)); } /* Pour paint into the heap to reveal active objects */ colour_heap (fp); /* Start freeing and compacting */ garbage_bytes_freed = 0; defragment_heap (); /* Stats and logging */ (void) int_to_mp (p, garbage_freed, (int) garbage_bytes_freed, LONG_MP_DIGITS); (void) add_mp (p, garbage_total_freed, garbage_total_freed, garbage_freed, LONG_MP_DIGITS); garbage_collects++; t1 = seconds (); /* C optimiser can make last digit differ, so next condition is needed to determine a positive time difference */ if ((t1 - t0) > ((double) clock_res / 2.0)) { garbage_seconds += (t1 - t0); } else { garbage_seconds += ((double) clock_res / 2.0); } /* Call the event handler */ genie_call_event_routine (p, MODE (PROC_VOID), &on_gc_event, stack_pointer, frame_pointer); } /** @brief Yield a handle that will point to a block in the heap. @param p Node in syntax tree. @param a68m mode of object @return Handle that points to object. **/ static A68_HANDLE *give_handle (NODE_T * p, MOID_T * a68m) { if (free_handles != NO_HANDLE) { A68_HANDLE *x = free_handles; free_handles = NEXT (x); if (free_handles != NO_HANDLE) { PREVIOUS (free_handles) = NO_HANDLE; } STATUS (x) = ALLOCATED_MASK; POINTER (x) = NO_BYTE; SIZE (x) = 0; MOID (x) = a68m; NEXT (x) = busy_handles; PREVIOUS (x) = NO_HANDLE; if (NEXT (x) != NO_HANDLE) { PREVIOUS (NEXT (x)) = x; } busy_handles = x; free_handle_count--; return (x); } else { /* Do not auto-GC! */ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); } return (NO_HANDLE); } /** @brief Give a block of heap for an object of indicated mode. @param p Node in syntax tree. @param mode Mode of object. @param size Size in bytes to allocate. @return Fat pointer to object in the heap. **/ A68_REF heap_generator (NODE_T * p, MOID_T * mode, int size) { /* Align */ ABEND (size < 0, ERROR_INVALID_SIZE, NO_TEXT); size = A68_ALIGN (size); /* Now give it */ if (heap_available () >= size) { A68_HANDLE *x; A68_REF z; STATUS (&z) = (STATUS_MASK) (INIT_MASK | IN_HEAP_MASK); OFFSET (&z) = 0; x = give_handle (p, mode); SIZE (x) = size; POINTER (x) = HEAP_ADDRESS (heap_pointer); FILL (POINTER (x), 0, size); REF_SCOPE (&z) = PRIMAL_SCOPE; REF_HANDLE (&z) = x; ABEND (((long) ADDRESS (&z)) % A68_ALIGNMENT != 0, ERROR_ALIGNMENT, NO_TEXT); heap_pointer += size; return (z); } else { /* Do not auto-GC! */ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_CORE); exit_genie (p, A68_RUNTIME_ERROR); return (nil_ref); } } /* Following implements the generator. For dynamically sized objects, first bounds are evaluated (right first, then down). The object is generated keeping track of the bound-count. ... [#1] STRUCT ( [#2] STRUCT ( [#3] A a, b, ... ) , Advance bound-count here, max is #3 [#4] B a, b, ... ) , Advance bound-count here, max is #4 [#5] C a, b, ... ... Bound-count is maximised when generator_stowed is entered recursively. Bound-count is advanced when completing a STRUCTURED_FIELD. */ /** @brief Whether a moid needs work in allocation. @param m Moid under test. **/ static BOOL_T mode_needs_allocation (MOID_T * m) { if (IS (m, UNION_SYMBOL)) { return (A68_FALSE); } else { return (HAS_ROWS (m)); } } /** @brief Prepare bounds. @param p Node in syntax tree. **/ static void genie_compute_bounds (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, BOUNDS_LIST)) { genie_compute_bounds (SUB (p)); } else if (IS (p, BOUND)) { genie_compute_bounds (SUB (p)); } else if (IS (p, UNIT)) { if (NEXT (p) != NO_NODE && (is_one_of (NEXT (p), COLON_SYMBOL, DOTDOT_SYMBOL, STOP))) { EXECUTE_UNIT (p); p = NEXT_NEXT (p); } else { /* Default lower bound */ PUSH_PRIMITIVE (p, 1, A68_INT); } EXECUTE_UNIT (p); } } } /** @brief Prepare bounds for a row. @param p Node in syntax tree. **/ void genie_generator_bounds (NODE_T * p) { LOW_STACK_ALERT (p); for (; p != NO_NODE; FORWARD (p)) { if (IS (p, BOUNDS)) { genie_compute_bounds (SUB (p)); } 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 = ... */ genie_generator_bounds (DEF_NODE (p)); } } else if (IS (p, DECLARER) && !mode_needs_allocation (MOID (p))) { return; } else { genie_generator_bounds (SUB (p)); } } } /** @brief Allocate a structure. @param p Position in the syntax tree. @param faddr Field address in STRUCT. @param decl Declarer in the syntax tree. @param cur_sp Current stack pointer. @param top_sp Stack pointer value to restore. **/ void genie_generator_field (NODE_T * p, BYTE_T ** faddr, NODE_T ** decl, ADDR_T * cur_sp, ADDR_T *top_sp) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, STRUCTURED_FIELD)) { genie_generator_field (SUB (p), faddr, decl, cur_sp, top_sp); } if (IS (p, DECLARER)) { (*decl) = SUB (p); FORWARD (p); } if (IS (p, FIELD_IDENTIFIER)) { MOID_T *fmoid = MOID (*decl); if (HAS_ROWS (fmoid) && ISNT (fmoid, UNION_SYMBOL)) { ADDR_T pop_sp = *cur_sp; genie_generator_stowed (*decl, *faddr, NO_VAR, cur_sp); *top_sp = *cur_sp; *cur_sp = pop_sp; } (*faddr) += SIZE (fmoid); } } } /** @brief Allocate a structure. @param p Decl in the syntax tree. @param faddr Field address in STRUCT. @param cur_sp Current stack pointer. **/ void genie_generator_struct (NODE_T * p, BYTE_T ** faddr, ADDR_T * cur_sp) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, STRUCTURED_FIELD_LIST)) { genie_generator_struct (SUB (p), faddr, cur_sp); } else if (IS (p, STRUCTURED_FIELD)) { NODE_T *decl = NO_NODE; ADDR_T top_sp = *cur_sp; genie_generator_field (SUB (p), faddr, &decl, cur_sp, &top_sp); *cur_sp = top_sp; } } } /** @brief Allocate a stowed object. @param p Decl in the syntax tree. @param addr Field address in STRUCT. @param decl Declarer in the syntax tree. @param cur_sp Current stack pointer. **/ void genie_generator_stowed (NODE_T * p, BYTE_T * addr, NODE_T ** decl, ADDR_T * cur_sp) { if (p == NO_NODE) { return; } else if (IS (p, INDICANT) && IS_LITERALLY (p, "STRING")) { /* The standard prelude definition is hard coded here */ *((A68_REF *) addr) = empty_string (p); return; } else if (IS (p, INDICANT) && TAX (p) != NO_TAG) { /* Continue from definition at MODE A = . */ genie_generator_stowed (DEF_NODE (p), addr, decl, cur_sp); return; } else if (IS (p, DECLARER) && mode_needs_allocation (MOID (p))) { genie_generator_stowed (SUB (p), addr, decl, cur_sp); return; } else if (IS (p, STRUCT_SYMBOL)) { BYTE_T *faddr = addr; genie_generator_struct (SUB_NEXT (p), &faddr, cur_sp); return; } else if (IS (p, FLEX_SYMBOL)) { genie_generator_stowed (NEXT (p), addr, decl, cur_sp); return; } else if (IS (p, BOUNDS)) { A68_REF desc; MOID_T *rmod = MOID (p), *smod = MOID (NEXT (p)); A68_ARRAY *arr; A68_TUPLE *tup; BYTE_T *bounds = STACK_ADDRESS (*cur_sp); int k, dim = DIM (DEFLEX (rmod)); int esiz = SIZE (smod), rsiz = 1; BOOL_T alloc_sub, alloc_str; NODE_T *in = SUB_NEXT (p); if (IS (in, INDICANT) && IS_LITERALLY (in, "STRING")) { alloc_str = A68_TRUE; alloc_sub = A68_FALSE; } else { alloc_sub = mode_needs_allocation (smod); alloc_str = A68_FALSE; } desc = heap_generator (p, rmod, dim * SIZE_AL (A68_TUPLE) + SIZE_AL (A68_ARRAY)); GET_DESCRIPTOR (arr, tup, &desc); for (k = 0; k < dim; k++) { CHECK_INIT (p, INITIALISED ((A68_INT *) bounds), MODE (INT)); LWB (&tup[k]) = VALUE ((A68_INT *) bounds); bounds += SIZE (MODE (INT)); CHECK_INIT (p, INITIALISED ((A68_INT *) bounds), MODE (INT)); UPB (&tup[k]) = VALUE ((A68_INT *) bounds); bounds += SIZE (MODE (INT)); SPAN (&tup[k]) = rsiz; SHIFT (&tup[k]) = LWB (&tup[k]) * SPAN (&tup[k]); rsiz *= ROW_SIZE (&tup[k]); } DIM (arr) = dim; MOID (arr) = smod; ELEM_SIZE (arr) = esiz; SLICE_OFFSET (arr) = 0; FIELD_OFFSET (arr) = 0; (*cur_sp) += (dim * 2 * SIZE (MODE (INT))); /* Generate a new row. Note that STRING is handled explicitly since it has implicit bounds */ if (rsiz == 0) { /* Generate a ghost element */ ADDR_T top_sp = *cur_sp; BYTE_T *elem; ARRAY (arr) = heap_generator (p, rmod, esiz); elem = ADDRESS (&(ARRAY (arr))); if (alloc_sub) { genie_generator_stowed (NEXT (p), &(elem[0]), NO_VAR, cur_sp); top_sp = *cur_sp; } else if (alloc_str) { * (A68_REF *) elem = empty_string (p); } (*cur_sp) = top_sp; } else { ADDR_T pop_sp = *cur_sp, top_sp = *cur_sp; BYTE_T *elem; ARRAY (arr) = heap_generator (p, rmod, rsiz * esiz); elem = ADDRESS (&(ARRAY (arr))); for (k = 0; k < rsiz; k++) { if (alloc_sub) { (*cur_sp) = pop_sp; genie_generator_stowed (NEXT (p), &(elem[k * esiz]), NO_VAR, cur_sp); top_sp = *cur_sp; } else if (alloc_str) { * (A68_REF *) (&(elem[k * esiz])) = empty_string (p); } } (*cur_sp) = top_sp; } *(A68_REF *) addr = desc; return; } } /** @brief Generate space and push a REF. @param p Declarer in the syntax tree. @param ref_mode REF mode to be generated @param tag Associated internal LOC for this generator. @param leap Where to generate space. @param sp Stack pointer to locate bounds. **/ void genie_generator_internal (NODE_T * p, MOID_T * ref_mode, TAG_T * tag, LEAP_T leap, ADDR_T sp) { MOID_T *mode = SUB (ref_mode); A68_REF name = nil_ref; /* Set up a REF MODE object, either in the stack or in the heap. Note that A68G will not extend stack frames. Thus only 'static' LOC generators are in the stack, and 'dynamic' LOC generators go into the heap. These local REFs in the heap get local scope however, and A68Gs approach differs from the CDC ALGOL 68 approach that put all generators in the heap. */ if (leap == LOC_SYMBOL) { STATUS (&name) = (STATUS_MASK) (INIT_MASK | IN_FRAME_MASK); REF_HANDLE (&name) = &nil_handle; OFFSET (&name) = frame_pointer + FRAME_INFO_SIZE + OFFSET (tag); REF_SCOPE (&name) = frame_pointer; } else if (leap == -LOC_SYMBOL && NON_LOCAL (p) != NO_TABLE) { ADDR_T lev; name = heap_generator (p, mode, SIZE (mode)); FOLLOW_SL (lev, LEVEL (NON_LOCAL (p))); REF_SCOPE (&name) = lev; } else if (leap == -LOC_SYMBOL) { name = heap_generator (p, mode, SIZE (mode)); REF_SCOPE (&name) = frame_pointer; } else if (leap == HEAP_SYMBOL || leap == -HEAP_SYMBOL) { name = heap_generator (p, mode, SIZE (mode)); REF_SCOPE (&name) = PRIMAL_SCOPE; } else if (leap == NEW_SYMBOL || leap == -NEW_SYMBOL) { name = heap_generator (p, mode, SIZE (mode)); REF_SCOPE (&name) = PRIMAL_SCOPE; } else { ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); } if (HAS_ROWS (mode)) { ADDR_T cur_sp = sp; genie_generator_stowed (p, ADDRESS (&name), NO_VAR, &cur_sp); } PUSH_REF (p, name); } /** @brief Push a name refering to allocated space. @param p Node in syntax tree. @return A propagator for this action. **/ static PROP_T genie_generator (NODE_T * p) { PROP_T self; ADDR_T pop_sp = stack_pointer; A68_REF z; if (NEXT_SUB (p) != NO_NODE) { genie_generator_bounds (NEXT_SUB (p)); } genie_generator_internal (NEXT_SUB (p), MOID (p), TAX (p), -ATTRIBUTE (SUB (p)), pop_sp); POP_REF (p, &z); stack_pointer = pop_sp; PUSH_REF (p, z); UNIT (&self) = genie_generator; SOURCE (&self) = p; return (self); } /* This code implements a parallel clause for Algol68G. This parallel clause has been included for educational purposes, and this implementation just emulates a multi-processor machine. It cannot make use of actual multiple processors. POSIX threads are used to have separate registers and stack for each concurrent unit. Algol68G parallel units behave as POSIX threads - they have private stacks. Hence an assignation to an object in another thread, does not change that object in that other thread. Also jumps between threads are forbidden. */ /** @brief Propagator_name. @param p Propagator procedure. @return Function name of "p". **/ char *propagator_name (PROP_PROC * p) { if (p == genie_and_function) { return ("genie_and_function"); } if (p == genie_assertion) { return ("genie_assertion"); } if (p == genie_assignation) { return ("genie_assignation"); } if (p == genie_assignation_constant) { return ("genie_assignation_constant"); } if (p == genie_call) { return ("genie_call"); } if (p == genie_cast) { return ("genie_cast"); } if (p == (PROP_PROC *) genie_closed) { return ("genie_closed"); } if (p == genie_coercion) { return ("genie_coercion"); } if (p == genie_collateral) { return ("genie_collateral"); } if (p == genie_column_function) { return ("genie_column_function"); } if (p == (PROP_PROC *) genie_conditional) { return ("genie_conditional"); } if (p == genie_constant) { return ("genie_constant"); } if (p == genie_denotation) { return ("genie_denotation"); } if (p == genie_deproceduring) { return ("genie_deproceduring"); } if (p == genie_dereference_frame_identifier) { return ("genie_dereference_frame_identifier"); } if (p == genie_dereference_selection_name_quick) { return ("genie_dereference_selection_name_quick"); } if (p == genie_dereference_slice_name_quick) { return ("genie_dereference_slice_name_quick"); } if (p == genie_dereferencing) { return ("genie_dereferencing"); } if (p == genie_dereferencing_quick) { return ("genie_dereferencing_quick"); } if (p == genie_diagonal_function) { return ("genie_diagonal_function"); } if (p == genie_dyadic) { return ("genie_dyadic"); } if (p == genie_dyadic_quick) { return ("genie_dyadic_quick"); } if (p == (PROP_PROC *) genie_enclosed) { return ("genie_enclosed"); } if (p == genie_format_text) { return ("genie_format_text"); } if (p == genie_formula) { return ("genie_formula"); } if (p == genie_generator) { return ("genie_generator"); } if (p == genie_identifier) { return ("genie_identifier"); } if (p == genie_identifier_standenv) { return ("genie_identifier_standenv"); } if (p == genie_identifier_standenv_proc) { return ("genie_identifier_standenv_proc"); } if (p == genie_identity_relation) { return ("genie_identity_relation"); } if (p == (PROP_PROC *) genie_int_case) { return ("genie_int_case"); } if (p == genie_field_selection) { return ("genie_field_selection"); } if (p == genie_frame_identifier) { return ("genie_frame_identifier"); } if (p == (PROP_PROC *) genie_loop) { return ("genie_loop"); } if (p == genie_monadic) { return ("genie_monadic"); } if (p == genie_nihil) { return ("genie_nihil"); } if (p == genie_or_function) { return ("genie_or_function"); } #if defined HAVE_PARALLEL_CLAUSE if (p == genie_parallel) { return ("genie_parallel"); } #endif if (p == genie_routine_text) { return ("genie_routine_text"); } if (p == genie_row_function) { return ("genie_row_function"); } if (p == genie_rowing) { return ("genie_rowing"); } if (p == genie_rowing_ref_row_of_row) { return ("genie_rowing_ref_row_of_row"); } if (p == genie_rowing_ref_row_row) { return ("genie_rowing_ref_row_row"); } if (p == genie_rowing_row_of_row) { return ("genie_rowing_row_of_row"); } if (p == genie_rowing_row_row) { return ("genie_rowing_row_row"); } if (p == genie_selection) { return ("genie_selection"); } if (p == genie_selection_name_quick) { return ("genie_selection_name_quick"); } if (p == genie_selection_value_quick) { return ("genie_selection_value_quick"); } if (p == genie_skip) { return ("genie_skip"); } if (p == genie_slice) { return ("genie_slice"); } if (p == genie_slice_name_quick) { return ("genie_slice_name_quick"); } if (p == genie_transpose_function) { return ("genie_transpose_function"); } if (p == genie_unit) { return ("genie_unit"); } if (p == (PROP_PROC *) genie_united_case) { return ("genie_united_case"); } if (p == genie_uniting) { return ("genie_uniting"); } if (p == genie_voiding) { return ("genie_voiding"); } if (p == genie_voiding_assignation) { return ("genie_voiding_assignation"); } if (p == genie_voiding_assignation_constant) { return ("genie_voiding_assignation_constant"); } if (p == genie_widening) { return ("genie_widening"); } if (p == genie_widening_int_to_real) { return ("genie_widening_int_to_real"); } return (NO_TEXT); } #if defined HAVE_PARALLEL_CLAUSE typedef struct A68_STACK_DESCRIPTOR A68_STACK_DESCRIPTOR; typedef struct A68_THREAD_CONTEXT A68_THREAD_CONTEXT; struct A68_STACK_DESCRIPTOR { ADDR_T cur_ptr, ini_ptr; BYTE_T *swap, *start; int bytes; }; struct A68_THREAD_CONTEXT { pthread_t parent, id; A68_STACK_DESCRIPTOR stack, frame; NODE_T *unit; int stack_used; BYTE_T *thread_stack_offset; BOOL_T active; }; /* Set an upper limit for number of threads. Don't copy POSIX_THREAD_THREADS_MAX since it may be ULONG_MAX. */ #define THREAD_LIMIT 256 #if ! defined _POSIX_THREAD_THREADS_MAX #define _POSIX_THREAD_THREADS_MAX (THREAD_LIMIT) #endif #if (_POSIX_THREAD_THREADS_MAX < THREAD_LIMIT) #define THREAD_MAX (_POSIX_THREAD_THREADS_MAX) #else #define THREAD_MAX (THREAD_LIMIT) #endif pthread_t main_thread_id = 0; int running_par_level = 0; static A68_THREAD_CONTEXT context[THREAD_MAX]; static ADDR_T fp0, sp0; static BOOL_T abend_all_threads = A68_FALSE, exit_from_threads = A68_FALSE; static int context_index = 0; static int par_return_code = 0; static jmp_buf *jump_buffer; static NODE_T *jump_label; static pthread_mutex_t unit_sema = PTHREAD_MUTEX_INITIALIZER; static pthread_t parent_thread_id = 0; static void save_stacks (pthread_t); static void restore_stacks (pthread_t); #define SAVE_STACK(stk, st, si) {\ A68_STACK_DESCRIPTOR *s = (stk);\ BYTE_T *start = (st);\ int size = (si);\ if (size > 0) {\ if (!((s != NULL) && (BYTES (s) > 0) && (size <= BYTES (s)))) {\ if (SWAP (s) != NO_BYTE) {\ free (SWAP (s));\ }\ SWAP (s) = (BYTE_T *) malloc ((size_t) size);\ ABEND (SWAP (s) == NULL, ERROR_OUT_OF_CORE, NO_TEXT);\ }\ START (s) = start;\ BYTES (s) = size;\ COPY (SWAP (s), start, size);\ } else {\ START (s) = start;\ BYTES (s) = 0;\ if (SWAP (s) != NO_BYTE) {\ free (SWAP (s));\ }\ SWAP (s) = NO_BYTE;\ }} #define RESTORE_STACK(stk) {\ A68_STACK_DESCRIPTOR *s = (stk);\ if (s != NULL && BYTES (s) > 0) {\ COPY (START (s), SWAP (s), BYTES (s));\ }} #define GET_THREAD_INDEX(z, ptid) {\ int _k_;\ pthread_t _tid_ = (ptid);\ (z) = -1;\ for (_k_ = 0; _k_ < context_index && (z) == -1; _k_++) {\ if (pthread_equal (_tid_, ID (&context[_k_]))) {\ (z) = _k_;\ }\ }\ ABEND ((z) == -1, "thread id not registered", NO_TEXT);\ } #define ERROR_THREAD_FAULT "thread fault" #define LOCK_THREAD {\ ABEND (pthread_mutex_lock (&unit_sema) != 0, ERROR_THREAD_FAULT, NO_TEXT);\ } #define UNLOCK_THREAD {\ ABEND (pthread_mutex_unlock (&unit_sema) != 0, ERROR_THREAD_FAULT, NO_TEXT);\ } /** @brief Does system stack grow up or down?. @param lwb BYTE in the stack to calibrate direction @return 1 if stackpointer increases, -1 if stackpointer decreases, 0 in case of error **/ static int stack_direction (BYTE_T * lwb) { BYTE_T upb; if ((int) (&upb - lwb) > 0) { return (1); } else if ((int) (&upb - lwb) < 0) { return (-1); } else { return (0); } } /** @brief Fill in tree what level of parallel clause we are in. @param p Node in syntax tree. @param n Level counter. **/ void set_par_level (NODE_T * p, int n) { for (; p != NO_NODE; p = NEXT (p)) { if (IS (p, PARALLEL_CLAUSE)) { PAR_LEVEL (p) = n + 1; } else { PAR_LEVEL (p) = n; } set_par_level (SUB (p), PAR_LEVEL (p)); } } /** @brief Whether we are in the main thread. @return See brief description. **/ BOOL_T is_main_thread (void) { return ((BOOL_T) (main_thread_id == pthread_self ())); } /** @brief End a thread, beit normally or not. **/ void genie_abend_thread (void) { int k; GET_THREAD_INDEX (k, pthread_self ()); ACTIVE (&context[k]) = A68_FALSE; UNLOCK_THREAD; pthread_exit (NULL); } /** @brief When we end execution in a parallel clause we zap all threads. **/ void genie_set_exit_from_threads (int ret) { abend_all_threads = A68_TRUE; exit_from_threads = A68_TRUE; par_return_code = ret; genie_abend_thread (); } /** @brief When we jump out of a parallel clause we zap all threads. @param p Node in syntax tree. @param jump_stat Jump buffer. @param label Node where label is at. **/ void genie_abend_all_threads (NODE_T * p, jmp_buf * jump_stat, NODE_T * label) { (void) p; abend_all_threads = A68_TRUE; exit_from_threads = A68_FALSE; jump_buffer = jump_stat; jump_label = label; if (!is_main_thread ()) { genie_abend_thread (); } } /** @brief Save this thread and try to start another. @param p Node in syntax tree. **/ static void try_change_thread (NODE_T * p) { if (is_main_thread ()) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OUTSIDE); exit_genie (p, A68_RUNTIME_ERROR); } else { /* Release the unit_sema so another thread can take it up .. */ save_stacks (pthread_self ()); UNLOCK_THREAD; /* ... and take it up again! */ LOCK_THREAD; restore_stacks (pthread_self ()); } } /** @brief Store the stacks of threads. @param t Thread number. **/ static void save_stacks (pthread_t t) { ADDR_T p, q, u, v; int k; GET_THREAD_INDEX (k, t); /* Store stack pointers */ CUR_PTR (&FRAME (&context[k])) = frame_pointer; CUR_PTR (&STACK (&context[k])) = stack_pointer; /* Swap out evaluation stack */ p = stack_pointer; q = INI_PTR (&STACK (&context[k])); SAVE_STACK (&(STACK (&context[k])), STACK_ADDRESS (q), p - q); /* Swap out frame stack */ p = frame_pointer; q = INI_PTR (&FRAME (&context[k])); u = p + FRAME_SIZE (p); v = q + FRAME_SIZE (q); /* Consider the embedding thread */ SAVE_STACK (&(FRAME (&context[k])), FRAME_ADDRESS (v), u - v); } /** @brief Restore stacks of thread. @param t Thread number. **/ static void restore_stacks (pthread_t t) { if (ERROR_COUNT (&program) > 0 || abend_all_threads) { genie_abend_thread (); } else { int k; GET_THREAD_INDEX (k, t); /* Restore stack pointers */ get_stack_size (); system_stack_offset = THREAD_STACK_OFFSET (&context[k]); frame_pointer = CUR_PTR (&FRAME (&context[k])); stack_pointer = CUR_PTR (&STACK (&context[k])); /* Restore stacks */ RESTORE_STACK (&(STACK (&context[k]))); RESTORE_STACK (&(FRAME (&context[k]))); } } /** @brief Check whether parallel units have terminated. @param active Checks whether there are still active threads. @param parent Parent thread number. **/ static void check_parallel_units (BOOL_T * active, pthread_t parent) { int k; for (k = 0; k < context_index; k++) { if (parent == PARENT (&context[k])) { (*active) |= ACTIVE (&context[k]); } } } /** @brief Execute one unit from a PAR clause. @param arg Dummy argument. **/ static void *start_unit (void *arg) { pthread_t t; int k; BYTE_T stack_offset; NODE_T *p; (void) arg; LOCK_THREAD; t = pthread_self (); GET_THREAD_INDEX (k, t); THREAD_STACK_OFFSET (&context[k]) = (BYTE_T *) (&stack_offset - stack_direction (&stack_offset) * STACK_USED (&context[k])); restore_stacks (t); p = (NODE_T *) (UNIT (&context[k])); EXECUTE_UNIT_TRACE (p); genie_abend_thread (); return ((void *) NULL); } /** @brief Execute parallel units. @param p Node in syntax tree. @param parent Parent thread number. **/ static void start_parallel_units (NODE_T * p, pthread_t parent) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { pthread_t new_id; pthread_attr_t new_at; size_t ss; BYTE_T stack_offset; A68_THREAD_CONTEXT *u; /* Set up a thread for this unit */ if (context_index >= THREAD_MAX) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OVERFLOW); exit_genie (p, A68_RUNTIME_ERROR); } /* Fill out a context for this thread */ u = &(context[context_index]); UNIT (u) = p; STACK_USED (u) = SYSTEM_STACK_USED; THREAD_STACK_OFFSET (u) = NO_BYTE; CUR_PTR (&STACK (u)) = stack_pointer; CUR_PTR (&FRAME (u)) = frame_pointer; INI_PTR (&STACK (u)) = sp0; INI_PTR (&FRAME (u)) = fp0; SWAP (&STACK (u)) = NO_BYTE; SWAP (&FRAME (u)) = NO_BYTE; START (&STACK (u)) = NO_BYTE; START (&FRAME (u)) = NO_BYTE; BYTES (&STACK (u)) = 0; BYTES (&FRAME (u)) = 0; ACTIVE (u) = A68_TRUE; /* Create the thread */ RESET_ERRNO; if (pthread_attr_init (&new_at) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_setstacksize (&new_at, (size_t) stack_size) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_getstacksize (&new_at, &ss) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); exit_genie (p, A68_RUNTIME_ERROR); } ABEND ((size_t) ss != (size_t) stack_size, "cannot set thread stack size", NO_TEXT); if (pthread_create (&new_id, &new_at, start_unit, NULL) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_CANNOT_CREATE); exit_genie (p, A68_RUNTIME_ERROR); } PARENT (u) = parent; ID (u) = new_id; context_index++; save_stacks (new_id); } else { start_parallel_units (SUB (p), parent); } } } /** @brief Execute one unit from a PAR clause. @param arg Dummy argument. **/ static void *start_genie_parallel (void *arg) { pthread_t t; int k; BYTE_T stack_offset; NODE_T *p; BOOL_T units_active; (void) arg; LOCK_THREAD; t = pthread_self (); GET_THREAD_INDEX (k, t); THREAD_STACK_OFFSET (&context[k]) = (BYTE_T *) (&stack_offset - stack_direction (&stack_offset) * STACK_USED (&context[k])); restore_stacks (t); p = (NODE_T *) (UNIT (&context[k])); /* This is the thread spawned by the main thread, we spawn parallel units and await their completion */ start_parallel_units (SUB (p), t); do { units_active = A68_FALSE; check_parallel_units (&units_active, pthread_self ()); if (units_active) { try_change_thread (p); } } while (units_active); genie_abend_thread (); return ((void *) NULL); } /** @brief Execute parallel clause. @param p Node in syntax tree. @return Propagator for this routine. **/ static PROP_T genie_parallel (NODE_T * p) { int j; ADDR_T stack_s = 0, frame_s = 0; BYTE_T *system_stack_offset_s = NO_BYTE; int save_par_level = running_par_level; running_par_level = PAR_LEVEL (p); if (is_main_thread ()) { /* Spawn first thread and await its completion */ pthread_attr_t new_at; size_t ss; BYTE_T stack_offset; A68_THREAD_CONTEXT *u; LOCK_THREAD; abend_all_threads = A68_FALSE; exit_from_threads = A68_FALSE; par_return_code = 0; sp0 = stack_s = stack_pointer; fp0 = frame_s = frame_pointer; system_stack_offset_s = system_stack_offset; context_index = 0; /* Set up a thread for this unit */ u = &(context[context_index]); UNIT (u) = p; STACK_USED (u) = SYSTEM_STACK_USED; THREAD_STACK_OFFSET (u) = NO_BYTE; CUR_PTR (&STACK (u)) = stack_pointer; CUR_PTR (&FRAME (u)) = frame_pointer; INI_PTR (&STACK (u)) = sp0; INI_PTR (&FRAME (u)) = fp0; SWAP (&STACK (u)) = NO_BYTE; SWAP (&FRAME (u)) = NO_BYTE; START (&STACK (u)) = NO_BYTE; START (&FRAME (u)) = NO_BYTE; BYTES (&STACK (u)) = 0; BYTES (&FRAME (u)) = 0; ACTIVE (u) = A68_TRUE; /* Spawn the first thread and join it to await its completion */ RESET_ERRNO; if (pthread_attr_init (&new_at) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_setstacksize (&new_at, (size_t) stack_size) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } if (pthread_attr_getstacksize (&new_at, &ss) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } ABEND ((size_t) ss != (size_t) stack_size, "cannot set thread stack size", NO_TEXT); if (pthread_create (&parent_thread_id, &new_at, start_genie_parallel, NULL) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_CANNOT_CREATE); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } if (errno != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } PARENT (u) = main_thread_id; ID (u) = parent_thread_id; context_index++; save_stacks (parent_thread_id); UNLOCK_THREAD; if (pthread_join (parent_thread_id, NULL) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } /* The first spawned thread has completed, now clean up */ for (j = 0; j < context_index; j++) { if (ACTIVE (&context[j]) && ID (&context[j]) != main_thread_id && ID (&context[j]) != parent_thread_id) { /* If threads are zapped it is possible that some are active at this point! */ if (pthread_join (ID (&context[j]), NULL) != 0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_THREAD_FAULT); running_par_level = save_par_level; exit_genie (p, A68_RUNTIME_ERROR); } } if (SWAP (&STACK (&context[j])) != NO_BYTE) { free (SWAP (&STACK (&context[j]))); SWAP (&STACK (&context[j])) = NO_BYTE; } if (SWAP (&STACK (&context[j])) != NO_BYTE) { free (SWAP (&STACK (&context[j]))); SWAP (&STACK (&context[j])) = NO_BYTE; } } /* Now every thread should have ended */ running_par_level = save_par_level; context_index = 0; stack_pointer = stack_s; frame_pointer = frame_s; get_stack_size (); system_stack_offset = system_stack_offset_s; /* See if we ended execution in parallel clause */ if (is_main_thread () && exit_from_threads) { exit_genie (p, par_return_code); } if (is_main_thread () && ERROR_COUNT (&program) > 0) { exit_genie (p, A68_RUNTIME_ERROR); } /* See if we jumped out of the parallel clause(s) */ if (is_main_thread () && abend_all_threads) { JUMP_TO (TABLE (TAX (jump_label))) = UNIT (TAX (jump_label)); longjmp (*(jump_buffer), 1); } } else { /* Not in the main thread, spawn parallel units and await completion */ BOOL_T units_active; pthread_t t = pthread_self (); /* Spawn parallel units */ start_parallel_units (SUB (p), t); do { units_active = A68_FALSE; check_parallel_units (&units_active, t); if (units_active) { try_change_thread (p); } } while (units_active); running_par_level = save_par_level; } return (GPROP (p)); } /** @brief OP LEVEL = (INT) SEMA @param p Node in syntax tree. **/ void genie_level_sema_int (NODE_T * p) { A68_INT k; A68_REF s; POP_OBJECT (p, &k, A68_INT); s = heap_generator (p, MODE (INT), SIZE (MODE (INT))); * DEREF (A68_INT, &s) = k; PUSH_REF (p, s); } /** @brief OP LEVEL = (SEMA) INT @param p Node in syntax tree. **/ void genie_level_int_sema (NODE_T * p) { A68_REF s; POP_REF (p, &s); CHECK_INIT (p, INITIALISED (&s), MODE (SEMA)); PUSH_PRIMITIVE (p, VALUE (DEREF (A68_INT, &s)), A68_INT); } /** @brief OP UP = (SEMA) VOID @param p Node in syntax tree. **/ void genie_up_sema (NODE_T * p) { A68_REF s; if (is_main_thread ()) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OUTSIDE); exit_genie (p, A68_RUNTIME_ERROR); } POP_REF (p, &s); CHECK_INIT (p, INITIALISED (&s), MODE (SEMA)); VALUE (DEREF (A68_INT, &s))++; } /** @brief OP DOWN = (SEMA) VOID @param p Node in syntax tree. **/ void genie_down_sema (NODE_T * p) { A68_REF s; A68_INT *k; BOOL_T cont = A68_TRUE; if (is_main_thread ()) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_PARALLEL_OUTSIDE); exit_genie (p, A68_RUNTIME_ERROR); } POP_REF (p, &s); CHECK_INIT (p, INITIALISED (&s), MODE (SEMA)); while (cont) { k = DEREF (A68_INT, &s); if (VALUE (k) <= 0) { save_stacks (pthread_self ()); while (VALUE (k) <= 0) { if (ERROR_COUNT (&program) > 0 || abend_all_threads) { genie_abend_thread (); } UNLOCK_THREAD; /* Waiting a bit relaxes overhead */ ASSERT (usleep (10) == 0); LOCK_THREAD; /* Garbage may be collected, so recalculate 'k' */ k = DEREF (A68_INT, &s); } restore_stacks (pthread_self ()); cont = A68_TRUE; } else { VALUE (k)--; cont = A68_FALSE; } } } #endif algol68g-2.8/source/syntax.c0000644000175000001440000157442412223637127012743 00000000000000/** @file syntax.c @author J. Marcel van der Veer @brief Hand-coded Algol 68 scanner and parser. @section Copyright This file is part of Algol 68 Genie - an Algol 68 compiler-interpreter. Copyright 2001-2013 J. Marcel van der Veer . @section License 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 . @section Description Algol 68 grammar is defined as a two level (Van Wijngaarden) grammar that incorporates, as syntactical rules, the "semantical" rules in other languages. Examples are correct use of symbols, modes and scope. That is why so much functionality is in the "syntax.c" file. In fact, all this material constitutes an effective "Algol 68 VW parser". This pragmatic approach was chosen since in the early days of Algol 68, many "ab initio" implementations failed. This is a Mailloux-type parser, in the sense that it scans a "phrase" for definitions before it starts parsing, and therefore allows for tags to be used before they are defined, which gives some freedom in top-down programming. In 2011, FLACC documentation became available again. This documentation suggests that the set-up of this parser resembles that of FLACC, which supports the view that this is a Mailloux-type parser. First part in this file is the scanner. The source file is read, is tokenised, and if needed a refinement preprocessor elaborates a stepwise refined program. The result is a linear list of tokens that is input for the parser, that will transform the linear list into a syntax tree. Algol68G 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 do some rudimentary parsing. Format texts can have enclosed clauses in them, so we record information in a stack as to know what is being scanned. Also, the refinement preprocessor implements a (trivial) grammar. The scanner supports two stropping regimes: bold 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 about 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. So those 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. Also structure of format texts is checked 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. With respect to the mode checker: 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. Finally, a static scope checker inspects the source. Note that Algol 68 also needs dynamic scope checking. This phase concludes the parser. **/ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" static MOID_T *get_mode_from_declarer (NODE_T *); typedef struct TUPLE_T TUPLE_T; typedef struct SCOPE_T SCOPE_T; struct TUPLE_T { int level; BOOL_T 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 **); TAG_T *error_tag; static SOID_T *top_soid_list = NO_SOID; static BOOL_T basic_coercions (MOID_T *, MOID_T *, int, int); static BOOL_T is_coercible (MOID_T *, MOID_T *, int, int); static BOOL_T is_nonproc (MOID_T *); static void mode_check_enclosed (NODE_T *, SOID_T *, SOID_T *); static void mode_check_unit (NODE_T *, SOID_T *, SOID_T *); static void mode_check_formula (NODE_T *, SOID_T *, SOID_T *); static void coerce_enclosed (NODE_T *, SOID_T *); static void coerce_operand (NODE_T *, SOID_T *); static void coerce_formula (NODE_T *, SOID_T *); static void coerce_unit (NODE_T *, SOID_T *); #define DEPREF A68_TRUE #define NO_DEPREF A68_FALSE #define IF_MODE_IS_WELL(n) (! ((n) == MODE (ERROR) || (n) == MODE (UNDEFINED))) #define INSERT_COERCIONS(n, p, q) make_strong ((n), (p), MOID (q)) #define STOP_CHAR 127 #define IN_PRELUDE(p) (LINE_NUMBER (p) <= 0) #define EOL(c) ((c) == NEWLINE_CHAR || (c) == NULL_CHAR) static BOOL_T stop_scanner = A68_FALSE, read_error = A68_FALSE, no_preprocessing = A68_FALSE; static char *scan_buf; static int max_scan_buf_length, source_file_size; static int reductions = 0; static jmp_buf bottom_up_crash_exit, top_down_crash_exit; static BOOL_T victal_check_declarer (NODE_T *, int); static NODE_T *reduce_dyadic (NODE_T *, int u); static NODE_T *top_down_loop (NODE_T *); static NODE_T *top_down_skip_unit (NODE_T *); static void append_source_line (char *, LINE_T **, int *, char *); static void elaborate_bold_tags (NODE_T *); static void extract_declarations (NODE_T *); static void extract_identities (NODE_T *); static void extract_indicants (NODE_T *); static void extract_labels (NODE_T *, int); static void extract_operators (NODE_T *); static void extract_priorities (NODE_T *); static void extract_proc_identities (NODE_T *); static void extract_proc_variables (NODE_T *); static void extract_variables (NODE_T *); static void ignore_superfluous_semicolons (NODE_T *); static void recover_from_error (NODE_T *, int, BOOL_T); static void reduce_arguments (NODE_T *); static void reduce_basic_declarations (NODE_T *); static void reduce_bounds (NODE_T *); static void reduce_collateral_clauses (NODE_T *); static void reduce_declaration_lists (NODE_T *); static void reduce_declarers (NODE_T *, int); static void reduce_enclosed_clauses (NODE_T *, int); static void reduce_enquiry_clauses (NODE_T *); static void reduce_erroneous_units (NODE_T *); static void reduce_format_texts (NODE_T *); static void reduce_formulae (NODE_T *); static void reduce_generic_arguments (NODE_T *); static void reduce_primaries (NODE_T *, int); static void reduce_primary_parts (NODE_T *, int); static void reduce_right_to_left_constructs (NODE_T * q); static void reduce_secondaries (NODE_T *); static void reduce_serial_clauses (NODE_T *); static void reduce_branch (NODE_T *, int); static void reduce_tertiaries (NODE_T *); static void reduce_units (NODE_T *); static void reduce (NODE_T *, void (*)(NODE_T *), BOOL_T *, ...); /* Standard environ */ static char *bold_prelude_start[] = { "BEGIN MODE DOUBLE = LONG REAL, QUAD = LONG LONG REAL;", " start: commence:", " BEGIN", NO_TEXT }; static char *bold_postlude[] = { " END;", " stop: abort: halt: SKIP", "END", NO_TEXT }; static char *quote_prelude_start[] = { "'BEGIN' 'MODE' 'DOUBLE' = 'LONG' 'REAL'," " 'QUAD' = 'LONG' 'LONG' 'REAL'," " 'DEVICE' = 'FILE'," " 'TEXT' = 'STRING';" " START: COMMENCE:" " 'BEGIN'", NO_TEXT }; static char *quote_postlude[] = { " 'END';", " STOP: ABORT: HALT: 'SKIP'", "'END'", NO_TEXT }; /** @brief Is_ref_refety_flex. @param m Mode under test. @return See brief description. **/ static BOOL_T is_ref_refety_flex (MOID_T * m) { if (IS_REF_FLEX (m)) { return (A68_TRUE); } else if (IS (m, REF_SYMBOL)) { return (is_ref_refety_flex (SUB (m))); } else { return (A68_FALSE); } } /** @brief Count pictures. @param p Node in syntax tree. @param k Counter. **/ static void count_pictures (NODE_T * p, int *k) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, PICTURE)) { (*k)++; } count_pictures (SUB (p), k); } } /** @brief Count number of operands in operator parameter list. @param p Node in syntax tree. @return See brief description. **/ static int count_operands (NODE_T * p) { if (p != NO_NODE) { if (IS (p, DECLARER)) { return (count_operands (NEXT (p))); } else if (IS (p, COMMA_SYMBOL)) { return (1 + count_operands (NEXT (p))); } else { return (count_operands (NEXT (p)) + count_operands (SUB (p))); } } else { return (0); } } /** @brief Count formal bounds in declarer in tree. @param p Node in syntax tree. @return See brief description. **/ static int count_formal_bounds (NODE_T * p) { if (p == NO_NODE) { return (0); } else { if (IS (p, COMMA_SYMBOL)) { return (1); } else { return (count_formal_bounds (NEXT (p)) + count_formal_bounds (SUB (p))); } } } /** @brief Count bounds in declarer in tree. @param p Node in syntax tree. @return See brief description. **/ 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))); } } } /** @brief Count number of SHORTs or LONGs. @param p Node in syntax tree. @return See brief description. **/ 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); } } /** @brief Count moids in a pack. @param u Pack. @return See brief description. **/ int count_pack_members (PACK_T * u) { int k = 0; for (; u != NO_PACK; FORWARD (u)) { k++; } return (k); } /** @brief Replace a mode by its equivalent mode. @param m Mode to replace. **/ static void resolve_equivalent (MOID_T ** m) { while ((*m) != NO_MOID && EQUIVALENT ((*m)) != NO_MOID && (*m) != EQUIVALENT (*m)) { (*m) = EQUIVALENT (*m); } } /** @brief Save scanner state, for character look-ahead. @param ref_l Source line. @param ref_s Position in source line text. @param ch Last scanned character. **/ static void save_state (LINE_T * ref_l, char *ref_s, char ch) { SCAN_STATE_L (&program) = ref_l; SCAN_STATE_S (&program) = ref_s; SCAN_STATE_C (&program) = ch; } /** @brief Restore scanner state, for character look-ahead. @param ref_l Source line. @param ref_s Position in source line text. @param ch Last scanned character. **/ static void restore_state (LINE_T ** ref_l, char **ref_s, char *ch) { *ref_l = SCAN_STATE_L (&program); *ref_s = SCAN_STATE_S (&program); *ch = SCAN_STATE_C (&program); } /**************************************/ /* Scanner, tokenises the source code */ /**************************************/ /** @brief Whether ch is unworthy. @param u Source line with error. @param v Character in line. @param ch **/ static void unworthy (LINE_T * u, char *v, char ch) { if (IS_PRINT (ch)) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "*%s", ERROR_UNWORTHY_CHARACTER) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "*%s %s", ERROR_UNWORTHY_CHARACTER, ctrl_char (ch)) >= 0); } scan_error (u, v, edit_line); } /** @brief Concatenate lines that terminate in '\' with next line. @param top Top source 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; q = NEXT (q)) { ; } for (; q != NO_LINE; BACKWARD (q)) { char *z = STRING (q); int len = (int) 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] = NULL_CHAR; len += (int) strlen (STRING (NEXT (q))); z = (char *) get_fixed_heap_space ((size_t) (len + 1)); bufcpy (z, STRING (q), len + 1); bufcat (z, STRING (NEXT (q)), len + 1); STRING (NEXT (q))[0] = NULL_CHAR; STRING (q) = z; } } } /** @brief Whether u is bold tag v, independent of stropping regime. @param u Symbol under test. @param v Bold symbol . @return Whether u is v. **/ static BOOL_T is_bold (char *u, char *v) { unsigned len = (unsigned) strlen (v); if (OPTION_STROPPING (&program) == QUOTE_STROPPING) { if (u[0] == '\'') { return ((BOOL_T) (strncmp (++u, v, len) == 0 && u[len] == '\'')); } else { return (A68_FALSE); } } else { return ((BOOL_T) (strncmp (u, v, len) == 0 && !IS_UPPER (u[len]))); } } /** @brief Skip string. @param top Current source line. @param ch Current character in source line. @return Whether string is properly terminated. **/ static BOOL_T 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 (A68_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 (A68_FALSE); } /** @brief Skip comment. @param top Current source line. @param ch Current character in source line. @param delim Expected terminating delimiter. @return Whether comment is properly terminated. **/ static BOOL_T skip_comment (LINE_T ** top, char **ch, int delim) { LINE_T *u = *top; char *v = *ch; v++; while (u != NO_LINE) { while (v[0] != NULL_CHAR) { if (is_bold (v, "COMMENT") && delim == BOLD_COMMENT_SYMBOL) { *top = u; *ch = &v[1]; return (A68_TRUE); } else if (is_bold (v, "CO") && delim == STYLE_I_COMMENT_SYMBOL) { *top = u; *ch = &v[1]; return (A68_TRUE); } else if (v[0] == '#' && delim == STYLE_II_COMMENT_SYMBOL) { *top = u; *ch = &v[1]; return (A68_TRUE); } else { v++; } } FORWARD (u); if (u != NO_LINE) { v = &(STRING (u)[0]); } else { v = NO_TEXT; } } return (A68_FALSE); } /** @brief Skip rest of pragmat. @param top Current source line. @param ch Current character in source line. @param delim Expected terminating delimiter. @param whitespace Whether other pragmat items are allowed. @return Whether pragmat is properly terminated. **/ static BOOL_T skip_pragmat (LINE_T ** top, char **ch, int delim, BOOL_T 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 (A68_TRUE); } else if (is_bold (v, "PR") && delim == STYLE_I_PRAGMAT_SYMBOL) { *top = u; *ch = &v[1]; return (A68_TRUE); } else { if (whitespace && !IS_SPACE (v[0]) && v[0] != NEWLINE_CHAR) { scan_error (u, v, ERROR_PRAGMENT); } else if (IS_UPPER (v[0])) { /* Skip a bold word as you may trigger on REPR, for instance .. */ while (IS_UPPER (v[0])) { v++; } } else { v++; } } } FORWARD (u); if (u != NO_LINE) { v = &(STRING (u)[0]); } else { v = NO_TEXT; } } return (A68_FALSE); } /** @brief Return pointer to next token within pragmat. @param top Current source line. @param ch Current character in source line. @return Pointer to next item, NO_TEXT if none remains. **/ 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 (!IS_SPACE (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); } /** @brief Case insensitive strncmp for at most the number of chars in 'v'. @param u String 1, must not be NO_TEXT. @param v String 2, must not be NO_TEXT. @return Alphabetic difference between 1 and 2. **/ static int streq (char *u, char *v) { int diff; for (diff = 0; diff == 0 && u[0] != NULL_CHAR && v[0] != NULL_CHAR; u++, v++) { diff = ((int) TO_LOWER (u[0])) - ((int) TO_LOWER (v[0])); } return (diff); } /** @brief Scan for next pragmat and yield first pragmat item. @param top Current source line. @param ch Current character in source line. @param delim Expected terminating delimiter. @return Pointer to next item or NO_TEXT if none remain. **/ 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; /* STRINGs must be skipped */ if (v[0] == QUOTE_CHAR) { SCAN_ERROR (!skip_string (&u, &v), start_l, start_c, ERROR_UNTERMINATED_STRING); } /* COMMENTS must be skipped */ else if (is_bold (v, "COMMENT")) { SCAN_ERROR (!skip_comment (&u, &v, BOLD_COMMENT_SYMBOL), start_l, start_c, ERROR_UNTERMINATED_COMMENT); } else if (is_bold (v, "CO")) { SCAN_ERROR (!skip_comment (&u, &v, STYLE_I_COMMENT_SYMBOL), start_l, start_c, ERROR_UNTERMINATED_COMMENT); } else if (v[0] == '#') { SCAN_ERROR (!skip_comment (&u, &v, STYLE_II_COMMENT_SYMBOL), start_l, start_c, ERROR_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, ERROR_UNTERMINATED_PRAGMAT); /* Item "preprocessor" restarts preprocessing if it is off */ if (no_preprocessing && streq (item, "PREPROCESSOR") == 0) { no_preprocessing = A68_FALSE; SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_TRUE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); } /* If preprocessing is switched off, we idle to closing bracket */ else if (no_preprocessing) { SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_FALSE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); } /* Item "nopreprocessor" stops preprocessing if it is on */ if (streq (item, "NOPREPROCESSOR") == 0) { no_preprocessing = A68_TRUE; SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_TRUE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); } /* Item "INCLUDE" includes a file */ else if (streq (item, "INCLUDE") == 0) { *top = u; *ch = v; return (item); } /* Item "READ" includes a file */ else if (streq (item, "READ") == 0) { *top = u; *ch = v; return (item); } /* Unrecognised item - probably options handled later by the tokeniser */ else { SCAN_ERROR (!skip_pragmat (&u, &v, *delim, A68_FALSE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); } } else if (IS_UPPER (v[0])) { /* Skip a bold word as you may trigger on REPR, for instance .. */ while (IS_UPPER (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); } /** @brief Include files. @param top Top source line. **/ static void include_files (LINE_T * top) { /* include_files syntax: PR read "filename" PR 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. */ BOOL_T make_pass = A68_TRUE; while (make_pass) { LINE_T *s, *t, *u = top; char *v = &(STRING (u)[0]); make_pass = A68_FALSE; RESET_ERRNO; 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 || streq (item, "READ") == 0)) { FILE_T fd; int n, linum, fsize, k, bytes_read, fnwid; char *fbuf, delim; char fnb[BUFFER_SIZE], *fn; /* Skip to filename */ if (streq (item, "INCLUDE") == 0) { v = &v[strlen ("INCLUDE")]; } else { v = &v[strlen ("READ")]; } while (IS_SPACE (v[0])) { v++; } /* Scan quoted filename */ SCAN_ERROR ((v[0] != QUOTE_CHAR && v[0] != '\''), start_l, start_c, ERROR_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, ERROR_INCORRECT_FILENAME); SCAN_ERROR (n == BUFFER_SIZE - 1, start_l, start_c, ERROR_INCORRECT_FILENAME); if (v[0] == delim) { while (v[0] == delim && v[1] == delim) { SCAN_ERROR (n == BUFFER_SIZE - 1, start_l, start_c, ERROR_INCORRECT_FILENAME); fnb[n++] = delim; fnb[n] = NULL_CHAR; v += 2; } } else if (IS_PRINT (v[0])) { fnb[n++] = *(v++); fnb[n] = NULL_CHAR; } else { SCAN_ERROR (A68_TRUE, start_l, start_c, ERROR_INCORRECT_FILENAME); } } while (v[0] != delim); /* Insist that the pragmat is closed properly */ v = &v[1]; SCAN_ERROR (!skip_pragmat (&u, &v, pr_lim, A68_TRUE), start_l, start_c, ERROR_UNTERMINATED_PRAGMAT); /* Filename valid? */ SCAN_ERROR (n == 0, start_l, start_c, ERROR_INCORRECT_FILENAME); fnwid = (int) strlen (fnb) + 1; fn = (char *) get_fixed_heap_space ((size_t) fnwid); bufcpy (fn, fnb, fnwid); /* Recursive include? Then *ignore* the file */ for (t = top; t != NO_LINE; t = NEXT (t)) { if (strcmp (FILENAME (t), fn) == 0) { goto search_next_pragmat; /* Eeek! */ } } /* Access the file */ RESET_ERRNO; fd = open (fn, O_RDONLY | O_BINARY); ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "*%s \"%s\"", ERROR_SOURCE_FILE_OPEN, fn) >= 0); SCAN_ERROR (fd == -1, start_l, start_c, edit_line); /* Access the file */ RESET_ERRNO; fsize = (int) lseek (fd, 0, SEEK_END); ASSERT (fsize >= 0); SCAN_ERROR (errno != 0, start_l, start_c, ERROR_FILE_READ); fbuf = (char *) get_temp_heap_space ((unsigned) (8 + fsize)); RESET_ERRNO; ASSERT (lseek (fd, 0, SEEK_SET) >= 0); SCAN_ERROR (errno != 0, start_l, start_c, ERROR_FILE_READ); RESET_ERRNO; bytes_read = (int) io_read (fd, fbuf, (size_t) fsize); SCAN_ERROR (errno != 0 || bytes_read != fsize, start_l, start_c, ERROR_FILE_READ); /* Buffer still usable? */ if (fsize > max_scan_buf_length) { max_scan_buf_length = fsize; scan_buf = (char *) get_temp_heap_space ((unsigned) (8 + 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 */ scan_buf[0] = NEWLINE_CHAR; scan_buf[1] = NULL_CHAR; append_source_line (scan_buf, &t, &linum, fn); } else while (k < fsize) { n = 0; scan_buf[0] = NULL_CHAR; while (k < fsize && fbuf[k] != NEWLINE_CHAR) { SCAN_ERROR ((IS_CNTRL (fbuf[k]) && !IS_SPACE (fbuf[k])) || fbuf[k] == STOP_CHAR, start_l, start_c, ERROR_FILE_INCLUDE_CTRL); scan_buf[n++] = fbuf[k++]; scan_buf[n] = NULL_CHAR; } scan_buf[n++] = NEWLINE_CHAR; scan_buf[n] = NULL_CHAR; if (k < fsize) { k++; } append_source_line (scan_buf, &t, &linum, fn); } /* Conclude and go find another include directive, if any */ NEXT (t) = s; PREVIOUS (s) = t; concatenate_lines (top); ASSERT (close (fd) == 0); make_pass = A68_TRUE; } search_next_pragmat:/* skip */ ; } } } /** @brief Append a source line to the internal source file. @param str Text line to be appended. @param ref_l Previous source line. @param line_num Previous source line number. @param filename Name of file being read. **/ static void append_source_line (char *str, LINE_T ** ref_l, int *line_num, char *filename) { LINE_T *z = new_source_line (); /* Allow shell command in first line, f.i. "#!/usr/share/bin/a68g" */ if (*line_num == 1) { if (strlen (str) >= 2 && strncmp (str, "#!", 2) == 0) { ABEND (strstr (str, "run-script") != NO_TEXT, ERROR_SHELL_SCRIPT, NO_TEXT); (*line_num)++; return; } } /* Link line into the chain */ STRING (z) = new_fixed_string (str); FILENAME (z) = filename; NUMBER (z) = (*line_num)++; PRINT_STATUS (z) = NOT_PRINTED; LIST (z) = A68_TRUE; DIAGNOSTICS (z) = NO_DIAGNOSTIC; NEXT (z) = NO_LINE; PREVIOUS (z) = *ref_l; if (TOP_LINE (&program) == NO_LINE) { TOP_LINE (&program) = z; } if (*ref_l != NO_LINE) { NEXT (*ref_l) = z; } *ref_l = z; } /** @brief Size of source file. @return Size of file. **/ static int get_source_size (void) { FILE_T f = FILE_SOURCE_FD (&program); /* This is why WIN32 must open as "read binary" */ return ((int) lseek (f, 0, SEEK_END)); } /** @brief Append environment source lines. @param str Line to append. @param ref_l Source line after which to append. @param line_num Number of source line 'ref_l'. @param name Either "prelude" or "postlude". **/ static void append_environ (char *str[], LINE_T ** ref_l, int *line_num, char *name) { int k; for (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); } /* char *text = new_string (str, NO_TEXT); while (text != NO_TEXT && text[0] != NULL_CHAR) { char *car = text; char *cdr = a68g_strchr (text, '!'); int zero_line_num = 0; cdr[0] = NULL_CHAR; text = &cdr[1]; (*line_num)++; ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s\n", car) >= 0); append_source_line (edit_line, ref_l, &zero_line_num, name); } */ } /** @brief Read script file and make internal copy. @return Whether reading is satisfactory . **/ static BOOL_T read_script_file (void) { LINE_T * ref_l = NO_LINE; int k, n, num; unsigned len; BOOL_T file_end = A68_FALSE; char filename[BUFFER_SIZE], linenum[BUFFER_SIZE]; char ch, * fn, * line; char * buffer = (char *) get_temp_heap_space ((unsigned) (8 + source_file_size)); FILE_T source = FILE_SOURCE_FD (&program); ABEND (source == -1, "source file not open", NO_TEXT); buffer[0] = NULL_CHAR; n = 0; len = (unsigned) (8 + source_file_size); buffer = (char *) get_temp_heap_space (len); ASSERT (lseek (source, 0, SEEK_SET) >= 0); while (!file_end) { /* Read the original file name */ filename[0] = NULL_CHAR; k = 0; if (io_read (source, &ch, 1) == 0) { file_end = A68_TRUE; continue; } while (ch != NEWLINE_CHAR) { filename[k++] = ch; ASSERT (io_read (source, &ch, 1) == 1); } filename[k] = NULL_CHAR; fn = TEXT (add_token (&top_token, filename)); /* Read the original file number */ linenum[0] = NULL_CHAR; k = 0; ASSERT (io_read (source, &ch, 1) == 1); while (ch != NEWLINE_CHAR) { linenum[k++] = ch; ASSERT (io_read (source, &ch, 1) == 1); } linenum[k] = NULL_CHAR; num = (int) strtol (linenum, NO_VAR, 10); ABEND (errno == ERANGE, "strange line number", NO_TEXT); /* COPY original line into buffer */ ASSERT (io_read (source, &ch, 1) == 1); line = &buffer[n]; while (ch != NEWLINE_CHAR) { buffer[n++] = ch; ASSERT (io_read (source, &ch, 1) == 1); ABEND ((unsigned) n >= len, "buffer overflow", NO_TEXT); } buffer[n++] = NEWLINE_CHAR; buffer[n] = NULL_CHAR; append_source_line (line, &ref_l, &num, fn); } return (A68_TRUE); } /** @brief Read source file and make internal copy. @return Whether reading is satisfactory . **/ static BOOL_T read_source_file (void) { LINE_T *ref_l = NO_LINE; int line_num = 0, k, bytes_read; ssize_t l; FILE_T f = FILE_SOURCE_FD (&program); char **prelude_start, **postlude, *buffer; /* Prelude */ if (OPTION_STROPPING (&program) == UPPER_STROPPING) { prelude_start = bold_prelude_start; postlude = bold_postlude; } else if (OPTION_STROPPING (&program) == QUOTE_STROPPING) { prelude_start = quote_prelude_start; postlude = quote_postlude; } else { prelude_start = postlude = NO_VAR; } append_environ (prelude_start, &ref_l, &line_num, "prelude"); /* Read the file into a single buffer, so we save on system calls */ line_num = 1; buffer = (char *) get_temp_heap_space ((unsigned) (8 + source_file_size)); RESET_ERRNO; ASSERT (lseek (f, 0, SEEK_SET) >= 0); ABEND (errno != 0, "error while reading source file", NO_TEXT); RESET_ERRNO; bytes_read = (int) io_read (f, buffer, (size_t) source_file_size); ABEND (errno != 0 || bytes_read != source_file_size, "error while reading source file", NO_TEXT); /* Link all lines into the list */ k = 0; while (k < source_file_size) { l = 0; scan_buf[0] = NULL_CHAR; 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 { scan_buf[l++] = buffer[k++]; scan_buf[l] = NULL_CHAR; } } scan_buf[l++] = NEWLINE_CHAR; scan_buf[l] = NULL_CHAR; if (k < source_file_size) { k++; } append_source_line (scan_buf, &ref_l, &line_num, FILE_SOURCE_NAME (&program)); SCAN_ERROR (l != (ssize_t) strlen (scan_buf), NO_LINE, NO_TEXT, ERROR_FILE_SOURCE_CTRL); } /* Postlude */ append_environ (postlude, &ref_l, &line_num, "postlude"); /* Concatenate lines */ concatenate_lines (TOP_LINE (&program)); /* Include files */ include_files (TOP_LINE (&program)); return (A68_TRUE); } /** @brief Next_char get next character from internal copy of source file. @param ref_l Source line we're scanning. @param ref_s Character (in source line) we're scanning. @param allow_typo Whether typographical display features are allowed. @return Next char on input. **/ static char next_char (LINE_T ** ref_l, char **ref_s, BOOL_T allow_typo) { char ch; #if defined NO_TYPO allow_typo = A68_FALSE; #endif LOW_STACK_ALERT (NO_NODE); /* Source empty? */ if (*ref_l == NO_LINE) { return (STOP_CHAR); } else { LIST (*ref_l) = (BOOL_T) (OPTION_NODEMASK (&program) & SOURCE_MASK ? A68_TRUE : A68_FALSE); /* Take new line? */ if ((*ref_s)[0] == NEWLINE_CHAR || (*ref_s)[0] == NULL_CHAR) { *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 && (IS_SPACE (ch) || ch == FORMFEED_CHAR)) { ch = next_char (ref_l, ref_s, allow_typo); } return (ch); } } /** @brief Find first character that can start a valid symbol. @param ref_c Pointer to character. @param ref_l Source line we're scanning. @param ref_s Character (in source line) we're scanning. **/ static void get_good_char (char *ref_c, LINE_T ** ref_l, char **ref_s) { while (*ref_c != STOP_CHAR && (IS_SPACE (*ref_c) || (*ref_c == NULL_CHAR))) { if (*ref_l != NO_LINE) { LIST (*ref_l) = (BOOL_T) (OPTION_NODEMASK (&program) & SOURCE_MASK ? A68_TRUE : A68_FALSE); } *ref_c = next_char (ref_l, ref_s, A68_FALSE); } } /** @brief Handle a pragment (pragmat or comment). @param type Type of pragment (#, CO, COMMENT, PR, PRAGMAT). @param ref_l Source line we're scanning. @param ref_c Character (in source line) we're scanning. @return Pragment text as a string for binding in the tree. **/ static char *pragment (int type, LINE_T ** ref_l, char **ref_c) { #define INIT_BUFFER {chars_in_buf = 0; scan_buf[chars_in_buf] = NULL_CHAR;} #define ADD_ONE_CHAR(ch) {scan_buf[chars_in_buf ++] = ch; scan_buf[chars_in_buf] = NULL_CHAR;} char c = **ref_c, *term_s = NO_TEXT, *start_c = *ref_c; char *z; LINE_T *start_l = *ref_l; int term_s_length, chars_in_buf; BOOL_T stop, pragmat = A68_FALSE; /* Set terminator */ if (OPTION_STROPPING (&program) == 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 == STYLE_I_PRAGMAT_SYMBOL) { term_s = "PR"; pragmat = A68_TRUE; } else if (type == BOLD_PRAGMAT_SYMBOL) { term_s = "PRAGMAT"; pragmat = A68_TRUE; } } else if (OPTION_STROPPING (&program) == QUOTE_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 == STYLE_I_PRAGMAT_SYMBOL) { term_s = "'PR'"; pragmat = A68_TRUE; } else if (type == BOLD_PRAGMAT_SYMBOL) { term_s = "'PRAGMAT'"; pragmat = A68_TRUE; } } term_s_length = (int) strlen (term_s); /* Scan for terminator */ INIT_BUFFER; stop = A68_FALSE; while (stop == A68_FALSE) { SCAN_ERROR (c == STOP_CHAR, start_l, start_c, ERROR_UNTERMINATED_PRAGMENT); /* A ".." or '..' delimited string in a PRAGMAT */ if (pragmat && (c == QUOTE_CHAR || (c == '\'' && OPTION_STROPPING (&program) == UPPER_STROPPING))) { char delim = c; BOOL_T eos = A68_FALSE; ADD_ONE_CHAR (c); c = next_char (ref_l, ref_c, A68_FALSE); while (!eos) { SCAN_ERROR (EOL (c), start_l, start_c, ERROR_LONG_STRING); if (c == delim) { ADD_ONE_CHAR (delim); save_state (*ref_l, *ref_c, c); c = next_char (ref_l, ref_c, A68_FALSE); if (c == delim) { c = next_char (ref_l, ref_c, A68_FALSE); } else { restore_state (ref_l, ref_c, &c); eos = A68_TRUE; } } else if (IS_PRINT (c)) { ADD_ONE_CHAR (c); c = next_char (ref_l, ref_c, A68_FALSE); } else { unworthy (start_l, start_c, c); } } } else if (EOL (c)) { ADD_ONE_CHAR (NEWLINE_CHAR); } else if (IS_PRINT (c) || IS_SPACE (c)) { ADD_ONE_CHAR (c); } if (chars_in_buf >= term_s_length) { /* Check whether we encountered the terminator */ stop = (BOOL_T) (strcmp (term_s, &(scan_buf[chars_in_buf - term_s_length])) == 0); } c = next_char (ref_l, ref_c, A68_FALSE); } scan_buf[chars_in_buf - term_s_length] = NULL_CHAR; z = new_string (term_s, scan_buf, term_s, NO_TEXT); if (type == STYLE_I_PRAGMAT_SYMBOL || type == BOLD_PRAGMAT_SYMBOL) { isolate_options (scan_buf, start_l); } return (z); #undef ADD_ONE_CHAR #undef INIT_BUFFER } /** @brief Attribute for format item. @param ch Format item in character form. @return See brief description. **/ static int get_format_item (char ch) { switch (TO_LOWER (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 (0); } } } /* Macros */ #define SCAN_DIGITS(c)\ while (IS_DIGIT (c)) {\ (sym++)[0] = (c);\ (c) = next_char (ref_l, ref_s, A68_TRUE);\ } #define SCAN_EXPONENT_PART(c)\ (sym++)[0] = EXPONENT_CHAR;\ (c) = next_char (ref_l, ref_s, A68_TRUE);\ if ((c) == '+' || (c) == '-') {\ (sym++)[0] = (c);\ (c) = next_char (ref_l, ref_s, A68_TRUE);\ }\ SCAN_ERROR (!IS_DIGIT (c), *start_l, *start_c, ERROR_EXPONENT_DIGIT);\ SCAN_DIGITS (c) /** @brief Whether input shows exponent character. @param ref_l Source line we're scanning. @param ref_s Character (in source line) we're scanning. @param ch Last scanned char. @return See brief description. **/ static BOOL_T is_exp_char (LINE_T ** ref_l, char **ref_s, char *ch) { BOOL_T ret = A68_FALSE; char exp_syms[3]; if (OPTION_STROPPING (&program) == UPPER_STROPPING) { exp_syms[0] = EXPONENT_CHAR; exp_syms[1] = (char) TO_UPPER (EXPONENT_CHAR); exp_syms[2] = NULL_CHAR; } else { exp_syms[0] = (char) TO_UPPER (EXPONENT_CHAR); exp_syms[1] = BACKSLASH_CHAR; exp_syms[2] = NULL_CHAR; } save_state (*ref_l, *ref_s, *ch); if (strchr (exp_syms, *ch) != NO_TEXT) { *ch = next_char (ref_l, ref_s, A68_TRUE); ret = (BOOL_T) (strchr ("+-0123456789", *ch) != NO_TEXT); } restore_state (ref_l, ref_s, ch); return (ret); } /** @brief Whether input shows radix character. @param ref_l Source line we're scanning. @param ref_s Character (in source line) we're scanning. @param ch Character to test. @return See brief description. **/ static BOOL_T is_radix_char (LINE_T ** ref_l, char **ref_s, char *ch) { BOOL_T ret = A68_FALSE; save_state (*ref_l, *ref_s, *ch); if (OPTION_STROPPING (&program) == QUOTE_STROPPING) { if (*ch == TO_UPPER (RADIX_CHAR)) { *ch = next_char (ref_l, ref_s, A68_TRUE); ret = (BOOL_T) (strchr ("0123456789ABCDEF", *ch) != NO_TEXT); } } else { if (*ch == RADIX_CHAR) { *ch = next_char (ref_l, ref_s, A68_TRUE); ret = (BOOL_T) (strchr ("0123456789abcdef", *ch) != NO_TEXT); } } restore_state (ref_l, ref_s, ch); return (ret); } /** @brief Whether input shows decimal point. @param ref_l Source line we're scanning. @param ref_s Character (in source line) we're scanning. @param ch Character to test. @return See brief description. **/ static BOOL_T is_decimal_point (LINE_T ** ref_l, char **ref_s, char *ch) { BOOL_T ret = A68_FALSE; save_state (*ref_l, *ref_s, *ch); if (*ch == POINT_CHAR) { char exp_syms[3]; if (OPTION_STROPPING (&program) == UPPER_STROPPING) { exp_syms[0] = EXPONENT_CHAR; exp_syms[1] = (char) TO_UPPER (EXPONENT_CHAR); exp_syms[2] = NULL_CHAR; } else { exp_syms[0] = (char) TO_UPPER (EXPONENT_CHAR); exp_syms[1] = BACKSLASH_CHAR; exp_syms[2] = NULL_CHAR; } *ch = next_char (ref_l, ref_s, A68_TRUE); if (strchr (exp_syms, *ch) != NO_TEXT) { *ch = next_char (ref_l, ref_s, A68_TRUE); ret = (BOOL_T) (strchr ("+-0123456789", *ch) != NO_TEXT); } else { ret = (BOOL_T) (strchr ("0123456789", *ch) != NO_TEXT); } } restore_state (ref_l, ref_s, ch); return (ret); } /** @brief Get next token from internal copy of source file.. @param in_format Are we scanning a format text. @param ref_l Source line we're scanning. @param ref_s Character (in source line) we're scanning. @param start_l Line where token starts. @param start_c Character where token starts. @param att Attribute designated to token. **/ static void get_next_token (BOOL_T in_format, LINE_T ** ref_l, char **ref_s, LINE_T ** start_l, char **start_c, int *att) { char c = **ref_s, *sym = scan_buf; sym[0] = NULL_CHAR; 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] = NULL_CHAR; return; } /***************/ /* In a format */ /***************/ if (in_format) { char *format_items; if (OPTION_STROPPING (&program) == UPPER_STROPPING) { format_items = "/%\\+-.abcdefghijklmnopqrstuvwxyz"; } else {/* if (OPTION_STROPPING (&program) == QUOTE_STROPPING) */ format_items = "/%\\+-.ABCDEFGHIJKLMNOPQRSTUVWXYZ"; } if (a68g_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, A68_FALSE); return; } if (IS_DIGIT (c)) { /* INT denotation for static replicator */ SCAN_DIGITS (c); sym[0] = NULL_CHAR; *att = STATIC_REPLICATOR; return; } } /*******************/ /* Not in a format */ /*******************/ if (IS_UPPER (c)) { if (OPTION_STROPPING (&program) == UPPER_STROPPING) { /* Upper case word - bold tag */ while (IS_UPPER (c) || c == '_') { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } sym[0] = NULL_CHAR; *att = BOLD_TAG; } else if (OPTION_STROPPING (&program) == QUOTE_STROPPING) { while (IS_UPPER (c) || IS_DIGIT (c) || c == '_') { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_TRUE); } sym[0] = NULL_CHAR; *att = IDENTIFIER; } } else if (c == '\'') { /* Quote, uppercase word, quote - bold tag */ int k = 0; c = next_char (ref_l, ref_s, A68_FALSE); while (IS_UPPER (c) || IS_DIGIT (c) || c == '_') { (sym++)[0] = c; k++; c = next_char (ref_l, ref_s, A68_TRUE); } SCAN_ERROR (k == 0, *start_l, *start_c, ERROR_QUOTED_BOLD_TAG); sym[0] = NULL_CHAR; *att = BOLD_TAG; /* Skip terminating quote, or complain if it is not there */ SCAN_ERROR (c != '\'', *start_l, *start_c, ERROR_QUOTED_BOLD_TAG); c = next_char (ref_l, ref_s, A68_FALSE); } else if (IS_LOWER (c)) { /* Lower case word - identifier */ while (IS_LOWER (c) || IS_DIGIT (c) || c == '_') { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_TRUE); } sym[0] = NULL_CHAR; *att = IDENTIFIER; } else if (c == POINT_CHAR) { /* Begins with a point symbol - point, dotdot, 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, A68_TRUE); SCAN_DIGITS (c); if (is_exp_char (ref_l, ref_s, &c)) { SCAN_EXPONENT_PART (c); } sym[0] = NULL_CHAR; *att = REAL_DENOTATION; } else { c = next_char (ref_l, ref_s, A68_TRUE); if (c == POINT_CHAR) { (sym++)[0] = POINT_CHAR; (sym++)[0] = POINT_CHAR; sym[0] = NULL_CHAR; *att = DOTDOT_SYMBOL; c = next_char (ref_l, ref_s, A68_FALSE); } else { (sym++)[0] = POINT_CHAR; sym[0] = NULL_CHAR; *att = POINT_SYMBOL; } } } else if (IS_DIGIT (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, A68_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, A68_TRUE); if (OPTION_STROPPING (&program) == UPPER_STROPPING) { while (IS_DIGIT (c) || strchr ("abcdef", c) != NO_TEXT) { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_TRUE); } } else { while (IS_DIGIT (c) || strchr ("ABCDEF", c) != NO_TEXT) { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_TRUE); } } *att = BITS_DENOTATION; } else { *att = INT_DENOTATION; } sym[0] = NULL_CHAR; } else if (c == QUOTE_CHAR) { /* STRING denotation */ BOOL_T stop = A68_FALSE; while (!stop) { c = next_char (ref_l, ref_s, A68_FALSE); while (c != QUOTE_CHAR && c != STOP_CHAR) { SCAN_ERROR (EOL (c), *start_l, *start_c, ERROR_LONG_STRING); (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } SCAN_ERROR (*ref_l == NO_LINE, *start_l, *start_c, ERROR_UNTERMINATED_STRING); c = next_char (ref_l, ref_s, A68_FALSE); if (c == QUOTE_CHAR) { (sym++)[0] = QUOTE_CHAR; } else { stop = A68_TRUE; } } sym[0] = NULL_CHAR; *att = (in_format ? LITERAL : ROW_CHAR_DENOTATION); } else if (a68g_strchr ("#$()[]{},;@", c) != NO_TEXT) { /* Single character symbols */ (sym++)[0] = c; (void) next_char (ref_l, ref_s, A68_FALSE); sym[0] = NULL_CHAR; *att = 0; } else if (c == '|') { /* Bar */ (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); if (c == ':') { (sym++)[0] = c; (void) next_char (ref_l, ref_s, A68_FALSE); } sym[0] = NULL_CHAR; *att = 0; } else if (c == '!' && OPTION_STROPPING (&program) == QUOTE_STROPPING) { /* Bar, will be replaced with modern variant. For this reason ! is not a MONAD with quote-stropping */ (sym++)[0] = '|'; c = next_char (ref_l, ref_s, A68_FALSE); if (c == ':') { (sym++)[0] = c; (void) next_char (ref_l, ref_s, A68_FALSE); } sym[0] = NULL_CHAR; *att = 0; } else if (c == ':') { /* Colon, semicolon, IS, ISNT */ (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); if (c == '=') { (sym++)[0] = c; if ((c = next_char (ref_l, ref_s, A68_FALSE)) == ':') { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } } else if (c == '/') { (sym++)[0] = c; if ((c = next_char (ref_l, ref_s, A68_FALSE)) == '=') { (sym++)[0] = c; if ((c = next_char (ref_l, ref_s, A68_FALSE)) == ':') { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } } } else if (c == ':') { (sym++)[0] = c; if ((c = next_char (ref_l, ref_s, A68_FALSE)) == '=') { (sym++)[0] = c; } } sym[0] = NULL_CHAR; *att = 0; } else if (c == '=') { /* Operator starting with "=" */ char *scanned = sym; (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); if (a68g_strchr (NOMADS, c) != NO_TEXT) { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } if (c == '=') { (sym++)[0] = c; if (next_char (ref_l, ref_s, A68_FALSE) == ':') { (sym++)[0] = ':'; c = next_char (ref_l, ref_s, A68_FALSE); if (strlen (sym) < 4 && c == '=') { (sym++)[0] = '='; (void) next_char (ref_l, ref_s, A68_FALSE); } } } else if (c == ':') { (sym++)[0] = c; sym[0] = NULL_CHAR; if (next_char (ref_l, ref_s, A68_FALSE) == '=') { (sym++)[0] = '='; (void) next_char (ref_l, ref_s, A68_FALSE); } else { SCAN_ERROR (!(strcmp (scanned, "=:") == 0 || strcmp (scanned, "==:") == 0), *start_l, *start_c, ERROR_INVALID_OPERATOR_TAG); } } sym[0] = NULL_CHAR; if (strcmp (scanned, "=") == 0) { *att = EQUALS_SYMBOL; } else { *att = OPERATOR; } } else if (a68g_strchr (MONADS, c) != NO_TEXT || a68g_strchr (NOMADS, c) != NO_TEXT) { /* Operator */ char *scanned = sym; (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); if (a68g_strchr (NOMADS, c) != NO_TEXT) { (sym++)[0] = c; c = next_char (ref_l, ref_s, A68_FALSE); } if (c == '=') { (sym++)[0] = c; if (next_char (ref_l, ref_s, A68_FALSE) == ':') { (sym++)[0] = ':'; c = next_char (ref_l, ref_s, A68_FALSE); if (strlen (scanned) < 4 && c == '=') { (sym++)[0] = '='; (void) next_char (ref_l, ref_s, A68_FALSE); } } } else if (c == ':') { (sym++)[0] = c; sym[0] = NULL_CHAR; if (next_char (ref_l, ref_s, A68_FALSE) == '=') { (sym++)[0] = '='; sym[0] = NULL_CHAR; (void) next_char (ref_l, ref_s, A68_FALSE); } else { SCAN_ERROR (strcmp (&(scanned[1]), "=:") != 0, *start_l, *start_c, ERROR_INVALID_OPERATOR_TAG); } } sym[0] = NULL_CHAR; *att = OPERATOR; } else { /* Afuuus ... strange characters! */ unworthy (*start_l, *start_c, (int) c); } } /** @brief Whether att opens an embedded clause. @param att Attribute under test. @return Whether att opens an embedded clause. **/ static BOOL_T 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 DOWNTO_SYMBOL: case WHILE_SYMBOL: case DO_SYMBOL: case SUB_SYMBOL: case ACCO_SYMBOL: { return (A68_TRUE); } } return (A68_FALSE); } /** @brief Whether att closes an embedded clause. @param att Attribute under test. @return Whether att closes an embedded clause. **/ static BOOL_T 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: case OCCA_SYMBOL: { return (A68_TRUE); } } return (A68_FALSE); } /** @brief Cast a string to lower case. @param p String to cast. **/ static void make_lower_case (char *p) { for (; p != NO_TEXT && p[0] != NULL_CHAR; p++) { p[0] = (char) TO_LOWER (p[0]); } } /** @brief Construct a linear list of tokens. @param root Node where to insert new symbol. @param level Current recursive descent depth. @param in_format Whether we scan a format. @param l Current source line. @param s Current character in source line. @param start_l Source line where symbol starts. @param start_c Character where symbol starts. **/ static void tokenise_source (NODE_T ** root, int level, BOOL_T in_format, LINE_T ** l, char **s, LINE_T ** start_l, char **start_c) { char *lpr = NO_TEXT; int lprt = 0; while (l != NO_VAR && !stop_scanner) { int att = 0; get_next_token (in_format, l, s, start_l, start_c, &att); if (scan_buf[0] == STOP_CHAR) { stop_scanner = A68_TRUE; } else if (strlen (scan_buf) > 0 || att == ROW_CHAR_DENOTATION || att == LITERAL) { KEYWORD_T *kw; char *c = NO_TEXT; BOOL_T make_node = A68_TRUE; char *trailing = NO_TEXT; if (att != IDENTIFIER) { kw = find_keyword (top_keyword, scan_buf); } else { kw = NO_KEYWORD; } if (!(kw != NO_KEYWORD && att != ROW_CHAR_DENOTATION)) { if (att == IDENTIFIER) { make_lower_case (scan_buf); } if (att != ROW_CHAR_DENOTATION && att != LITERAL) { int len = (int) strlen (scan_buf); while (len >= 1 && scan_buf[len - 1] == '_') { trailing = "_"; scan_buf[len - 1] = NULL_CHAR; len--; } } c = TEXT (add_token (&top_token, 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 (find_keyword (top_keyword, "GOTO")); make_node = A68_FALSE; } else { att = ATTRIBUTE (kw); c = TEXT (kw); } } else { if (att == 0 || att == BOLD_TAG) { att = ATTRIBUTE (kw); } c = TEXT (kw); /* Handle pragments */ if (att == STYLE_II_COMMENT_SYMBOL || att == STYLE_I_COMMENT_SYMBOL || att == BOLD_COMMENT_SYMBOL) { char *nlpr = pragment (ATTRIBUTE (kw), l, s); if (lpr == NO_TEXT || (int) strlen (lpr) == 0) { lpr = nlpr; } else { lpr = new_string (lpr, "\n\n", nlpr, NO_TEXT); } lprt = att; make_node = A68_FALSE; } else if (att == STYLE_I_PRAGMAT_SYMBOL || att == BOLD_PRAGMAT_SYMBOL) { char *nlpr = pragment (ATTRIBUTE (kw), l, s); if (lpr == NO_TEXT || (int) strlen (lpr) == 0) { lpr = nlpr; } else { lpr = new_string (lpr, "\n\n", nlpr, NO_TEXT); } lprt = att; if (!stop_scanner) { (void) set_options (OPTION_LIST (&program), A68_FALSE); make_node = A68_FALSE; } } } } /* Add token to the tree */ if (make_node) { NODE_T *q = new_node (); INFO (q) = 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 DOTDOT_SYMBOL: case SEMI_SYMBOL: { GINFO (q) = NO_GINFO; break; } default: { GINFO (q) = new_genie_info (); break; } } STATUS (q) = OPTION_NODEMASK (&program); 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 (lpr != NO_TEXT) { NPRAGMENT (q) = lpr; NPRAGMENT_TYPE (q) = lprt; lpr = NO_TEXT; lprt = 0; } if (*root != NO_NODE) { NEXT (*root) = q; } if (TOP_NODE (&program) == NO_NODE) { TOP_NODE (&program) = q; } *root = q; if (trailing != NO_TEXT) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, q, WARNING_TRAILING, 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, A68_TRUE, l, s, start_l, start_c); } else if (in_format && open_nested_clause (att)) { NODE_T *z = PREVIOUS (*root); if (z != NO_NODE && is_one_of (z, FORMAT_ITEM_N, FORMAT_ITEM_G, FORMAT_ITEM_H, FORMAT_ITEM_F)) { tokenise_source (root, level, A68_FALSE, l, s, start_l, start_c); } else if (att == OPEN_SYMBOL) { ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL; } else if (OPTION_BRACKETS (&program) && att == SUB_SYMBOL) { ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL; } else if (OPTION_BRACKETS (&program) && att == ACCO_SYMBOL) { ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL; } } else if (!in_format && level > 0 && open_nested_clause (att)) { tokenise_source (root, level + 1, A68_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 (&program) && in_format && att == BUS_SYMBOL) { ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL; } else if (OPTION_BRACKETS (&program) && in_format && att == OCCA_SYMBOL) { ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL; } } } } /** @brief Tokenise source file, build initial syntax tree. @return Whether tokenising ended satisfactorily. **/ BOOL_T lexical_analyser (void) { LINE_T *l, *start_l = NO_LINE; char *s = NO_TEXT, *start_c = NO_TEXT; NODE_T *root = NO_NODE; scan_buf = NO_TEXT; max_scan_buf_length = source_file_size = get_source_size (); /* Errors in file? */ if (max_scan_buf_length == 0) { return (A68_FALSE); } if (OPTION_RUN_SCRIPT (&program)) { scan_buf = (char *) get_temp_heap_space ((unsigned) (8 + max_scan_buf_length)); if (!read_script_file ()) { return (A68_FALSE); } } else { max_scan_buf_length += KILOBYTE; /* for the environ, more than enough */ scan_buf = (char *) get_temp_heap_space ((unsigned) max_scan_buf_length); /* Errors in file? */ if (!read_source_file ()) { return (A68_FALSE); } } /* Start tokenising */ read_error = A68_FALSE; stop_scanner = A68_FALSE; if ((l = TOP_LINE (&program)) != NO_LINE) { s = STRING (l); } tokenise_source (&root, 0, A68_FALSE, &l, &s, &start_l, &start_c); return (A68_TRUE); } /************************************************/ /* A small refinement preprocessor for Algol68G */ /************************************************/ /** @brief Whether refinement terminator. @param p Position in syntax tree. @return See brief description. **/ static BOOL_T is_refinement_terminator (NODE_T * p) { if (IS (p, POINT_SYMBOL)) { if (IN_PRELUDE (NEXT (p))) { return (A68_TRUE); } else { return (whether (p, POINT_SYMBOL, IDENTIFIER, COLON_SYMBOL, STOP)); } } else { return (A68_FALSE); } } /** @brief Get refinement definitions in the internal source. **/ void get_refinements (void) { NODE_T *p = TOP_NODE (&program); TOP_REFINEMENT (&program) = NO_REFINEMENT; /* First look where the prelude ends */ while (p != NO_NODE && IN_PRELUDE (p)) { FORWARD (p); } /* Determine whether the program contains refinements at all */ while (p != NO_NODE && !IN_PRELUDE (p) && !is_refinement_terminator (p)) { FORWARD (p); } if (p == NO_NODE || IN_PRELUDE (p)) { return; } /* Apparently this is code with refinements */ FORWARD (p); if (p == NO_NODE || IN_PRELUDE (p)) { /* Ok, we accept a program with no refinements as well */ return; } while (p != NO_NODE && !IN_PRELUDE (p) && whether (p, IDENTIFIER, COLON_SYMBOL, STOP)) { REFINEMENT_T *new_one = (REFINEMENT_T *) get_fixed_heap_space ((size_t) SIZE_AL (REFINEMENT_T)), *x; BOOL_T exists; NEXT (new_one) = NO_REFINEMENT; NAME (new_one) = NSYMBOL (p); APPLICATIONS (new_one) = 0; LINE_DEFINED (new_one) = LINE (INFO (p)); LINE_APPLIED (new_one) = NO_LINE; NODE_DEFINED (new_one) = p; BEGIN (new_one) = END (new_one) = NO_NODE; p = NEXT_NEXT (p); if (p == NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, NO_NODE, ERROR_REFINEMENT_EMPTY); return; } else { BEGIN (new_one) = p; } while (p != NO_NODE && ATTRIBUTE (p) != POINT_SYMBOL) { END (new_one) = p; FORWARD (p); } if (p == NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, NO_NODE, ERROR_SYNTAX_EXPECTED, POINT_SYMBOL); return; } else { FORWARD (p); } /* Do we already have one by this name */ x = TOP_REFINEMENT (&program); exists = A68_FALSE; while (x != NO_REFINEMENT && !exists) { if (NAME (x) == NAME (new_one)) { diagnostic_node (A68_SYNTAX_ERROR, NODE_DEFINED (new_one), ERROR_REFINEMENT_DEFINED); exists = A68_TRUE; } FORWARD (x); } /* Straight insertion in chain */ if (!exists) { NEXT (new_one) = TOP_REFINEMENT (&program); TOP_REFINEMENT (&program) = new_one; } } if (p != NO_NODE && !IN_PRELUDE (p)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_REFINEMENT_INVALID); } } /** @brief Put refinement applications in the internal source. **/ void put_refinements (void) { REFINEMENT_T *x; NODE_T *p, *point; /* If there are no refinements, there's little to do */ if (TOP_REFINEMENT (&program) == NO_REFINEMENT) { return; } /* Initialisation */ x = TOP_REFINEMENT (&program); while (x != NO_REFINEMENT) { APPLICATIONS (x) = 0; FORWARD (x); } /* Before we introduce infinite loops, find where closing-prelude starts */ p = TOP_NODE (&program); while (p != NO_NODE && IN_PRELUDE (p)) { FORWARD (p); } while (p != NO_NODE && !IN_PRELUDE (p)) { FORWARD (p); } ABEND (p == NO_NODE, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); point = p; /* We need to substitute until the first point */ p = TOP_NODE (&program); while (p != NO_NODE && ATTRIBUTE (p) != POINT_SYMBOL) { if (IS (p, IDENTIFIER)) { /* See if we can find its definition */ REFINEMENT_T *y = NO_REFINEMENT; x = TOP_REFINEMENT (&program); while (x != NO_REFINEMENT && y == NO_REFINEMENT) { if (NAME (x) == NSYMBOL (p)) { y = x; } else { FORWARD (x); } } if (y != NO_REFINEMENT) { /* We found its definition */ APPLICATIONS (y)++; if (APPLICATIONS (y) > 1) { diagnostic_node (A68_SYNTAX_ERROR, NODE_DEFINED (y), ERROR_REFINEMENT_APPLIED); FORWARD (p); } else { /* Tie the definition in the tree */ LINE_APPLIED (y) = LINE (INFO (p)); if (PREVIOUS (p) != NO_NODE) { NEXT (PREVIOUS (p)) = BEGIN (y); } if (BEGIN (y) != NO_NODE) { PREVIOUS (BEGIN (y)) = PREVIOUS (p); } if (NEXT (p) != NO_NODE) { PREVIOUS (NEXT (p)) = END (y); } if (END (y) != NO_NODE) { NEXT (END (y)) = NEXT (p); } p = BEGIN (y); /* So we can substitute the refinements within */ } } else { FORWARD (p); } } else { FORWARD (p); } } /* After the point we ignore it all until the prelude */ if (p != NO_NODE && IS (p, POINT_SYMBOL)) { if (PREVIOUS (p) != NO_NODE) { NEXT (PREVIOUS (p)) = point; } if (PREVIOUS (point) != NO_NODE) { PREVIOUS (point) = PREVIOUS (p); } } else { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_SYNTAX_EXPECTED, POINT_SYMBOL); } /* Has the programmer done it well? */ if (ERROR_COUNT (&program) == 0) { x = TOP_REFINEMENT (&program); while (x != NO_REFINEMENT) { if (APPLICATIONS (x) == 0) { diagnostic_node (A68_SYNTAX_ERROR, NODE_DEFINED (x), ERROR_REFINEMENT_NOT_APPLIED); } FORWARD (x); } } } /*****************************************************/ /* Top-down parser, elaborates the control structure */ /*****************************************************/ /** @brief Insert alt equals symbol. @param p Node after which to insert. **/ static void insert_alt_equals (NODE_T * p) { NODE_T *q = new_node (); *q = *p; INFO (q) = new_node_info (); *INFO (q) = *INFO (p); GINFO (q) = new_genie_info (); *GINFO (q) = *GINFO (p); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; NSYMBOL (q) = TEXT (add_token (&top_token, "=")); NEXT (p) = q; PREVIOUS (q) = p; if (NEXT (q) != NO_NODE) { PREVIOUS (NEXT (q)) = q; } } /** @brief Substitute brackets. @param p Node in syntax tree. **/ void substitute_brackets (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { substitute_brackets (SUB (p)); switch (ATTRIBUTE (p)) { case ACCO_SYMBOL: { ATTRIBUTE (p) = OPEN_SYMBOL; break; } case OCCA_SYMBOL: { ATTRIBUTE (p) = CLOSE_SYMBOL; break; } case SUB_SYMBOL: { ATTRIBUTE (p) = OPEN_SYMBOL; break; } case BUS_SYMBOL: { ATTRIBUTE (p) = CLOSE_SYMBOL; break; } } } } /** @brief Whether token terminates a unit. @param p Node in syntax tree. \return TRUE or FALSE whether token terminates a unit **/ static BOOL_T 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 EDOC_SYMBOL: case OCCA_SYMBOL: { return (A68_TRUE); } } return (A68_FALSE); } /** @brief Whether token is a unit-terminator in a loop clause. @param p Node in syntax tree. @return Whether token is a unit-terminator in a loop clause. **/ static BOOL_T is_loop_keyword (NODE_T * p) { switch (ATTRIBUTE (p)) { case FOR_SYMBOL: case FROM_SYMBOL: case BY_SYMBOL: case TO_SYMBOL: case DOWNTO_SYMBOL: case WHILE_SYMBOL: case DO_SYMBOL: { return (A68_TRUE); } } return (A68_FALSE); } /** @brief Whether token cannot follow semicolon or EXIT. @param p Node in syntax tree. @return Whether token cannot follow semicolon or EXIT. **/ static BOOL_T 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 EDOC_SYMBOL: case OCCA_SYMBOL: case OD_SYMBOL: case UNTIL_SYMBOL: { return (A68_TRUE); } default: { return (A68_FALSE); } } } /** @brief Get good attribute. @param p Node in syntax tree. @return See brief description. **/ static int get_good_attribute (NODE_T * p) { switch (ATTRIBUTE (p)) { case UNIT: case TERTIARY: case SECONDARY: case PRIMARY: { return (get_good_attribute (SUB (p))); } default: { return (ATTRIBUTE (p)); } } } /** @brief Preferably don't put intelligible diagnostic here. @param p Node in syntax tree. @return See brief description. **/ static BOOL_T dont_mark_here (NODE_T * p) { switch (ATTRIBUTE (p)) { case ACCO_SYMBOL: 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 BOOL_SYMBOL: case BUS_SYMBOL: case BY_SYMBOL: case BYTES_SYMBOL: case CASE_SYMBOL: case CHANNEL_SYMBOL: case CHAR_SYMBOL: case CLOSE_SYMBOL: case CODE_SYMBOL: case COLON_SYMBOL: case COLUMN_SYMBOL: case COMMA_SYMBOL: case COMPLEX_SYMBOL: case COMPL_SYMBOL: case DIAGONAL_SYMBOL: case DO_SYMBOL: case DOTDOT_SYMBOL: case DOWNTO_SYMBOL: case EDOC_SYMBOL: case ELIF_SYMBOL: case ELSE_BAR_SYMBOL: case ELSE_SYMBOL: case EMPTY_SYMBOL: case END_SYMBOL: case ENVIRON_SYMBOL: case EQUALS_SYMBOL: case ESAC_SYMBOL: case EXIT_SYMBOL: case FALSE_SYMBOL: case FILE_SYMBOL: case FI_SYMBOL: case FLEX_SYMBOL: case FORMAT_DELIMITER_SYMBOL: case FORMAT_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 OCCA_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 PIPE_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 SOUND_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 TRANSPOSE_SYMBOL: case TRUE_SYMBOL: case UNION_SYMBOL: case UNTIL_SYMBOL: case VOID_SYMBOL: case WHILE_SYMBOL: /* and than */ case SERIAL_CLAUSE: case ENQUIRY_CLAUSE: case INITIALISER_SERIES: case DECLARATION_LIST: { return (A68_TRUE); } } return (A68_FALSE); } /** @brief Intelligible diagnostic from syntax tree branch. @param p Node in syntax tree. @param w Where to put error message. @return See brief description. **/ char *phrase_to_text (NODE_T * p, NODE_T ** w) { #define MAX_TERMINALS 8 int count = 0, line = -1; static char buffer[BUFFER_SIZE]; for (buffer[0] = NULL_CHAR; p != NO_NODE && count < MAX_TERMINALS; FORWARD (p)) { if (LINE_NUMBER (p) > 0) { int gatt = get_good_attribute (p); char *z = non_terminal_string (input_line, 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 (dont_mark_here (*w)) { *w = p; } } /* Add initiation */ if (count == 0) { if (w != NO_VAR) { bufcat (buffer, "construct beginning with", BUFFER_SIZE); } } else if (count == 1) { bufcat (buffer, " followed by", BUFFER_SIZE); } else if (count == 2) { bufcat (buffer, " and then", BUFFER_SIZE); } else if (count >= 3) { bufcat (buffer, ",", BUFFER_SIZE); } /* Attribute or symbol */ if (z != NO_TEXT && SUB (p) != NO_NODE) { if (gatt == IDENTIFIER || gatt == OPERATOR || gatt == DENOTATION) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } else { if (strchr ("aeio", z[0]) != NO_TEXT) { bufcat (buffer, " an", BUFFER_SIZE); } else { bufcat (buffer, " a", BUFFER_SIZE); } ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " %s", z) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } } else if (z != NO_TEXT && SUB (p) == NO_NODE) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } else if (NSYMBOL (p) != NO_TEXT) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, 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) { bufcat (buffer, " starting", BUFFER_SIZE); } ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " in line %d", line) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } count++; } } if (p != NO_NODE && count == MAX_TERMINALS) { bufcat (buffer, " etcetera", BUFFER_SIZE); } return (buffer); } /** @brief Intelligible diagnostic from syntax tree branch. @param p Node in syntax tree. @param w Where to put error message. @return See brief description. **/ char *phrase_to_text_2 (NODE_T * p, NODE_T ** w) { #define MAX_TERMINALS 8 int count = 0; static char buffer[BUFFER_SIZE]; for (buffer[0] = NULL_CHAR; p != NO_NODE && count < MAX_TERMINALS; FORWARD (p)) { if (LINE_NUMBER (p) > 0) { char *z = non_terminal_string (input_line, ATTRIBUTE (p)); /* 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 (dont_mark_here (*w)) { *w = p; } } /* Add initiation */ if (count >= 1) { bufcat (buffer, ",", BUFFER_SIZE); } /* Attribute or symbol */ if (z != NO_TEXT) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " %s", z) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } else if (NSYMBOL (p) != NO_TEXT) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); bufcat (buffer, edit_line, BUFFER_SIZE); } count++; } } if (p != NO_NODE && count == MAX_TERMINALS) { bufcat (buffer, " etcetera", BUFFER_SIZE); } return (buffer); } /* This is a parenthesis checker. After this checker, we know that at least brackets are matched. This stabilises later parser phases. Top-down parsing is done to place error diagnostics near offending lines. */ static char bracket_check_error_text[BUFFER_SIZE]; /** @brief Intelligible diagnostics for the bracket checker. @param txt Buffer to which to append text. @param n Count mismatch (~= 0). @param bra Opening bracket. @param ket Expected closing bracket. @return See brief description. **/ static void bracket_check_error (char *txt, int n, char *bra, char *ket) { if (n != 0) { char b[BUFFER_SIZE]; ASSERT (snprintf (b, SNPRINTF_SIZE, "\"%s\" without matching \"%s\"", (n > 0 ? bra : ket), (n > 0 ? ket : bra)) >= 0); if (strlen (txt) > 0) { bufcat (txt, " and ", BUFFER_SIZE); } bufcat (txt, b, BUFFER_SIZE); } } /** @brief Diagnose brackets in local branch of the tree. @param p Node in syntax tree. @return Error message. **/ static char *bracket_check_diagnose (NODE_T * p) { int begins = 0, opens = 0, format_delims = 0, format_opens = 0, subs = 0, ifs = 0, cases = 0, dos = 0, accos = 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 ACCO_SYMBOL: { accos++; break; } case OCCA_SYMBOL: { accos--; 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; } } } bracket_check_error_text[0] = NULL_CHAR; bracket_check_error (bracket_check_error_text, begins, "BEGIN", "END"); bracket_check_error (bracket_check_error_text, opens, "(", ")"); bracket_check_error (bracket_check_error_text, format_opens, "(", ")"); bracket_check_error (bracket_check_error_text, format_delims, "$", "$"); bracket_check_error (bracket_check_error_text, accos, "{", "}"); bracket_check_error (bracket_check_error_text, subs, "[", "]"); bracket_check_error (bracket_check_error_text, ifs, "IF", "FI"); bracket_check_error (bracket_check_error_text, cases, "CASE", "ESAC"); bracket_check_error (bracket_check_error_text, dos, "DO", "OD"); return (bracket_check_error_text); } /** @brief Driver for locally diagnosing non-matching tokens. @param top @param p Node in syntax tree. @return Token from where to continue. **/ static NODE_T *bracket_check_parse (NODE_T * top, NODE_T * p) { BOOL_T ignore_token; for (; p != NO_NODE; FORWARD (p)) { int ket = STOP; NODE_T *q = NO_NODE; ignore_token = A68_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 ACCO_SYMBOL: { ket = OCCA_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 OCCA_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 = A68_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); diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_PARENTHESIS, (strlen (diag) > 0 ? diag : INFO_MISSING_KEYWORDS)); longjmp (top_down_crash_exit, 1); } else { char *diag = bracket_check_diagnose (top); diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_PARENTHESIS_2, ATTRIBUTE (q), LINE (INFO (q)), ket, (strlen (diag) > 0 ? diag : INFO_MISSING_KEYWORDS)); longjmp (top_down_crash_exit, 1); } } return (NO_NODE); } /** @brief Driver for globally diagnosing non-matching tokens. @param top Top node in syntax tree. **/ void check_parenthesis (NODE_T * top) { if (!setjmp (top_down_crash_exit)) { if (bracket_check_parse (top, top) != NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, top, ERROR_PARENTHESIS, INFO_MISSING_KEYWORDS); } } } /* Next is a top-down parser that branches out the basic blocks. After this we can assign symbol tables to basic blocks. */ /** @brief Give diagnose from top-down parser. @param start Embedding clause starts here. @param posit Error issued at this point. @param clause Type of clause being processed. @param expected Token expected. **/ static void top_down_diagnose (NODE_T * start, NODE_T * posit, int clause, int expected) { NODE_T *issue = (posit != NO_NODE ? posit : start); if (expected != 0) { diagnostic_node (A68_SYNTAX_ERROR, issue, ERROR_EXPECTED_NEAR, expected, clause, NSYMBOL (start), LINE (INFO (start))); } else { diagnostic_node (A68_SYNTAX_ERROR, issue, ERROR_UNBALANCED_KEYWORD, clause, NSYMBOL (start), LINE (INFO (start))); } } /** @brief Check for premature exhaustion of tokens. @param p Node in syntax tree. @param q **/ static void tokens_exhausted (NODE_T * p, NODE_T * q) { if (p == NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_KEYWORD); longjmp (top_down_crash_exit, 1); } } /* This part specifically branches out loop clauses */ /** @brief Whether in cast or formula with loop clause. @param p Node in syntax tree. @return Number of symbols to skip. **/ 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 (p, REF_SYMBOL)) { return (1); } else if (is_one_of (p, OPERATOR, BOLD_TAG, STOP)) { return (1); } else if (whether (p, UNION_SYMBOL, OPEN_SYMBOL, STOP)) { return (2); } else if (is_one_of (p, OPEN_SYMBOL, SUB_SYMBOL, STOP)) { int k; for (k = 0; p != NO_NODE && (is_one_of (p, OPEN_SYMBOL, SUB_SYMBOL, STOP)); FORWARD (p), k++) { ; } return (p != NO_NODE && (whether (p, UNION_SYMBOL, OPEN_SYMBOL, STOP) ? k : 0)); } return (0); } /** @brief Skip a unit in a loop clause (FROM u BY u TO u). @param p Node in syntax tree. @return Token from where to proceed or NO_NODE. **/ static NODE_T *top_down_skip_loop_unit (NODE_T * p) { /* Unit may start with, or consist of, a loop */ if (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 (is_loop_keyword (p)) { p = top_down_loop (p); } } else if (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 && is_loop_keyword (p)) { p = top_down_loop (p); } } else if (is_one_of (p, SEMI_SYMBOL, COMMA_SYMBOL, STOP) || IS (p, EXIT_SYMBOL)) { /* Statement separators */ return (p); } else { FORWARD (p); } } return (NO_NODE); } /** @brief Skip a loop clause. @param p Node in syntax tree. @return Token from where to proceed or NO_NODE. **/ static NODE_T *top_down_skip_loop_series (NODE_T * p) { BOOL_T siga; do { p = top_down_skip_loop_unit (p); siga = (BOOL_T) (p != NO_NODE && (is_one_of (p, SEMI_SYMBOL, EXIT_SYMBOL, COMMA_SYMBOL, COLON_SYMBOL, STOP))); if (siga) { FORWARD (p); } } while (!(p == NO_NODE || !siga)); return (p); } /** @brief Make branch of loop parts. @param p Node in syntax tree. @return Token from where to proceed or NO_NODE. **/ NODE_T *top_down_loop (NODE_T * p) { NODE_T *start = p, *q = p, *save; 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 (top_down_crash_exit, 1); } tokens_exhausted (FORWARD (q), start); if (is_one_of (q, FROM_SYMBOL, BY_SYMBOL, TO_SYMBOL, DOWNTO_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 (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 (is_one_of (q, BY_SYMBOL, TO_SYMBOL, DOWNTO_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 (top_down_crash_exit, 1); } 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 (is_one_of (q, TO_SYMBOL, DOWNTO_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 (top_down_crash_exit, 1); } make_sub (start, PREVIOUS (q), BY_SYMBOL); } if (is_one_of (q, TO_SYMBOL, DOWNTO_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 (top_down_crash_exit, 1); } 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 (top_down_crash_exit, 1); } make_sub (start, PREVIOUS (q), WHILE_SYMBOL); } if (is_one_of (q, DO_SYMBOL, ALT_DO_SYMBOL, STOP)) { int k = ATTRIBUTE (q); start = q; q = top_down_skip_loop_series (NEXT (q)); tokens_exhausted (q, start); if (ISNT (q, OD_SYMBOL)) { top_down_diagnose (start, q, LOOP_CLAUSE, OD_SYMBOL); longjmp (top_down_crash_exit, 1); } make_sub (start, q, k); } save = NEXT (start); make_sub (p, start, LOOP_CLAUSE); return (save); } /** @brief Driver for making branches of loop parts. @param p Node in syntax tree. **/ 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 (is_loop_keyword (q) != STOP) { q = top_down_loop (q); } else { FORWARD (q); } } } /** @brief Driver for making branches of until parts. @param p Node in syntax tree. **/ static void top_down_untils (NODE_T * p) { NODE_T *q = p; for (; q != NO_NODE; FORWARD (q)) { if (SUB (q) != NO_NODE) { top_down_untils (SUB (q)); } } q = p; while (q != NO_NODE) { if (IS (q, UNTIL_SYMBOL)) { NODE_T *u = q; while (NEXT (u) != NO_NODE) { FORWARD (u); } make_sub (q, PREVIOUS (u), UNTIL_SYMBOL); return; } else { FORWARD (q); } } } /* Branch anything except parts of a loop */ /** @brief Skip serial/enquiry clause (unit series). @param p Node in syntax tree. @return Token from where to proceed or NO_NODE. **/ static NODE_T *top_down_series (NODE_T * p) { BOOL_T siga = A68_TRUE; while (siga) { siga = A68_FALSE; p = top_down_skip_unit (p); if (p != NO_NODE) { if (is_one_of (p, SEMI_SYMBOL, EXIT_SYMBOL, COMMA_SYMBOL, STOP)) { siga = A68_TRUE; FORWARD (p); } } } return (p); } /** @brief Make branch of BEGIN .. END. @param begin_p @return Token from where to proceed or NO_NODE. **/ 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 || ISNT (end_p, END_SYMBOL)) { top_down_diagnose (begin_p, end_p, ENCLOSED_CLAUSE, END_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } else { make_sub (begin_p, end_p, BEGIN_SYMBOL); return (NEXT (begin_p)); } } /** @brief Make branch of CODE .. EDOC. @param code_p @return Token from where to proceed or NO_NODE. **/ static NODE_T *top_down_code (NODE_T * code_p) { NODE_T *edoc_p = top_down_series (NEXT (code_p)); if (edoc_p == NO_NODE || ISNT (edoc_p, EDOC_SYMBOL)) { diagnostic_node (A68_SYNTAX_ERROR, code_p, ERROR_KEYWORD); longjmp (top_down_crash_exit, 1); return (NO_NODE); } else { make_sub (code_p, edoc_p, CODE_SYMBOL); return (NEXT (code_p)); } } /** @brief Make branch of ( .. ). @param open_p @return Token from where to proceed or NO_NODE. **/ 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)) { make_sub (open_p, then_bar_p, OPEN_SYMBOL); return (NEXT (open_p)); } if (then_bar_p == NO_NODE || ISNT (then_bar_p, THEN_BAR_SYMBOL)) { top_down_diagnose (open_p, then_bar_p, ENCLOSED_CLAUSE, STOP); longjmp (top_down_crash_exit, 1); } 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)) { make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL); 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 || ISNT (close_p, CLOSE_SYMBOL)) { top_down_diagnose (open_p, elif_bar_p, ENCLOSED_CLAUSE, CLOSE_SYMBOL); longjmp (top_down_crash_exit, 1); } make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL); make_sub (elif_bar_p, PREVIOUS (close_p), THEN_BAR_SYMBOL); 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); make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL); 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 (top_down_crash_exit, 1); return (NO_NODE); } } /** @brief Make branch of [ .. ]. @param sub_p @return Token from where to proceed or NO_NODE. **/ 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)) { make_sub (sub_p, bus_p, SUB_SYMBOL); return (NEXT (sub_p)); } else { top_down_diagnose (sub_p, bus_p, 0, BUS_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } } /** @brief Make branch of { .. }. @param acco_p @return Token from where to proceed or NO_NODE. **/ static NODE_T *top_down_acco (NODE_T * acco_p) { NODE_T *occa_p = top_down_series (NEXT (acco_p)); if (occa_p != NO_NODE && IS (occa_p, OCCA_SYMBOL)) { make_sub (acco_p, occa_p, ACCO_SYMBOL); return (NEXT (acco_p)); } else { top_down_diagnose (acco_p, occa_p, ENCLOSED_CLAUSE, OCCA_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } } /** @brief Make branch of IF .. THEN .. ELSE .. FI. @param if_p @return Token from where to proceed or NO_NODE. **/ 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 || ISNT (then_p, THEN_SYMBOL)) { top_down_diagnose (if_p, then_p, CONDITIONAL_CLAUSE, THEN_SYMBOL); longjmp (top_down_crash_exit, 1); } 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)) { make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL); 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 || ISNT (fi_p, FI_SYMBOL)) { top_down_diagnose (if_p, fi_p, CONDITIONAL_CLAUSE, FI_SYMBOL); longjmp (top_down_crash_exit, 1); } else { make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL); make_sub (elif_p, PREVIOUS (fi_p), ELSE_SYMBOL); 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); make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL); make_sub (if_p, elif_p, IF_SYMBOL); return (fi_p); } else { top_down_diagnose (if_p, elif_p, CONDITIONAL_CLAUSE, FI_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } } /** @brief Make branch of CASE .. IN .. OUT .. ESAC. @param case_p @return Token from where to proceed or NO_NODE. **/ 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 || ISNT (in_p, IN_SYMBOL)) { top_down_diagnose (case_p, in_p, ENCLOSED_CLAUSE, IN_SYMBOL); longjmp (top_down_crash_exit, 1); } 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)) { make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL); 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 || ISNT (esac_p, ESAC_SYMBOL)) { top_down_diagnose (case_p, esac_p, ENCLOSED_CLAUSE, ESAC_SYMBOL); longjmp (top_down_crash_exit, 1); } else { make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL); make_sub (ouse_p, PREVIOUS (esac_p), OUT_SYMBOL); 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); make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL); make_sub (case_p, ouse_p, CASE_SYMBOL); return (esac_p); } else { top_down_diagnose (case_p, ouse_p, ENCLOSED_CLAUSE, ESAC_SYMBOL); longjmp (top_down_crash_exit, 1); return (NO_NODE); } } /** @brief Skip a unit. @param p Node in syntax tree. @return Token from where to proceed or NO_NODE. **/ NODE_T *top_down_skip_unit (NODE_T * p) { while (p != NO_NODE && !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 if (IS (p, CODE_SYMBOL)) { p = top_down_code (p); } else if (IS (p, ACCO_SYMBOL)) { p = top_down_acco (p); } else { FORWARD (p); } } return (p); } static NODE_T *top_down_skip_format (NODE_T *); /** @brief Make branch of ( .. ) in a format. @param open_p @return Token from where to proceed or NO_NODE. **/ 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)) { 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 (top_down_crash_exit, 1); return (NO_NODE); } } /** @brief Skip a format text. @param p Node in syntax tree. @return Token from where to proceed or NO_NODE. **/ 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 (is_one_of (p, FORMAT_CLOSE_SYMBOL, FORMAT_DELIMITER_SYMBOL, STOP)) { return (p); } else { FORWARD (p); } } return (NO_NODE); } /** @brief Make branch of $ .. $. @param p Node in syntax tree. **/ static void top_down_formats (NODE_T * p) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { if (SUB (q) != NO_NODE) { top_down_formats (SUB (q)); } } for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, FORMAT_DELIMITER_SYMBOL)) { NODE_T *f = NEXT (q); while (f != NO_NODE && ISNT (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 (top_down_crash_exit, 1); } else { make_sub (q, f, FORMAT_DELIMITER_SYMBOL); } } } } /** @brief Make branches of phrases for the bottom-up parser. @param p Node in syntax tree. **/ void top_down_parser (NODE_T * p) { if (p != NO_NODE) { if (!setjmp (top_down_crash_exit)) { (void) top_down_series (p); top_down_loops (p); top_down_untils (p); top_down_formats (p); } } } /********************************************/ /* Bottom-up parser, reduces all constructs */ /********************************************/ /** @brief Detect redefined keyword. @param p Node in syntax tree. @param construct Where detected. */ static void detect_redefined_keyword (NODE_T * p, int construct) { if (p != NO_NODE && whether (p, KEYWORD, EQUALS_SYMBOL, STOP)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_REDEFINED_KEYWORD, NSYMBOL (p), construct); } } /** @brief Whether a series is serial or collateral. @param p Node in syntax tree. @return Whether a series is serial or collateral. **/ static int serial_or_collateral (NODE_T * p) { NODE_T *q; int semis = 0, commas = 0, exits = 0; for (q = p; q != NO_NODE; FORWARD (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)); } } /** @brief Whether formal bounds. @param p Node in syntax tree. @return Whether formal bounds. **/ static BOOL_T is_formal_bounds (NODE_T * p) { if (p == NO_NODE) { return (A68_TRUE); } else { switch (ATTRIBUTE (p)) { case OPEN_SYMBOL: case CLOSE_SYMBOL: case SUB_SYMBOL: case BUS_SYMBOL: case COMMA_SYMBOL: case COLON_SYMBOL: case DOTDOT_SYMBOL: case INT_DENOTATION: case IDENTIFIER: case OPERATOR: { return ((BOOL_T) (is_formal_bounds (SUB (p)) && is_formal_bounds (NEXT (p)))); } default: { return (A68_FALSE); } } } } /** @brief Insert a node with attribute "a" after "p". @param p Node in syntax tree. @param a Attribute. **/ static void pad_node (NODE_T * p, int 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 = new_node (); *z = *p; if (GINFO (p) != NO_GINFO) { GINFO (z) = 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; } /** @brief Diagnose extensions. @param p Node in syntax tree. **/ static void a68_extension (NODE_T * p) { if (OPTION_PORTCHECK (&program)) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_EXTENSION); } else { diagnostic_node (A68_WARNING, p, WARNING_EXTENSION); } } /** @brief Diagnose for clauses not yielding a value. @param p Node in syntax tree. **/ static void empty_clause (NODE_T * p) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_CLAUSE_WITHOUT_VALUE); } #if ! defined HAVE_PARALLEL_CLAUSE /** @brief Diagnose for parallel clause. @param p Node in syntax tree. **/ static void par_clause (NODE_T * p) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_NO_PARALLEL_CLAUSE); } #endif /** @brief Diagnose for missing symbol. @param p Node in syntax tree. **/ static void strange_tokens (NODE_T * p) { NODE_T *q = ((p != NO_NODE && NEXT (p) != NO_NODE) ? NEXT (p) : p); diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_STRANGE_TOKENS); } /** @brief Diagnose for strange separator. @param p Node in syntax tree. **/ static void strange_separator (NODE_T * p) { NODE_T *q = ((p != NO_NODE && NEXT (p) != NO_NODE) ? NEXT (p) : p); diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_STRANGE_SEPARATOR); } /* 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. */ /** @brief Skip anything until a comma, semicolon or EXIT is found. @param p Node in syntax tree. @return Node from where to proceed. **/ 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); } /** @brief Attribute of entry in symbol table. @param table Current symbol table. @param name Token name. @return Attribute of entry in symbol table, or 0 if not found. **/ static int find_tag_definition (TABLE_T * table, char *name) { if (table != NO_TABLE) { int ret = 0; TAG_T *s; BOOL_T found; found = A68_FALSE; for (s = INDICANTS (table); s != NO_TAG && !found; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { ret += INDICANT; found = A68_TRUE; } } found = A68_FALSE; for (s = OPERATORS (table); s != NO_TAG && !found; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { ret += OPERATOR; found = A68_TRUE; } } if (ret == 0) { return (find_tag_definition (PREVIOUS (table), name)); } else { return (ret); } } else { return (0); } } /** @brief Fill in whether bold tag is operator or indicant. @param p Node in syntax tree. **/ static void elaborate_bold_tags (NODE_T * p) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, BOLD_TAG)) { switch (find_tag_definition (TABLE (q), NSYMBOL (q))) { case 0: { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_UNDECLARED_TAG); break; } case INDICANT: { ATTRIBUTE (q) = INDICANT; break; } case OPERATOR: { ATTRIBUTE (q) = OPERATOR; break; } } } } } /** @brief Skip declarer, or argument pack and declarer. @param p Node in syntax tree. @return Node before token that is not part of pack or declarer . **/ static NODE_T *skip_pack_declarer (NODE_T * p) { /* Skip () REF [] REF FLEX [] [] .. */ while (p != NO_NODE && (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 && (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); } } /** @brief Search MODE A = .., B = .. and store indicants. @param p Node in syntax tree. **/ static void extract_indicants (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (IS (q, MODE_SYMBOL)) { BOOL_T siga = A68_TRUE; do { FORWARD (q); detect_redefined_keyword (q, MODE_DECLARATION); if (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! */ ASSERT (add_tag (TABLE (p), INDICANT, q, NO_MOID, STOP) != NO_TAG); ASSERT (add_mode (&TOP_MOID (&program), INDICANT, 0, q, NO_MOID, NO_PACK) != NO_MOID); ATTRIBUTE (q) = DEFINING_INDICANT; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; q = skip_pack_declarer (NEXT (q)); FORWARD (q); } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } #define GET_PRIORITY(q, k)\ RESET_ERRNO;\ (k) = atoi (NSYMBOL (q));\ if (errno != 0) {\ diagnostic_node (A68_SYNTAX_ERROR, (q), ERROR_INVALID_PRIORITY);\ (k) = MAX_PRIORITY;\ } else if ((k) < 1 || (k) > MAX_PRIORITY) {\ diagnostic_node (A68_SYNTAX_ERROR, (q), ERROR_INVALID_PRIORITY);\ (k) = MAX_PRIORITY;\ } /** @brief Search PRIO X = .., Y = .. and store priorities. @param p Node in syntax tree. **/ static void extract_priorities (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (IS (q, PRIO_SYMBOL)) { BOOL_T siga = A68_TRUE; do { FORWARD (q); detect_redefined_keyword (q, PRIORITY_DECLARATION); /* An operator tag like ++ or && gives strange errors so we catch it here */ if (whether (q, OPERATOR, OPERATOR, STOP)) { int k; NODE_T *y = q; diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_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); GET_PRIORITY (q, k); ATTRIBUTE (q) = PRIORITY; ASSERT (add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) != NO_TAG); FORWARD (q); } else if (whether (q, OPERATOR, EQUALS_SYMBOL, INT_DENOTATION, STOP) || whether (q, EQUALS_SYMBOL, EQUALS_SYMBOL, INT_DENOTATION, STOP)) { int k; NODE_T *y = q; ATTRIBUTE (q) = DEFINING_OPERATOR; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; FORWARD (q); GET_PRIORITY (q, k); ATTRIBUTE (q) = PRIORITY; ASSERT (add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) != NO_TAG); FORWARD (q); } else if (whether (q, BOLD_TAG, IDENTIFIER, STOP)) { siga = A68_FALSE; } else if (whether (q, BOLD_TAG, EQUALS_SYMBOL, INT_DENOTATION, STOP)) { int k; NODE_T *y = q; ATTRIBUTE (q) = DEFINING_OPERATOR; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; FORWARD (q); GET_PRIORITY (q, k); ATTRIBUTE (q) = PRIORITY; ASSERT (add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) != NO_TAG); FORWARD (q); } else if (whether (q, BOLD_TAG, INT_DENOTATION, STOP) || whether (q, OPERATOR, INT_DENOTATION, STOP) || 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] == '=') { int k; NODE_T *y = q; char *sym = (char *) get_temp_heap_space ((size_t) (len + 1)); bufcpy (sym, NSYMBOL (q), len + 1); sym[len - 1] = NULL_CHAR; NSYMBOL (q) = TEXT (add_token (&top_token, sym)); if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=') { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_OPERATOR_INVALID_END); } ATTRIBUTE (q) = DEFINING_OPERATOR; insert_alt_equals (q); q = NEXT_NEXT (q); GET_PRIORITY (q, k); ATTRIBUTE (q) = PRIORITY; ASSERT (add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) != NO_TAG); FORWARD (q); } else { siga = A68_FALSE; } } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } /** @brief Search OP [( .. ) ..] X = .., Y = .. and store operators. @param p Node in syntax tree. **/ static void extract_operators (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (ISNT (q, OP_SYMBOL)) { FORWARD (q); } else { BOOL_T siga = A68_TRUE; /* Skip operator plan */ if (NEXT (q) != NO_NODE && IS (NEXT (q), OPEN_SYMBOL)) { q = skip_pack_declarer (NEXT (q)); } /* 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 (whether (q, OPERATOR, OPERATOR, STOP)) { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_INVALID_OPERATOR_TAG); ATTRIBUTE (q) = DEFINING_OPERATOR; ASSERT (add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP) != NO_TAG); NEXT (q) = NEXT_NEXT (q); /* Remove one superfluous operator, and hope it was only one */ PREVIOUS (NEXT (q)) = q; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else if (whether (q, OPERATOR, EQUALS_SYMBOL, STOP) || whether (q, EQUALS_SYMBOL, EQUALS_SYMBOL, STOP)) { ATTRIBUTE (q) = DEFINING_OPERATOR; ASSERT (add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP) != NO_TAG); FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else if (whether (q, BOLD_TAG, IDENTIFIER, STOP)) { siga = A68_FALSE; } else if (whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP)) { ATTRIBUTE (q) = DEFINING_OPERATOR; ASSERT (add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP) != NO_TAG); FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else if (q != NO_NODE && (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 *) get_temp_heap_space ((size_t) (len + 1)); bufcpy (sym, NSYMBOL (q), len + 1); sym[len - 1] = NULL_CHAR; NSYMBOL (q) = TEXT (add_token (&top_token, sym)); if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=') { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_OPERATOR_INVALID_END); } ATTRIBUTE (q) = DEFINING_OPERATOR; insert_alt_equals (q); ASSERT (add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP) != NO_TAG); FORWARD (q); q = skip_unit (q); } else { siga = A68_FALSE; } } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } } } } /** @brief Search and store labels. @param p Node in syntax tree. @param expect Information the parser may have on what is expected. **/ static void extract_labels (NODE_T * p, int expect) { NODE_T *q; /* Only handle candidate phrases as not to search indexers! */ if (expect == SERIAL_CLAUSE || expect == ENQUIRY_CLAUSE || expect == SOME_CLAUSE) { for (q = p; q != NO_NODE; FORWARD (q)) { if (whether (q, IDENTIFIER, COLON_SYMBOL, STOP)) { TAG_T *z = add_tag (TABLE (p), LABEL, q, NO_MOID, LOCAL_LABEL); ATTRIBUTE (q) = DEFINING_IDENTIFIER; UNIT (z) = NO_NODE; } } } } /** @brief Search MOID x = .., y = .. and store identifiers. @param p Node in syntax tree. **/ static void extract_identities (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (whether (q, DECLARER, IDENTIFIER, EQUALS_SYMBOL, STOP)) { BOOL_T siga = A68_TRUE; do { if (whether ((FORWARD (q)), IDENTIFIER, EQUALS_SYMBOL, STOP)) { ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; FORWARD (q); ATTRIBUTE (q) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else if (whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP)) { /* Handle common error in ALGOL 68 programs */ diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_MIXED_DECLARATION); ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } /** @brief Search MOID x [:= ..], y [:= ..] and store identifiers. @param p Node in syntax tree. **/ static void extract_variables (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (whether (q, DECLARER, IDENTIFIER, STOP)) { BOOL_T siga = A68_TRUE; do { FORWARD (q); if (whether (q, IDENTIFIER, STOP)) { if (whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP)) { /* Handle common error in ALGOL 68 programs */ diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_MIXED_DECLARATION); ATTRIBUTE (NEXT (q)) = ASSIGN_SYMBOL; } ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; q = skip_unit (q); } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } /** @brief Search PROC x = .., y = .. and stores identifiers. @param p Node in syntax tree. **/ static void extract_proc_identities (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (whether (q, PROC_SYMBOL, IDENTIFIER, EQUALS_SYMBOL, STOP)) { BOOL_T siga = A68_TRUE; do { FORWARD (q); if (whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP)) { TAG_T *t = add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER); IN_PROC (t) = A68_TRUE; ATTRIBUTE (q) = DEFINING_IDENTIFIER; ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else if (whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP)) { /* Handle common error in ALGOL 68 programs */ diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_MIXED_DECLARATION); ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL; q = skip_unit (q); } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } /** @brief Search PROC x [:= ..], y [:= ..]; store identifiers. @param p Node in syntax tree. **/ static void extract_proc_variables (NODE_T * p) { NODE_T *q = p; while (q != NO_NODE) { if (whether (q, PROC_SYMBOL, IDENTIFIER, STOP)) { BOOL_T siga = A68_TRUE; do { FORWARD (q); if (whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP)) { ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; q = skip_unit (FORWARD (q)); } else if (whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP)) { /* Handle common error in ALGOL 68 programs */ diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_SYNTAX_MIXED_DECLARATION); ASSERT (add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) != NO_TAG); ATTRIBUTE (q) = DEFINING_IDENTIFIER; ATTRIBUTE (FORWARD (q)) = ASSIGN_SYMBOL; q = skip_unit (q); } else { siga = A68_FALSE; } } while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL)); } else { FORWARD (q); } } } /** @brief Schedule gathering of definitions in a phrase. @param p Node in syntax tree. **/ static void extract_declarations (NODE_T * p) { NODE_T *q; /* 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 (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 (q = p; q != NO_NODE; FORWARD (q)) { if (whether (q, LOC_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } if (whether (q, HEAP_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } if (whether (q, NEW_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } if (whether (q, LOC_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } if (whether (q, HEAP_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } if (whether (q, NEW_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP)) { make_sub (q, q, QUALIFIER); } } /* Give priorities to operators */ for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, OPERATOR)) { if (find_tag_global (TABLE (q), OP_SYMBOL, NSYMBOL (q))) { TAG_T *s = find_tag_global (TABLE (q), PRIO_SYMBOL, NSYMBOL (q)); if (s != NO_TAG) { PRIO (INFO (q)) = PRIO (s); } else { PRIO (INFO (q)) = 0; } } else { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_UNDECLARED_TAG); PRIO (INFO (q)) = 1; } } } } /** @brief If match then reduce a sentence, the core BU parser routine. @param p Token where to start matching. @param a If not NO_NOTE, procedure to execute upon match. @param z If not NO_TICK, to be set to TRUE upon match. **/ static void reduce (NODE_T * p, void (*a) (NODE_T *), BOOL_T * z, ...) { va_list list; int result, arg; NODE_T *head = p, *tail = NO_NODE; va_start (list, z); result = va_arg (list, int); while ((arg = va_arg (list, int)) != STOP) { BOOL_T keep_matching; if (p == NO_NODE) { keep_matching = A68_FALSE; } else if (arg == WILDCARD) { /* WILDCARD matches any Algol68G non terminal, but no keyword */ keep_matching = (BOOL_T) (non_terminal_string (edit_line, ATTRIBUTE (p)) != NO_TEXT); } else { if (arg >= 0) { keep_matching = (BOOL_T) (arg == ATTRIBUTE (p)); } else { keep_matching = (BOOL_T) (arg != ATTRIBUTE (p)); } } if (keep_matching) { tail = p; FORWARD (p); } else { va_end (list); return; } } /* Print parser reductions */ if (head != NO_NODE && OPTION_REDUCTIONS (&program) && LINE_NUMBER (head) > 0) { NODE_T *q; int count = 0; reductions++; WIS (head); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\nReduction %d: %s<-", reductions, non_terminal_string (edit_line, result)) >= 0); WRITE (STDOUT_FILENO, output_line); for (q = head; q != NO_NODE && tail != NO_NODE && q != NEXT (tail); FORWARD (q), count++) { int gatt = ATTRIBUTE (q); char *str = non_terminal_string (input_line, gatt); if (count > 0) { WRITE (STDOUT_FILENO, ", "); } if (str != NO_TEXT) { WRITE (STDOUT_FILENO, str); if (gatt == IDENTIFIER || gatt == OPERATOR || gatt == DENOTATION || gatt == INDICANT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (q)) >= 0); WRITE (STDOUT_FILENO, output_line); } } else { WRITE (STDOUT_FILENO, NSYMBOL (q)); } } } /* Make reduction */ if (a != NO_NOTE) { a (head); } make_sub (head, tail, result); va_end (list); if (z != NO_TICK) { *z = A68_TRUE; } } /** @brief Graciously ignore extra semicolons. @param p Node in syntax tree. **/ 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) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, NEXT (p), WARNING_SKIPPED_SUPERFLUOUS, ATTRIBUTE (NEXT (p))); NEXT (p) = NO_NODE; } else if (IS (p, SEMI_SYMBOL) && is_semicolon_less (NEXT (p))) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_SKIPPED_SUPERFLUOUS, ATTRIBUTE (p)); if (PREVIOUS (p) != NO_NODE) { NEXT (PREVIOUS (p)) = NEXT (p); } PREVIOUS (NEXT (p)) = PREVIOUS (p); } } } /** @brief Driver for the bottom-up parser. @param p Node in syntax tree. **/ void bottom_up_parser (NODE_T * p) { if (p != NO_NODE) { if (!setjmp (bottom_up_crash_exit)) { NODE_T *q; int error_count_0 = ERROR_COUNT (&program); ignore_superfluous_semicolons (p); /* A program is "label sequence; particular program" */ extract_labels (p, SERIAL_CLAUSE/* a fake here, but ok */ ); /* Parse the program itself */ for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga = A68_TRUE; if (SUB (q) != NO_NODE) { reduce_branch (q, SOME_CLAUSE); } while (siga) { siga = A68_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)) { #if defined HAVE_PARALLEL_CLAUSE reduce (q, NO_NOTE, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); #else reduce (q, par_clause, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); #endif 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); } /* Try reducing the 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); if (SUB (p) == NO_NODE || NEXT (p) != NO_NODE) { recover_from_error (p, PARTICULAR_PROGRAM, (BOOL_T) ((ERROR_COUNT (&program) - error_count_0) > MAX_ERRORS)); } } } } /** @brief Reduce code clause. @param p Node in syntax tree. **/ static void reduce_code_clause (NODE_T * p) { BOOL_T siga = A68_TRUE; while (siga) { NODE_T *u; siga = A68_FALSE; for (u = p; u != NO_NODE; FORWARD (u)) { reduce (u, NO_NOTE, &siga, CODE_LIST, CODE_SYMBOL, ROW_CHAR_DENOTATION, STOP); reduce (u, NO_NOTE, &siga, CODE_LIST, CODE_LIST, ROW_CHAR_DENOTATION, STOP); reduce (u, NO_NOTE, &siga, CODE_LIST, CODE_LIST, COMMA_SYMBOL, ROW_CHAR_DENOTATION, STOP); reduce (u, NO_NOTE, &siga, CODE_CLAUSE, CODE_LIST, EDOC_SYMBOL, STOP); } } } /** @brief Reduce the sub-phrase that starts one level down. @param q Node in syntax tree. @param expect Information the parser may have on what is expected. **/ static void reduce_branch (NODE_T * q, int expect) { /* If this is unsuccessful then it 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 (&program), error_count_02; BOOL_T declarer_pack = A68_FALSE, no_error; switch (expect) { case STRUCTURE_PACK: case PARAMETER_PACK: case FORMAL_DECLARERS: case UNION_PACK: case SPECIFIER: { declarer_pack = A68_TRUE; } default: { declarer_pack = A68_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. */ extract_indicants (p); if (!declarer_pack) { extract_priorities (p); extract_operators (p); } error_count_02 = ERROR_COUNT (&program); elaborate_bold_tags (p); if ((ERROR_COUNT (&program) - error_count_02) > 0) { longjmp (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 (expect == CODE_CLAUSE) { reduce_code_clause (p); } else if (declarer_pack == A68_FALSE) { error_count_02 = ERROR_COUNT (&program); extract_declarations (p); if ((ERROR_COUNT (&program) - error_count_02) > 0) { longjmp (bottom_up_crash_exit, 1); } 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 (is_one_of (u, IF_SYMBOL, ELIF_SYMBOL, CASE_SYMBOL, OUSE_SYMBOL, WHILE_SYMBOL, UNTIL_SYMBOL, ELSE_BAR_SYMBOL, ACCO_SYMBOL, STOP)) { reduce_branch (u, ENQUIRY_CLAUSE); } else if (IS (u, BEGIN_SYMBOL)) { reduce_branch (u, SOME_CLAUSE); } else if (is_one_of (u, THEN_SYMBOL, ELSE_SYMBOL, OUT_SYMBOL, DO_SYMBOL, ALT_DO_SYMBOL, 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, LOOP_CLAUSE)) { reduce_branch (u, ENCLOSED_CLAUSE); } else if (is_one_of (u, FOR_SYMBOL, FROM_SYMBOL, BY_SYMBOL, TO_SYMBOL, DOWNTO_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); } } for (u = p; u != NO_NODE; FORWARD (u)) { if (SUB (u) != NO_NODE) { if (IS (u, CODE_SYMBOL)) { reduce_branch (u, CODE_CLAUSE); } } } 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); } /* Do something if parsing failed */ if (SUB (p) == NO_NODE || NEXT (p) != NO_NODE) { recover_from_error (p, expect, (BOOL_T) ((ERROR_COUNT (&program) - error_count_0) > MAX_ERRORS)); no_error = A68_FALSE; } else { no_error = A68_TRUE; } ATTRIBUTE (q) = ATTRIBUTE (p); if (no_error) { SUB (q) = SUB (p); } } } /** @brief Driver for reducing declarers. @param p Node in syntax tree. @param expect Information the parser may have on what is expected. **/ static void reduce_declarers (NODE_T * p, int expect) { NODE_T *q; BOOL_T siga; /* Reduce lengtheties */ for (q = p; q != NO_NODE; FORWARD (q)) { siga = A68_TRUE; reduce (q, NO_NOTE, NO_TICK, LONGETY, LONG_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, SHORTETY, SHORT_SYMBOL, STOP); while (siga) { siga = A68_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 (q, NO_NOTE, NO_TICK, INDICANT, PIPE_SYMBOL, STOP); reduce (q, NO_NOTE, NO_TICK, INDICANT, SOUND_SYMBOL, STOP); } /* Reduce standard stuff */ for (q = p; q != NO_NODE; FORWARD (q)) { if (whether (q, LONGETY, INDICANT, STOP)) { int a; if (SUB_NEXT (q) == NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_EXPECTED, INFO_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 { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_EXPECTED, INFO_APPROPRIATE_DECLARER); reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP); } } } else if (whether (q, SHORTETY, INDICANT, STOP)) { int a; if (SUB_NEXT (q) == NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_EXPECTED, INFO_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 { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_EXPECTED, INFO_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 (whether (q, PROC_SYMBOL, OPEN_SYMBOL, STOP)) { if (!is_formal_bounds (SUB_NEXT (q))) { reduce_branch (NEXT (q), FORMAL_DECLARERS); } } } else if (IS (q, OP_SYMBOL)) { if (whether (q, OP_SYMBOL, OPEN_SYMBOL, STOP)) { if (!is_formal_bounds (SUB_NEXT (q))) { reduce_branch (NEXT (q), FORMAL_DECLARERS); } } } } } /* Reduce row, proc or op declarers */ siga = A68_TRUE; while (siga) { siga = A68_FALSE; for (q = p; q != NO_NODE; FORWARD (q)) { /* FLEX DECL */ if (whether (q, FLEX_SYMBOL, DECLARER, STOP)) { reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, DECLARER, STOP); } /* FLEX [] DECL */ if (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 (whether (q, FLEX_SYMBOL, OPEN_SYMBOL, DECLARER, STOP) && SUB_NEXT (q) != NO_NODE) { if (!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 (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 (whether (q, OPEN_SYMBOL, DECLARER, STOP) && SUB (q) != NO_NODE) { if (whether (q, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP)) { /* Catch e.g. (INT i) () INT: */ if (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 = A68_TRUE; while (siga) { siga = A68_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 = A68_TRUE; while (siga) { siga = A68_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 = A68_TRUE; while (siga) { siga = A68_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 = A68_TRUE; while (siga) { siga = A68_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 = A68_TRUE; while (siga) { siga = A68_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 = A68_TRUE; while (siga) { siga = A68_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 (whether (q, OPEN_SYMBOL, COLON_SYMBOL, STOP) && !(expect == GENERIC_ARGUMENT || expect == BOUNDS)) { if (is_one_of (p, IN_SYMBOL, THEN_BAR_SYMBOL, STOP)) { reduce_branch (q, SPECIFIER); } } if (whether (q, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP)) { reduce_branch (q, PARAMETER_PACK); } if (whether (q, OPEN_SYMBOL, VOID_SYMBOL, COLON_SYMBOL, STOP)) { reduce_branch (q, PARAMETER_PACK); } } } } /** @brief Handle cases that need reducing from right-to-left. @param p Node in syntax tree. **/ 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 in stead of k := 1. 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); reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, CODE_CLAUSE, 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, DECLARER, COLON_SYMBOL, CODE_CLAUSE, 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); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, CODE_CLAUSE, 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); reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, CODE_CLAUSE, 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 (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, CODE_CLAUSE, STOP); } } } } /** @brief Reduce primary elements. @param p Node in syntax tree. @param expect Information the parser may have on what is expected. **/ static void reduce_primary_parts (NODE_T * p, int expect) { NODE_T *q = p; for (; q != NO_NODE; FORWARD (q)) { if (whether (q, IDENTIFIER, OF_SYMBOL, STOP)) { ATTRIBUTE (q) = FIELD_IDENTIFIER; } reduce (q, NO_NOTE, NO_TICK, ENVIRON_NAME, ENVIRON_SYMBOL, ROW_CHAR_DENOTATION, STOP); 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_T siga = A68_TRUE; while (siga) { siga = A68_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 (q = p; q != NO_NODE; FORWARD (q)) { #if defined HAVE_PARALLEL_CLAUSE reduce (q, NO_NOTE, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); #else reduce (q, par_clause, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP); #endif 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); } } /** @brief Reduce primaries completely. @param p Node in syntax tree. @param expect Information the parser may have on what is expected. **/ static void reduce_primaries (NODE_T * p, int expect) { NODE_T *q = p; while (q != NO_NODE) { BOOL_T fwd = A68_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 = A68_TRUE; while (siga) { NODE_T *x = NEXT (q); siga = A68_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 = A68_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); } } } /** @brief Enforce that ambiguous patterns are separated by commas. @param p Node in syntax tree. **/ 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)) { case INTEGRAL_PATTERN: /* These are the potentially ambiguous patterns */ case REAL_PATTERN: case COMPLEX_PATTERN: case BITS_PATTERN: { if (last_pat != NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, q, ERROR_COMMA_MUST_SEPARATE, ATTRIBUTE (last_pat), ATTRIBUTE (q)); } last_pat = q; break; } case COMMA_SYMBOL: { last_pat = NO_NODE; break; } } } } /** @brief Reduce format texts completely. @param p Node in syntax tree. @param pr Production rule. @param let Letter. **/ void reduce_c_pattern (NODE_T * p, int pr, int let) { NODE_T *q; for (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); } } /** @brief Reduce format texts completely. @param p Node in syntax tree. **/ static void reduce_format_texts (NODE_T * p) { NODE_T *q; /* Replicators */ for (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 (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, RADIX_FRAME, REPLICATOR, FORMAT_ITEM_R, STOP); } /* Insertions */ for (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 (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, INSERTION, REPLICATOR, INSERTION, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga = A68_TRUE; while (siga) { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, INSERTION, INSERTION, INSERTION, STOP); } } /* Replicated suppressible frames */ for (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 (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 (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 (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 (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 (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, STRING_PATTERN, REPLICATOR, FORMAT_A_FRAME, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, STRING_PATTERN, FORMAT_A_FRAME, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga = A68_TRUE; while (siga) { siga = A68_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 (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 (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga = A68_TRUE; while (siga) { siga = A68_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 (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 (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 (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 (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 (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 (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 (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 (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 (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, BITS_PATTERN, RADIX_FRAME, INTEGRAL_MOULD, STOP); } /* Integral patterns */ for (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 (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 (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 (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 (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 (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, PICTURE)) { BOOL_T siga = A68_TRUE; reduce (q, NO_NOTE, NO_TICK, PICTURE_LIST, PICTURE, STOP); while (siga) { siga = A68_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); } } } } /** @brief Reduce secondaries completely. @param p Node in syntax tree. **/ static void reduce_secondaries (NODE_T * p) { NODE_T *q; BOOL_T 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, GENERATOR, NEW_SYMBOL, DECLARER, STOP); reduce (q, NO_NOTE, NO_TICK, SECONDARY, GENERATOR, STOP); } siga = A68_TRUE; while (siga) { siga = A68_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); } } } /** @brief Whether "q" is an operator with priority "k". @param q Operator token. @param k Priority. @return 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); } /** @brief Reduce formulae. @param p Node in syntax tree. **/ static void reduce_formulae (NODE_T * p) { NODE_T *q = p; int priority; while (q != NO_NODE) { if (is_one_of (q, OPERATOR, SECONDARY, STOP)) { q = reduce_dyadic (q, STOP); } else { FORWARD (q); } } /* Reduce the expression */ for (priority = MAX_PRIORITY; priority >= 0; priority--) { for (q = p; q != NO_NODE; FORWARD (q)) { if (operator_with_priority (q, priority)) { BOOL_T siga = A68_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 (priority == 0 && siga) { diagnostic_node (A68_SYNTAX_ERROR, op, ERROR_NO_PRIORITY); } siga = A68_TRUE; while (siga) { NODE_T *op2 = NEXT (q); siga = A68_FALSE; if (operator_with_priority (q, priority)) { reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, SECONDARY, STOP); } if (operator_with_priority (q, priority)) { reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, MONADIC_FORMULA, STOP); } if (operator_with_priority (q, priority)) { reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, FORMULA, STOP); } if (priority == 0 && siga) { diagnostic_node (A68_SYNTAX_ERROR, op2, ERROR_NO_PRIORITY); } } } } } } /** @brief Reduce dyadic expressions. @param p Node in syntax tree. @param u Current priority. @return Token from where to continue. **/ 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_T siga; do { PRIO (INFO (q)) = 10; siga = (BOOL_T) ((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); } /** @brief Reduce tertiaries completely. @param p Node in syntax tree. **/ static void reduce_tertiaries (NODE_T * p) { NODE_T *q; BOOL_T siga; for (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); } siga = A68_TRUE; while (siga) { siga = A68_FALSE; for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, &siga, TRANSPOSE_FUNCTION, TRANSPOSE_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, DIAGONAL_FUNCTION, TERTIARY, DIAGONAL_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, DIAGONAL_FUNCTION, DIAGONAL_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, COLUMN_FUNCTION, TERTIARY, COLUMN_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, COLUMN_FUNCTION, COLUMN_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, ROW_FUNCTION, TERTIARY, ROW_SYMBOL, TERTIARY, STOP); reduce (q, NO_NOTE, &siga, ROW_FUNCTION, ROW_SYMBOL, TERTIARY, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, a68_extension, &siga, TERTIARY, TRANSPOSE_FUNCTION, STOP); reduce (q, a68_extension, &siga, TERTIARY, DIAGONAL_FUNCTION, STOP); reduce (q, a68_extension, &siga, TERTIARY, COLUMN_FUNCTION, STOP); reduce (q, a68_extension, &siga, TERTIARY, ROW_FUNCTION, STOP); } } for (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 (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); } } /** @brief Reduce units. @param p Node in syntax tree. **/ static void reduce_units (NODE_T * p) { NODE_T *q; /* Stray ~ is a SKIP */ for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, OPERATOR) && IS_LITERALLY (q, "~")) { ATTRIBUTE (q) = SKIP; } } /* Reduce units */ for (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 (q, NO_NOTE, NO_TICK, UNIT, CODE_CLAUSE, STOP); } } /** @brief Reduce_generic arguments. @param p Node in syntax tree. **/ static void reduce_generic_arguments (NODE_T * p) { NODE_T *q; BOOL_T siga; 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); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, DOTDOT_SYMBOL, UNIT, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, DOTDOT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, DOTDOT_SYMBOL, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, DOTDOT_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); } else if (IS (q, DOTDOT_SYMBOL)) { reduce (q, NO_NOTE, NO_TICK, TRIMMER, DOTDOT_SYMBOL, UNIT, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, DOTDOT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, DOTDOT_SYMBOL, AT_SYMBOL, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, TRIMMER, DOTDOT_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 (ISNT (q, UNIT) && ISNT (q, TRIMMER)) { pad_node (q, TRIMMER); } } } } q = NEXT (p); ABEND (q == NO_NODE, "erroneous parser state", NO_TEXT); reduce (q, NO_NOTE, NO_TICK, GENERIC_ARGUMENT_LIST, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, GENERIC_ARGUMENT_LIST, TRIMMER, STOP); do { siga = A68_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); } /** @brief Reduce bounds. @param p Node in syntax tree. **/ static void reduce_bounds (NODE_T * p) { NODE_T *q; BOOL_T 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, DOTDOT_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); reduce (q, NO_NOTE, NO_TICK, ALT_FORMAL_BOUNDS_LIST, DOTDOT_SYMBOL, STOP); do { siga = A68_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, ALT_FORMAL_BOUNDS_LIST, FORMAL_BOUNDS_LIST, DOTDOT_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); } /** @brief Reduce argument packs. @param p Node in syntax tree. **/ static void reduce_arguments (NODE_T * p) { if (NEXT (p) != NO_NODE) { NODE_T *q = NEXT (p); BOOL_T siga; reduce (q, NO_NOTE, NO_TICK, ARGUMENT_LIST, UNIT, STOP); do { siga = A68_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); } } /** @brief Reduce declarations. @param p Node in syntax tree. **/ static void reduce_basic_declarations (NODE_T * p) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, ENVIRON_NAME, ENVIRON_SYMBOL, ROW_CHAR_DENOTATION, 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); /* 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); /* Errors. WILDCARD catches TERTIARY which catches IDENTIFIER */ reduce (q, strange_tokens, NO_TICK, PROCEDURE_DECLARATION, PROC_SYMBOL, WILDCARD, ROUTINE_TEXT, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga; do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, ENVIRON_NAME, ENVIRON_NAME, COMMA_SYMBOL, ROW_CHAR_DENOTATION, STOP); 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); /* Errors. WILDCARD catches TERTIARY which catches IDENTIFIER */ reduce (q, strange_tokens, &siga, PROCEDURE_DECLARATION, PROCEDURE_DECLARATION, COMMA_SYMBOL, WILDCARD, ROUTINE_TEXT, STOP); } while (siga); } } /** @brief Reduce declaration lists. @param p Node in syntax tree. **/ static void reduce_declaration_lists (NODE_T * p) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { 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 (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga; do { siga = A68_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 (!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 (q = p; q != NO_NODE; FORWARD (q)) { reduce (q, NO_NOTE, NO_TICK, OPERATOR_DECLARATION, OPERATOR_PLAN, DEFINING_OPERATOR, EQUALS_SYMBOL, UNIT, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga; do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, OPERATOR_DECLARATION, OPERATOR_DECLARATION, COMMA_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, UNIT, STOP); } while (siga); } for (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); reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, ENVIRON_NAME, STOP); } for (q = p; q != NO_NODE; FORWARD (q)) { BOOL_T siga; do { siga = A68_FALSE; reduce (q, NO_NOTE, &siga, DECLARATION_LIST, DECLARATION_LIST, COMMA_SYMBOL, DECLARATION_LIST, STOP); } while (siga); } } /** @brief Reduce serial clauses. @param p Node in syntax tree. **/ static void reduce_serial_clauses (NODE_T * p) { if (NEXT (p) != NO_NODE) { NODE_T *q = NEXT (p), *u; BOOL_T siga, label_seen; /* Check wrong exits */ for (u = q; u != NO_NODE; FORWARD (u)) { if (IS (u, EXIT_SYMBOL)) { if (NEXT (u) == NO_NODE || ISNT (NEXT (u), LABELED_UNIT)) { diagnostic_node (A68_SYNTAX_ERROR, u, ERROR_LABELED_UNIT_MUST_FOLLOW); } } } /* Check wrong jumps and declarations */ for (u = q, label_seen = A68_FALSE; u != NO_NODE; FORWARD (u)) { if (IS (u, LABELED_UNIT)) { label_seen = A68_TRUE; } else if (IS (u, DECLARATION_LIST)) { if (label_seen) { diagnostic_node (A68_SYNTAX_ERROR, u, ERROR_LABEL_BEFORE_DECLARATION); } } } /* 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 = A68_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); } } /** @brief Reduce enquiry clauses. @param p Node in syntax tree. **/ static void reduce_enquiry_clauses (NODE_T * p) { if (NEXT (p) != NO_NODE) { NODE_T *q = NEXT (p); BOOL_T siga; reduce (q, NO_NOTE, NO_TICK, ENQUIRY_CLAUSE, UNIT, STOP); reduce (q, NO_NOTE, NO_TICK, INITIALISER_SERIES, DECLARATION_LIST, STOP); do { siga = A68_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); } } /** @brief Reduce collateral clauses. @param p Node in syntax tree. **/ static void reduce_collateral_clauses (NODE_T * p) { if (NEXT (p) != NO_NODE) { NODE_T *q = NEXT (p); if (IS (q, UNIT)) { BOOL_T siga; reduce (q, NO_NOTE, NO_TICK, UNIT_LIST, UNIT, STOP); do { siga = A68_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_T siga; reduce (q, NO_NOTE, NO_TICK, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP); do { siga = A68_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); } } } /** @brief Reduces enclosed clauses. @param q Node in syntax tree. @param expect Information the parser may have on what is expected. **/ static void reduce_enclosed_clauses (NODE_T * q, int 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 (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 (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, 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, DOWNTO_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, TO_PART, DOWNTO_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, UNTIL_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, UNTIL_PART, UNTIL_SYMBOL, ENQUIRY_CLAUSE, STOP); reduce (p, empty_clause, NO_TICK, UNTIL_PART, UNTIL_SYMBOL, INITIALISER_SERIES, STOP); } else if (IS (p, DO_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, DO_PART, DO_SYMBOL, SERIAL_CLAUSE, UNTIL_PART, OD_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, DO_PART, DO_SYMBOL, SERIAL_CLAUSE, OD_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, DO_PART, DO_SYMBOL, UNTIL_PART, OD_SYMBOL, STOP); } else if (IS (p, ALT_DO_SYMBOL)) { reduce (p, NO_NOTE, NO_TICK, ALT_DO_PART, ALT_DO_SYMBOL, SERIAL_CLAUSE, UNTIL_PART, OD_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, ALT_DO_PART, ALT_DO_SYMBOL, SERIAL_CLAUSE, OD_SYMBOL, STOP); reduce (p, NO_NOTE, NO_TICK, ALT_DO_PART, ALT_DO_SYMBOL, UNTIL_PART, 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); } } } /** @brief Substitute reduction when a phrase could not be parsed. @param p Node in syntax tree. @param expect Information the parser may have on what is expected. @param suppress Suppresses a diagnostic_node message (nested c.q. related diagnostics). **/ static void recover_from_error (NODE_T * p, int expect, BOOL_T 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; char *seq = phrase_to_text (p, &w); if (strlen (seq) == 0) { if (ERROR_COUNT (&program) == 0) { diagnostic_node (A68_SYNTAX_ERROR, w, ERROR_SYNTAX_EXPECTED, expect); } } else { diagnostic_node (A68_SYNTAX_ERROR, w, ERROR_INVALID_SEQUENCE, seq, expect); } if (ERROR_COUNT (&program) >= MAX_ERRORS) { longjmp (bottom_up_crash_exit, 1); } } /* Try to prevent spurious diagnostics by guessing what was expected */ while (NEXT (q) != NO_NODE) { FORWARD (q); } if (is_one_of (p, BEGIN_SYMBOL, OPEN_SYMBOL, STOP)) { if (expect == ARGUMENT || expect == COLLATERAL_CLAUSE || expect == PARAMETER_PACK || expect == STRUCTURE_PACK || expect == UNION_PACK) { make_sub (p, q, expect); } else if (expect == ENQUIRY_CLAUSE) { make_sub (p, q, OPEN_PART); } else if (expect == FORMAL_DECLARERS) { make_sub (p, q, FORMAL_DECLARERS); } else { make_sub (p, q, CLOSED_CLAUSE); } } else if (IS (p, FORMAT_DELIMITER_SYMBOL) && expect == FORMAT_TEXT) { make_sub (p, q, FORMAT_TEXT); } else if (IS (p, CODE_SYMBOL)) { make_sub (p, q, CODE_CLAUSE); } else if (is_one_of (p, THEN_BAR_SYMBOL, CHOICE, STOP)) { make_sub (p, q, CHOICE); } else if (is_one_of (p, IF_SYMBOL, IF_PART, STOP)) { make_sub (p, q, IF_PART); } else if (is_one_of (p, THEN_SYMBOL, THEN_PART, STOP)) { make_sub (p, q, THEN_PART); } else if (is_one_of (p, ELSE_SYMBOL, ELSE_PART, STOP)) { make_sub (p, q, ELSE_PART); } else if (is_one_of (p, ELIF_SYMBOL, ELIF_IF_PART, STOP)) { make_sub (p, q, ELIF_IF_PART); } else if (is_one_of (p, CASE_SYMBOL, CASE_PART, STOP)) { make_sub (p, q, CASE_PART); } else if (is_one_of (p, OUT_SYMBOL, OUT_PART, STOP)) { make_sub (p, q, OUT_PART); } else if (is_one_of (p, OUSE_SYMBOL, OUSE_PART, STOP)) { make_sub (p, q, OUSE_PART); } else if (is_one_of (p, FOR_SYMBOL, FOR_PART, STOP)) { make_sub (p, q, FOR_PART); } else if (is_one_of (p, FROM_SYMBOL, FROM_PART, STOP)) { make_sub (p, q, FROM_PART); } else if (is_one_of (p, BY_SYMBOL, BY_PART, STOP)) { make_sub (p, q, BY_PART); } else if (is_one_of (p, TO_SYMBOL, DOWNTO_SYMBOL, TO_PART, STOP)) { make_sub (p, q, TO_PART); } else if (is_one_of (p, WHILE_SYMBOL, WHILE_PART, STOP)) { make_sub (p, q, WHILE_PART); } else if (is_one_of (p, UNTIL_SYMBOL, UNTIL_PART, STOP)) { make_sub (p, q, UNTIL_PART); } else if (is_one_of (p, DO_SYMBOL, DO_PART, STOP)) { make_sub (p, q, DO_PART); } else if (is_one_of (p, ALT_DO_SYMBOL, ALT_DO_PART, STOP)) { make_sub (p, q, ALT_DO_PART); } else if (non_terminal_string (edit_line, expect) != NO_TEXT) { make_sub (p, q, expect); } } /** @brief Heuristic aid in pinpointing errors. @param p Node in syntax tree. **/ static void reduce_erroneous_units (NODE_T * p) { /* Constructs are reduced to units in an attempt to limit spurious diagnostics */ NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { /* Some implementations allow selection from a tertiary, when there is no risk of ambiguity. Algol68G follows RR, so some extra attention here to guide an unsuspecting user */ if (whether (q, SELECTOR, -SECONDARY, STOP)) { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_SYNTAX_EXPECTED, SECONDARY); reduce (q, NO_NOTE, NO_TICK, UNIT, SELECTOR, WILDCARD, STOP); } /* Attention for identity relations that require tertiaries */ if (whether (q, -TERTIARY, IS_SYMBOL, TERTIARY, STOP) || whether (q, TERTIARY, IS_SYMBOL, -TERTIARY, STOP) || whether (q, -TERTIARY, IS_SYMBOL, -TERTIARY, STOP)) { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_SYNTAX_EXPECTED, TERTIARY); reduce (q, NO_NOTE, NO_TICK, UNIT, WILDCARD, IS_SYMBOL, WILDCARD, STOP); } else if (whether (q, -TERTIARY, ISNT_SYMBOL, TERTIARY, STOP) || whether (q, TERTIARY, ISNT_SYMBOL, -TERTIARY, STOP) || whether (q, -TERTIARY, ISNT_SYMBOL, -TERTIARY, STOP)) { diagnostic_node (A68_SYNTAX_ERROR, NEXT (q), ERROR_SYNTAX_EXPECTED, 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 */ /** @brief Driver for a posteriori error checking. @param p Node in syntax tree. **/ void bottom_up_error_check (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, BOOLEAN_PATTERN)) { int k = 0; count_pictures (SUB (p), &k); if (!(k == 0 || k == 2)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_FORMAT_PICTURE_NUMBER, ATTRIBUTE (p)); } } else { bottom_up_error_check (SUB (p)); } } } /* Next part rearranges the tree after the symbol tables are finished */ /** @brief Transfer IDENTIFIER to JUMP where appropriate. @param p Node in syntax tree. **/ void 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 (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 (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 (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 (is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL) { make_sub (q, q, JUMP); } } } rearrange_goto_less_jumps (SUB (p)); } } /***********************************************************/ /* VICTAL checker for formal, actual and virtual declarers */ /***********************************************************/ /** @brief Check generator. @param p Node in syntax tree. **/ static void victal_check_generator (NODE_T * p) { if (!victal_check_declarer (NEXT (p), ACTUAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual declarer"); } } /** @brief Check formal pack. @param p Node in syntax tree. @param x Expected attribute. @param z Flag. **/ static void victal_check_formal_pack (NODE_T * p, int x, BOOL_T * z) { if (p != NO_NODE) { if (IS (p, FORMAL_DECLARERS)) { victal_check_formal_pack (SUB (p), x, z); } else if (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); } } } /** @brief Check operator declaration. @param p Node in syntax tree. **/ static void victal_check_operator_dec (NODE_T * p) { if (IS (NEXT (p), FORMAL_DECLARERS)) { BOOL_T z = A68_TRUE; victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z); if (!z) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarers"); } FORWARD (p); } if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } } /** @brief Check mode declaration. @param p Node in syntax tree. **/ 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 (is_one_of (p, MODE_SYMBOL, DEFINING_INDICANT, STOP) || 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)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual declarer"); } } } } /** @brief Check variable declaration. @param p Node in syntax tree. **/ 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_one_of (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, STOP) || IS (p, COMMA_SYMBOL)) { victal_check_variable_dec (NEXT (p)); } else if (IS (p, UNIT)) { victal_checker (SUB (p)); } else if (IS (p, DECLARER)) { if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual declarer"); } victal_check_variable_dec (NEXT (p)); } } } /** @brief Check identity declaration. @param p Node in syntax tree. **/ 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 (is_one_of (p, DEFINING_IDENTIFIER, EQUALS_SYMBOL, COMMA_SYMBOL, STOP)) { victal_check_identity_dec (NEXT (p)); } else if (IS (p, UNIT)) { victal_checker (SUB (p)); } else if (IS (p, DECLARER)) { if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } victal_check_identity_dec (NEXT (p)); } } } /** @brief Check routine pack. @param p Node in syntax tree. @param x Expected attribute. @param z Flag. **/ static void victal_check_routine_pack (NODE_T * p, int x, BOOL_T * z) { if (p != NO_NODE) { if (IS (p, PARAMETER_PACK)) { victal_check_routine_pack (SUB (p), x, z); } else if (is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) { victal_check_routine_pack (NEXT (p), x, z); } else if (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); } } } /** @brief Check routine text. @param p Node in syntax tree. **/ static void victal_check_routine_text (NODE_T * p) { if (IS (p, PARAMETER_PACK)) { BOOL_T z = A68_TRUE; victal_check_routine_pack (p, FORMAL_DECLARER_MARK, &z); if (!z) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarers"); } FORWARD (p); } if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } victal_checker (NEXT (p)); } /** @brief Check structure pack. @param p Node in syntax tree. @param x Expected attribute. @param z Flag. **/ static void victal_check_structure_pack (NODE_T * p, int x, BOOL_T * z) { if (p != NO_NODE) { if (IS (p, STRUCTURE_PACK)) { victal_check_structure_pack (SUB (p), x, z); } else if (is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) { victal_check_structure_pack (NEXT (p), x, z); } else if (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); } } } /** @brief Check union pack. @param p Node in syntax tree. @param x Expected attribute. @param z Flag. **/ static void victal_check_union_pack (NODE_T * p, int x, BOOL_T * z) { if (p != NO_NODE) { if (IS (p, UNION_PACK)) { victal_check_union_pack (SUB (p), x, z); } else if (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); } } } /** @brief Check declarer. @param p Node in syntax tree. @param x Expected attribute. **/ static BOOL_T victal_check_declarer (NODE_T * p, int x) { if (p == NO_NODE) { return (A68_FALSE); } else if (IS (p, DECLARER)) { return (victal_check_declarer (SUB (p), x)); } else if (is_one_of (p, LONGETY, SHORTETY, STOP)) { return (A68_TRUE); } else if (is_one_of (p, VOID_SYMBOL, INDICANT, STANDARD, STOP)) { return (A68_TRUE); } else if (IS (p, REF_SYMBOL)) { return (victal_check_declarer (NEXT (p), VIRTUAL_DECLARER_MARK)); } else if (IS (p, FLEX_SYMBOL)) { return (victal_check_declarer (NEXT (p), x)); } else if (IS (p, BOUNDS)) { victal_checker (SUB (p)); if (x == FORMAL_DECLARER_MARK) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal bounds"); (void) victal_check_declarer (NEXT (p), x); return (A68_TRUE); } else if (x == VIRTUAL_DECLARER_MARK) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "virtual bounds"); (void) victal_check_declarer (NEXT (p), x); return (A68_TRUE); } else { return (victal_check_declarer (NEXT (p), x)); } } else if (IS (p, FORMAL_BOUNDS)) { victal_checker (SUB (p)); if (x == ACTUAL_DECLARER_MARK) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "actual bounds"); (void) victal_check_declarer (NEXT (p), x); return (A68_TRUE); } else { return (victal_check_declarer (NEXT (p), x)); } } else if (IS (p, STRUCT_SYMBOL)) { BOOL_T z = A68_TRUE; victal_check_structure_pack (NEXT (p), x, &z); return (z); } else if (IS (p, UNION_SYMBOL)) { BOOL_T z = A68_TRUE; victal_check_union_pack (NEXT (p), FORMAL_DECLARER_MARK, &z); if (!z) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer pack"); } return (A68_TRUE); } else if (IS (p, PROC_SYMBOL)) { if (IS (NEXT (p), FORMAL_DECLARERS)) { BOOL_T z = A68_TRUE; victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z); if (!z) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } FORWARD (p); } if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); } return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Check cast. @param p Node in syntax tree. **/ static void victal_check_cast (NODE_T * p) { if (!victal_check_declarer (p, FORMAL_DECLARER_MARK)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_EXPECTED, "formal declarer"); victal_checker (NEXT (p)); } } /** @brief Driver for checking VICTALITY of declarers. @param p Node in syntax tree. **/ void 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 { victal_checker (SUB (p)); } } } /****************************************************/ /* Mode collection, equivalencing and derived modes */ /****************************************************/ /*************************/ /* Mode service routines */ /*************************/ /** @brief Reset moid. @param p Node in syntax tree. **/ static void reset_moid_tree (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { MOID (p) = NO_MOID; reset_moid_tree (SUB (p)); } } /** @brief Renumber moids. @param p Moid list. @param n Index. **/ void renumber_moids (MOID_T * p, int n) { if (p != NO_MOID) { NUMBER (p) = n; renumber_moids (NEXT (p), n + 1); } } /**************************************************/ /* Routines for establishing equivalence of modes */ /* Routines for adding modes */ /**************************************************/ /* After the initial version of the mode equivalencer was made to work (1993), I found: Algol Bulletin 30.3.3 C.H.A. Koster: On infinite modes, 86-89 [1969], which essentially concurs with the algorithm on mode equivalence I wrote (and which is still here). It is basic logic anyway: prove equivalence of things assuming their equivalence. */ /** @brief Whether packs are equivalent, same sequence of equivalence modes. @param s Pack 1. @param t Pack 2. @return See brief description. **/ static BOOL_T is_packs_equivalent (PACK_T * s, PACK_T * t) { for (; s != NO_PACK && t != NO_PACK; FORWARD (s), FORWARD (t)) { if (!is_modes_equivalent (MOID (s), MOID (t))) { return (A68_FALSE); } if (TEXT (s) != TEXT (t)) { return (A68_FALSE); } } return ((BOOL_T) (s == NO_PACK && t == NO_PACK)); } /** @brief Whether packs are equivalent, must be subsets. @param s Pack 1. @param t Pack 2. @return See brief description. **/ static BOOL_T is_united_packs_equivalent (PACK_T * s, PACK_T * t) { PACK_T *p, *q; BOOL_T f; /* whether s is a subset of t ... */ for (p = s; p != NO_PACK; FORWARD (p)) { for (f = A68_FALSE, q = t; q != NO_PACK && !f; FORWARD (q)) { f = is_modes_equivalent (MOID (p), MOID (q)); } if (!f) { return (A68_FALSE); } } /* ... and whether t is a subset of s */ for (p = t; p != NO_PACK; FORWARD (p)) { for (f = A68_FALSE, q = s; q != NO_PACK && !f; FORWARD (q)) { f = is_modes_equivalent (MOID (p), MOID (q)); } if (!f) { return (A68_FALSE); } } return (A68_TRUE); } /** @brief Whether moids a and b are structurally equivalent. @param a Moid. @param b Moid. @return See brief description. **/ BOOL_T is_modes_equivalent (MOID_T * a, MOID_T * b) { if (a == NO_MOID || b == NO_MOID) { /* Modes can be NO_MOID in partial argument lists */ return (A68_FALSE); } else if (a == b) { return (A68_TRUE); } else if (a == MODE (ERROR) || b == MODE (ERROR)) { return (A68_FALSE); } else if (ATTRIBUTE (a) != ATTRIBUTE (b)) { return (A68_FALSE); } else if (DIM (a) != DIM (b)) { return (A68_FALSE); } else if (IS (a, STANDARD)) { return ((BOOL_T) (a == b)); } else if (EQUIVALENT (a) == b || EQUIVALENT (b) == a) { return (A68_TRUE); } else if (is_postulated_pair (top_postulate, a, b) || is_postulated_pair (top_postulate, b, a)) { return (A68_TRUE); } else if (IS (a, INDICANT)) { if (NODE (a) == NO_NODE || NODE (b) == NO_NODE) { return (A68_FALSE); } else { return (NODE (a) == NODE (b)); } } switch (ATTRIBUTE (a)) { case REF_SYMBOL: case ROW_SYMBOL: case FLEX_SYMBOL: { return (is_modes_equivalent (SUB (a), SUB (b))); } } if (IS (a, PROC_SYMBOL) && PACK (a) == NO_PACK && PACK (b) == NO_PACK) { return (is_modes_equivalent (SUB (a), SUB (b))); } else if (IS (a, STRUCT_SYMBOL)) { POSTULATE_T *save; BOOL_T z; save = top_postulate; make_postulate (&top_postulate, a, b); z = is_packs_equivalent (PACK (a), PACK (b)); free_postulate_list (top_postulate, save); top_postulate = save; return (z); } else if (IS (a, UNION_SYMBOL)) { return (is_united_packs_equivalent (PACK (a), PACK (b))); } else if (IS (a, PROC_SYMBOL) && PACK (a) != NO_PACK && PACK (b) != NO_PACK) { POSTULATE_T *save; BOOL_T z; save = top_postulate; make_postulate (&top_postulate, a, b); z = is_modes_equivalent (SUB (a), SUB (b)); if (z) { z = is_packs_equivalent (PACK (a), PACK (b)); } free_postulate_list (top_postulate, save); top_postulate = save; return (z); } else if (IS (a, SERIES_MODE) || IS (a, STOWED_MODE)) { return (is_packs_equivalent (PACK (a), PACK (b))); } return (A68_FALSE); } /** @brief Whether modes 1 and 2 are structurally equivalent. @param p Mode 1. @param q Mode 2. @return See brief description. **/ static BOOL_T prove_moid_equivalence (MOID_T * p, MOID_T * q) { /* Prove two modes to be equivalent under assumption that they indeed are */ POSTULATE_T *save = top_postulate; BOOL_T z = is_modes_equivalent (p, q); free_postulate_list (top_postulate, save); top_postulate = save; return (z); } /** @brief Register mode in the global mode table, if mode is unique. @param z Mode table. @param u Mode to enter. @return Mode table entry. **/ static MOID_T *register_extra_mode (MOID_T ** z, MOID_T * u) { MOID_T *head = TOP_MOID (&program); /* If we already know this mode, return the existing entry; otherwise link it in */ for (; head != NO_MOID; FORWARD (head)) { if (prove_moid_equivalence (head, u)) { return (head); } } /* Link to chain and exit */ NUMBER (u) = mode_count++; NEXT (u) = (* z); return (* z = u); } /** @brief Add mode "sub" to chain "z". @param z Chain to insert into. @param att Attribute. @param dim Dimension. @param node Node. @param sub Subordinate mode. @param pack Pack. @return New entry. **/ MOID_T *add_mode (MOID_T ** z, int att, int dim, NODE_T * node, MOID_T * sub, PACK_T * pack) { MOID_T *new_mode = new_moid (); ABEND (att == REF_SYMBOL && sub == NO_MOID, ERROR_INTERNAL_CONSISTENCY, "store REF NULL"); ABEND (att == FLEX_SYMBOL && sub == NO_MOID, ERROR_INTERNAL_CONSISTENCY, "store FLEX NULL"); ABEND (att == ROW_SYMBOL && sub == NO_MOID, ERROR_INTERNAL_CONSISTENCY, "store [] NULL"); USE (new_mode) = A68_FALSE; SIZE (new_mode) = 0; ATTRIBUTE (new_mode) = att; DIM (new_mode) = dim; NODE (new_mode) = node; HAS_ROWS (new_mode) = (BOOL_T) (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 (register_extra_mode (z, new_mode)); } /** @brief Contract a UNION. @param u United mode. **/ static void contract_union (MOID_T * u) { PACK_T *s = PACK (u); for (; 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); } } } } /** @brief Absorb UNION pack. @param u Pack. @return Absorbed pack. **/ static PACK_T *absorb_union_pack (PACK_T * u) { BOOL_T go_on; PACK_T *t, *z; do { z = NO_PACK; go_on = A68_FALSE; for (t = u; t != NO_PACK; FORWARD (t)) { if (IS (MOID (t), UNION_SYMBOL)) { PACK_T *s; go_on = A68_TRUE; for (s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) { (void) add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s)); } } else { (void) add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t)); } } u = z; } while (go_on); return (z); } /** @brief Absorb nested series modes recursively. @param p Mode. **/ static void absorb_series_pack (MOID_T ** p) { BOOL_T go_on; do { PACK_T *z = NO_PACK, *t; go_on = A68_FALSE; for (t = PACK (*p); t != NO_PACK; FORWARD (t)) { if (MOID (t) != NO_MOID && IS (MOID (t), SERIES_MODE)) { PACK_T *s; go_on = A68_TRUE; for (s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) { add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s)); } } else { add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t)); } } PACK (*p) = z; } while (go_on); } /** @brief Absorb nested series and united modes recursively. @param p Mode. **/ static void absorb_series_union_pack (MOID_T ** p) { BOOL_T go_on; do { PACK_T *z = NO_PACK, *t; go_on = A68_FALSE; for (t = PACK (*p); t != NO_PACK; FORWARD (t)) { if (MOID (t) != NO_MOID && (IS (MOID (t), SERIES_MODE) || IS (MOID (t), UNION_SYMBOL))) { PACK_T *s; go_on = A68_TRUE; for (s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) { add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s)); } } else { add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t)); } } PACK (*p) = z; } while (go_on); } /** @brief Make SERIES (u, v). @param u Mode 1. @param v Mode 2. \return SERIES (u, v) **/ static MOID_T *make_series_from_moids (MOID_T * u, MOID_T * v) { MOID_T *x = new_moid (); ATTRIBUTE (x) = SERIES_MODE; add_mode_to_pack (&(PACK (x)), u, NO_TEXT, NODE (u)); add_mode_to_pack (&(PACK (x)), v, NO_TEXT, NODE (v)); absorb_series_pack (&x); DIM (x) = count_pack_members (PACK (x)); (void) register_extra_mode (&TOP_MOID (&program), x); if (DIM (x) == 1) { return (MOID (PACK (x))); } else { return (x); } } /** @brief Absorb firmly related unions in mode. @param m United mode. @return Absorbed "m". **/ static MOID_T *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. */ int mods; do { PACK_T *u = NO_PACK, *v; mods = 0; for (v = PACK (m); v != NO_PACK; FORWARD (v)) { MOID_T *n = depref_completely (MOID (v)); if (IS (n, UNION_SYMBOL) && is_subset (n, m, SAFE_DEFLEXING)) { /* Unpack it */ PACK_T *w; for (w = PACK (n); w != NO_PACK; FORWARD (w)) { add_mode_to_pack (&u, MOID (w), NO_TEXT, NODE (w)); } mods++; } else { add_mode_to_pack (&u, MOID (v), NO_TEXT, NODE (v)); } } PACK (m) = absorb_union_pack (u); } while (mods != 0); return (m); } /** @brief Make united mode, from mode that is a SERIES (..). @param m Series mode. @return Mode table entry. **/ static MOID_T *make_united_mode (MOID_T * m) { MOID_T *u; PACK_T *v, *w; int mods; if (m == NO_MOID) { return (MODE (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 */ absorb_series_union_pack (&m); /* Copy the series into a UNION */ u = new_moid (); ATTRIBUTE (u) = UNION_SYMBOL; PACK (u) = NO_PACK; v = PACK (u); w = PACK (m); for (w = PACK (m); w != NO_PACK; FORWARD (w)) { add_mode_to_pack (&(PACK (u)), MOID (w), NO_TEXT, NODE (m)); } /* Absorb and contract the new UNION */ do { mods = 0; absorb_series_union_pack (&u); DIM (u) = count_pack_members (PACK (u)); PACK (u) = absorb_union_pack (PACK (u)); contract_union (u); } while (mods != 0); /* A UNION of one mode is that mode itself */ if (DIM (u) == 1) { return (MOID (PACK (u))); } else { return (register_extra_mode (&TOP_MOID (&program), u)); } } /** @brief Add row and its slices to chain, recursively. @param p Chain to insert into. @param dim Dimension. @param sub Mode of slice. @param n Node in syntax tree. @param derivate Whether derived, ie. not in the source. @return Pointer to entry. **/ static MOID_T *add_row (MOID_T ** p, int dim, MOID_T * sub, NODE_T * n, BOOL_T derivate) { MOID_T * q = 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); } /** @brief Add a moid to a pack, maybe with a (field) name. @param p Pack. @param m Moid to add. @param text Field name. @param node Node in syntax tree. **/ void add_mode_to_pack (PACK_T ** p, MOID_T * m, char *text, NODE_T * node) { PACK_T *z = 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; } /** @brief Add a moid to a pack, maybe with a (field) name. @param p Pack. @param m Moid to add. @param text Field name. @param node Node in syntax tree. **/ void add_mode_to_pack_end (PACK_T ** p, MOID_T * m, char *text, NODE_T * node) { PACK_T *z = 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; } /** @brief Absorb UNION members. @param m First MOID. **/ 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) = absorb_union_pack (PACK (m)); } } } /** @brief Contract UNIONs . @param m First MOID. **/ 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) { contract_union (m); } } } /***************************************************/ /* Routines to collect MOIDs from the program text */ /***************************************************/ /** @brief Search standard mode in standard environ. @param sizety Sizety. @param indicant Node in syntax tree. @return Moid entry in standard environ. **/ static MOID_T *search_standard_mode (int sizety, NODE_T * indicant) { MOID_T *p = TOP_MOID (&program); /* Search standard mode */ for (; p != NO_MOID; FORWARD (p)) { if (IS (p, STANDARD) && DIM (p) == sizety && NSYMBOL (NODE (p)) == NSYMBOL (indicant)) { return (p); } } /* Sanity check if (sizety == -2 || sizety == 2) { return (NO_MOID); } */ /* 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); } } /** @brief Collect mode from STRUCT field. @param p Node in syntax tree. @param u Pack to insert to. **/ 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) add_mode_to_pack (u, NO_MOID, NSYMBOL (p), p); } else if (IS (p, DECLARER)) { MOID_T *new_one = get_mode_from_declarer (p); PACK_T *t; get_mode_from_struct_field (NEXT (p), u); for (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); } } } /** @brief Collect MODE from formal pack. @param p Node in syntax tree. @param u Pack to insert to. **/ static void get_mode_from_formal_pack (NODE_T * p, PACK_T ** u) { if (p != NO_NODE) { if (IS (p, DECLARER)) { MOID_T *z; get_mode_from_formal_pack (NEXT (p), u); z = get_mode_from_declarer (p); (void) 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); } } } /** @brief Collect MODE or VOID from formal UNION pack. @param p Node in syntax tree. @param u Pack to insert to. **/ 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)) { MOID_T *z; get_mode_from_union_pack (NEXT (p), u); z = get_mode_from_declarer (p); (void) 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); } } } /** @brief Collect mode from PROC, OP pack. @param p Node in syntax tree. @param u Pack to insert to. **/ static void get_mode_from_routine_pack (NODE_T * p, PACK_T ** u) { if (p != NO_NODE) { if (IS (p, IDENTIFIER)) { (void) add_mode_to_pack (u, NO_MOID, NO_TEXT, p); } else if (IS (p, DECLARER)) { MOID_T *z = get_mode_from_declarer (p); PACK_T *t = *u; for (; t != NO_PACK && MOID (t) == NO_MOID; FORWARD (t)) { MOID (t) = z; MOID (NODE (t)) = z; } (void) 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); } } } /** @brief Collect MODE from DECLARER. @param p Node in syntax tree. @return Mode table entry. **/ 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) = MODE (VOID); return (MOID (p)); } else if (IS (p, LONGETY)) { if (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 (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 = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p)); if (y == NO_TAG) { diagnostic_node (A68_ERROR, p, ERROR_UNDECLARED_TAG_2, NSYMBOL (p)); } else { MOID (p) = add_mode (&TOP_MOID (&program), INDICANT, 0, NODE (y), NO_MOID, NO_PACK); } } return (MOID (p)); } else if (IS (p, REF_SYMBOL)) { MOID_T *new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, p, new_one, NO_PACK); return (MOID (p)); } else if (IS (p, FLEX_SYMBOL)) { MOID_T *new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&program), 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 (&program), 1 + count_formal_bounds (SUB (p)), new_one, p, A68_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 (&program), count_bounds (SUB (p)), new_one, p, A68_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) = add_mode (&TOP_MOID (&program), STRUCT_SYMBOL, 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) = add_mode (&TOP_MOID (&program), UNION_SYMBOL, 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; MOID_T *new_one; if (IS (NEXT (p), FORMAL_DECLARERS)) { get_mode_from_formal_pack (SUB_NEXT (p), &u); FORWARD (p); } new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (u), save, new_one, u); MOID (save) = MOID (p); return (MOID (p)); } else { return (NO_MOID); } } } } /** @brief Collect MODEs from a routine-text header. @param p Node in syntax tree. @return Mode table entry. **/ static MOID_T *get_mode_from_routine_text (NODE_T * p) { PACK_T *u = NO_PACK; MOID_T *n; NODE_T *q = p; if (IS (p, PARAMETER_PACK)) { get_mode_from_routine_pack (SUB (p), &u); FORWARD (p); } n = get_mode_from_declarer (p); return (add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (u), q, n, u)); } /** @brief Collect modes from operator-plan. @param p Node in syntax tree. @return Mode table entry. **/ static MOID_T *get_mode_from_operator (NODE_T * p) { PACK_T *u = NO_PACK; MOID_T *new_one; NODE_T *save = p; if (IS (NEXT (p), FORMAL_DECLARERS)) { get_mode_from_formal_pack (SUB_NEXT (p), &u); FORWARD (p); } new_one = get_mode_from_declarer (NEXT (p)); MOID (p) = add_mode (&TOP_MOID (&program), PROC_SYMBOL, count_pack_members (u), save, new_one, u); return (MOID (p)); } /** @brief Collect mode from denotation. @param p Node in syntax tree. @param sizety Size of denotation. @return Mode table entry. **/ static void get_mode_from_denotation (NODE_T * p, int sizety) { if (p != NO_NODE) { if (IS (p, ROW_CHAR_DENOTATION)) { if (strlen (NSYMBOL (p)) == 1) { MOID (p) = MODE (CHAR); } else { MOID (p) = MODE (ROW_CHAR); } } else if (IS (p, TRUE_SYMBOL) || IS (p, FALSE_SYMBOL)) { MOID (p) = MODE (BOOL); } else if (IS (p, INT_DENOTATION)) { if (sizety == 0) { MOID (p) = MODE (INT); } else if (sizety == 1) { MOID (p) = MODE (LONG_INT); } else if (sizety == 2) { MOID (p) = MODE (LONGLONG_INT); } else { MOID (p) = (sizety > 0 ? MODE (LONGLONG_INT) : MODE (INT)); } } else if (IS (p, REAL_DENOTATION)) { if (sizety == 0) { MOID (p) = MODE (REAL); } else if (sizety == 1) { MOID (p) = MODE (LONG_REAL); } else if (sizety == 2) { MOID (p) = MODE (LONGLONG_REAL); } else { MOID (p) = (sizety > 0 ? MODE (LONGLONG_REAL) : MODE (REAL)); } } else if (IS (p, BITS_DENOTATION)) { if (sizety == 0) { MOID (p) = MODE (BITS); } else if (sizety == 1) { MOID (p) = MODE (LONG_BITS); } else if (sizety == 2) { MOID (p) = MODE (LONGLONG_BITS); } else { MOID (p) = (sizety > 0 ? MODE (LONGLONG_BITS) : MODE (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) = MODE (VOID); } } } /** @brief Collect modes from the syntax tree. @param p Node in syntax tree. @param attribute **/ static void get_modes_from_tree (NODE_T * p, int attribute) { NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { if (IS (q, VOID_SYMBOL)) { MOID (q) = MODE (VOID); } else if (IS (q, DECLARER)) { if (attribute == VARIABLE_DECLARATION) { MOID_T *new_one = get_mode_from_declarer (q); MOID (q) = add_mode (&TOP_MOID (&program), 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 (is_one_of (q, LOC_SYMBOL, HEAP_SYMBOL, NEW_SYMBOL, STOP)) { if (attribute == GENERATOR) { MOID_T *new_one = get_mode_from_declarer (NEXT (q)); MOID (NEXT (q)) = new_one; MOID (q) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK); } } else { if (attribute == DENOTATION) { get_mode_from_denotation (q, 0); } } } if (attribute != DENOTATION) { for (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. @param p Node in syntax tree. **/ 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) = add_mode (&TOP_MOID (&program), REF_SYMBOL, 0, p, new_one, NO_PACK); } } } /** @brief Collect modes from proc variable declarations. @param p Node in syntax tree. **/ 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 */ /**********************************/ /** @brief Whether a mode declaration refers to self or relates to void. @param def Entry of indicant in mode table, NO_MOID if z is an applied mode. @param z Mode to check. @param yin Whether shields YIN. @param yang Whether shields YANG. @param video Whether shields VOID . @return See brief description. **/ static BOOL_T is_well_formed (MOID_T *def, MOID_T * z, BOOL_T yin, BOOL_T yang, BOOL_T video) { if (z == NO_MOID) { return (A68_FALSE); } else if (yin && yang) { return (z == MODE (VOID) ? video : A68_TRUE); } else if (z == MODE (VOID)) { return (video); } else if (IS (z, STANDARD)) { return (A68_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 == MODE (VOID)) { return (video); } else { return (A68_TRUE); } } else { if (z == def || USE (z)) { return (yin && yang); } else { BOOL_T wwf; USE (z) = A68_TRUE; wwf = is_well_formed (def, EQUIVALENT (z), yin, yang, video); USE (z) = A68_FALSE; return (wwf); } } } else if (IS (z, REF_SYMBOL)) { return (is_well_formed (def, SUB (z), A68_TRUE, yang, A68_FALSE)); } else if (IS (z, PROC_SYMBOL)) { return (PACK (z) != NO_PACK ? A68_TRUE : is_well_formed (def, SUB (z), A68_TRUE, yang, A68_TRUE)); } else if (IS (z, ROW_SYMBOL)) { return (is_well_formed (def, SUB (z), yin, yang, A68_FALSE)); } else if (IS (z, FLEX_SYMBOL)) { return (is_well_formed (def, SUB (z), yin, yang, A68_FALSE)); } else if (IS (z, STRUCT_SYMBOL)) { PACK_T *s = PACK (z); for (; s != NO_PACK; FORWARD (s)) { if (! is_well_formed (def, MOID (s), yin, A68_TRUE, A68_FALSE)) { return (A68_FALSE); } } return (A68_TRUE); } else if (IS (z, UNION_SYMBOL)) { PACK_T *s = PACK (z); for (; s != NO_PACK; FORWARD (s)) { if (! is_well_formed (def, MOID (s), yin, yang, A68_TRUE)) { return (A68_FALSE); } } return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Replace a mode by its equivalent mode (walk chain). @param q Mode to track. **/ static void resolve_eq_members (MOID_T * q) { PACK_T *p; 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 (p = PACK (q); p != NO_PACK; FORWARD (p)) { resolve_equivalent (&MOID (p)); } } /** @brief Track equivalent tags. @param z Tag to track. **/ static void resolve_eq_tags (TAG_T * z) { for (; z != NO_TAG; FORWARD (z)) { if (MOID (z) != NO_MOID) { resolve_equivalent (& MOID (z)); } } } /** @brief Bind modes in syntax tree. @param p Node 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 && is_new_lexical_level (p)) { TABLE_T *s = TABLE (SUB (p)); TAG_T *z = INDICANTS (s); for (; 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. */ /** @brief Make name pack. @param src Source pack. @param dst Destination pack with REF modes. @param p Chain to insert new modes into. **/ static void make_name_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p) { if (src != NO_PACK) { MOID_T *z; make_name_pack (NEXT (src), dst, p); z = add_mode (p, REF_SYMBOL, 0, NO_NODE, MOID (src), NO_PACK); (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src)); } } /** @brief Make flex multiple row pack. @param src Source pack. @param dst Destination pack with REF modes. @param p Chain to insert new modes into. @param dim Dimension. **/ static void make_flex_multiple_row_pack (PACK_T * src, PACK_T ** dst, MOID_T ** p, int dim) { if (src != NO_PACK) { MOID_T *z; make_flex_multiple_row_pack (NEXT (src), dst, p, dim); z = add_row (p, dim, MOID (src), NO_NODE, A68_FALSE); z = add_mode (p, FLEX_SYMBOL, 0, NO_NODE, z, NO_PACK); (void) add_mode_to_pack (dst, z, TEXT (src), NODE (src)); } } /** @brief Make name struct. @param m Structured mode. @param p Chain to insert new modes into. @return Mode table entry. **/ 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 (add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u)); } /** @brief Make name row. @param m Rowed mode. @param p Chain to insert new modes into. @return Mode table entry. **/ static MOID_T *make_name_row (MOID_T * m, MOID_T ** p) { if (SLICE (m) != NO_MOID) { return (add_mode (p, REF_SYMBOL, 0, NO_NODE, SLICE (m), NO_PACK)); } else if (SUB (m) != NO_MOID) { return (add_mode (p, REF_SYMBOL, 0, NO_NODE, SUB (m), NO_PACK)); } else { return (NO_MOID); /* weird, FLEX INT or so ... */ } } /** @brief Make multiple row pack. @param src Source pack. @param dst Destination pack with REF modes. @param p Chain to insert new modes into. @param dim Dimension. **/ 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) add_mode_to_pack (dst, add_row (p, dim, MOID (src), NO_NODE, A68_FALSE), TEXT (src), NODE (src)); } } /** @brief Make flex multiple struct. @param m Structured mode. @param p Chain to insert new modes into. @param dim Dimension. @return Mode table entry. **/ 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 (add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u)); } /** @brief Make multiple struct. @param m Structured mode. @param p Chain to insert new modes into. @param dim Dimension. @return Mode table entry. **/ 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 (add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u)); } /** @brief Whether mode has row. @param m Mode under test. @return See brief description. **/ static BOOL_T is_mode_has_row (MOID_T * m) { if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL)) { BOOL_T k = A68_FALSE; PACK_T *p = PACK (m); for (; p != NO_PACK && k == A68_FALSE; FORWARD (p)) { HAS_ROWS (MOID (p)) = is_mode_has_row (MOID (p)); k |= (HAS_ROWS (MOID (p))); } return (k); } else { return ((BOOL_T) (HAS_ROWS (m) || IS (m, ROW_SYMBOL) || IS (m, FLEX_SYMBOL))); } } /** @brief Compute derived modes. @param mod Module. **/ static void compute_derived_modes (MODULE_T *mod) { MOID_T *z; int k, 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 (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) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB_SUB (z)), NO_PACK); } else if (IS (z, REF_SYMBOL) && DEFLEXED (SUB (z)) != NO_MOID) { DEFLEXED (z) = add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), DEFLEXED (SUB (z)), NO_PACK); } else if (IS (z, ROW_SYMBOL) && DEFLEXED (SUB (z)) != NO_MOID) { DEFLEXED (z) = add_mode (&TOP_MOID (mod), ROW_SYMBOL, DIM (z), NODE (z), DEFLEXED (SUB (z)), NO_PACK); } else if (IS (z, FLEX_SYMBOL) && DEFLEXED (SUB (z)) != NO_MOID) { DEFLEXED (z) = DEFLEXED (SUB (z)); } else if (IS (z, FLEX_SYMBOL)) { 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 (z, REF_SYMBOL)) { if (IS (SUB (z), STRUCT_SYMBOL)) { NAME (z) = make_name_struct (SUB (z), &TOP_MOID (mod)); } else if (IS (SUB (z), ROW_SYMBOL)) { NAME (z) = make_name_row (SUB (z), &TOP_MOID (mod)); } else if (IS (SUB (z), FLEX_SYMBOL) && SUB_SUB (z) != NO_MOID) { NAME (z) = make_name_row (SUB_SUB (z), &TOP_MOID (mod)); } } if (MULTIPLE (z) != NO_MOID) { ; } else if (IS (z, REF_SYMBOL)) { if (MULTIPLE (SUB (z)) != NO_MOID) { MULTIPLE (z) = make_name_struct (MULTIPLE (SUB (z)), &TOP_MOID (mod)); } } else if (IS (z, ROW_SYMBOL)) { 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 (z, FLEX_SYMBOL)) { TRIM (z) = SUB (z); } if (TRIM (z) == NO_MOID && IS_REF_FLEX (z)) { TRIM (z) = 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 (z, ROW_SYMBOL) && DIM (z) > 0 && SUB (z) != NO_MOID && ! DERIVATE (z)) { (void) add_row (&TOP_MOID (mod), DIM (z) + 1, SUB (z), NODE (z), A68_TRUE); } else if (IS (z, REF_SYMBOL) && 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)), A68_TRUE); MOID_T *y = 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 (z, ROW_SYMBOL) && SLICE (z) != NO_MOID) { ROWED (SLICE (z)) = z; } if (IS (z, REF_SYMBOL)) { MOID_T *y = SUB (z); if (SLICE (y) != NO_MOID && IS (SLICE (y), ROW_SYMBOL) && 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 (a68g_standenv)); resolve_eq_tags (IDENTIFIERS (a68g_standenv)); resolve_eq_tags (OPERATORS (a68g_standenv)); resolve_equivalent (&MODE (STRING)); resolve_equivalent (&MODE (COMPLEX)); resolve_equivalent (&MODE (COMPL)); resolve_equivalent (&MODE (LONG_COMPLEX)); resolve_equivalent (&MODE (LONG_COMPL)); resolve_equivalent (&MODE (LONGLONG_COMPLEX)); resolve_equivalent (&MODE (LONGLONG_COMPL)); resolve_equivalent (&MODE (SEMA)); resolve_equivalent (&MODE (PIPE)); /* 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 (z, FLEX_SYMBOL) && 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 (&program); FORWARD (z)) { MOID_T *v; for (v = NEXT (z); v != NO_MOID; FORWARD (v)) { if (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++; } } ABEND (MODE (STRING) != MODE (FLEX_ROW_CHAR), "equivalencing is broken", NO_TEXT); /* 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 (z, FLEX_SYMBOL) && ISNT (SUB (z), ROW_SYMBOL)) { diagnostic_node (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, 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_T x = A68_TRUE; for (t = NEXT (s); t != NO_PACK && x; FORWARD (t)) { if (TEXT (s) == TEXT (t)) { diagnostic_node (A68_ERROR, NODE (z), ERROR_MULTIPLE_FIELD); while (NEXT (s) != NO_PACK && TEXT (NEXT (s)) == TEXT (t)) { FORWARD (s); } x = A68_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 (count_pack_members (s) == 1) { diagnostic_node (A68_ERROR, NODE (z), ERROR_COMPONENT_NUMBER, 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 (is_firm (MOID (s), MOID (t))) { diagnostic_node (A68_ERROR, NODE (z), ERROR_COMPONENT_RELATED, z); } } } } /* Discard incestuous unions with firmly related subsets */ for (s = PACK (z); s != NO_PACK; FORWARD (s)) { MOID_T *n = depref_completely (MOID (s)); if (IS (n, UNION_SYMBOL) && is_subset (n, z, NO_DEFLEXING)) { diagnostic_node (A68_ERROR, NODE (z), ERROR_SUBSET_RELATED, z, n); } } } } /* Wrap up and exit */ /* Overwrite old equivalent modes now */ /* for (u = &TOP_MOID (mod); (*u) != NO_MOID; u = & NEXT (*u)) { while ((*u) != NO_MOID && EQUIVALENT (*u) != NO_MOID) { (*u) = NEXT (*u); } } */ free_postulate_list (top_postulate, NO_POSTULATE); top_postulate = NO_POSTULATE; } /** @brief Make list of all modes in the program. @param mod Module to list modes of. **/ void make_moid_list (MODULE_T *mod) { MOID_T *z; BOOL_T cont = A68_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 (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, INDICANT)) { NODE_T *u = NODE (z); ABEND (NEXT (u) == NO_NODE, "error in mode table", NO_TEXT); ABEND (NEXT_NEXT (u) == NO_NODE, "error in mode table", NO_TEXT); ABEND (MOID (NEXT_NEXT (u)) == NO_MOID, "error in mode table", NO_TEXT); EQUIVALENT (z) = MOID (NEXT_NEXT (u)); } } /* Checks on wrong declarations */ for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { USE (z) = A68_FALSE; } for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID) { if (!is_well_formed (z, EQUIVALENT (z), A68_FALSE, A68_FALSE, A68_TRUE)) { diagnostic_node (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z); cont = A68_FALSE; } } } for (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, A68_FALSE, A68_FALSE, A68_TRUE)) { diagnostic_node (A68_ERROR, NODE (z), ERROR_NOT_WELL_FORMED, z); } } } for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z)) { ABEND (USE (z), ERROR_INTERNAL_CONSISTENCY, NO_TEXT); } if (ERROR_COUNT (mod) != 0) { return; } compute_derived_modes (mod); init_postulates (); } /****************************************/ /* Symbol table handling, managing TAGS */ /****************************************/ /** @brief Set level for procedures. @param p Node in syntax tree. @param n Proc level number. **/ void set_proc_level (NODE_T * p, int n) { for (; p != NO_NODE; FORWARD (p)) { PROCEDURE_LEVEL (INFO (p)) = n; if (IS (p, ROUTINE_TEXT)) { set_proc_level (SUB (p), n + 1); } else { set_proc_level (SUB (p), n); } } } /** @brief Set nests for diagnostics. @param p Node in syntax tree. @param s Start of enclosing nest. **/ void set_nest (NODE_T * p, NODE_T * s) { for (; p != NO_NODE; FORWARD (p)) { NEST (p) = s; if (IS (p, PARTICULAR_PROGRAM)) { set_nest (SUB (p), p); } else if (IS (p, CLOSED_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else if (IS (p, COLLATERAL_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else if (IS (p, CONDITIONAL_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else if (IS (p, CASE_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else if (IS (p, CONFORMITY_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else if (IS (p, LOOP_CLAUSE) && LINE_NUMBER (p) != 0) { set_nest (SUB (p), p); } else { 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 *); /** @brief Find a tag, searching symbol tables towards the root. @param table Symbol table to search. @param name Name of tag. @return Type of tag, identifier or label or .... **/ int first_tag_global (TABLE_T * table, char *name) { if (table != NO_TABLE) { TAG_T *s = NO_TAG; for (s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (IDENTIFIER); } } for (s = INDICANTS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (INDICANT); } } for (s = LABELS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (LABEL); } } for (s = OPERATORS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (OP_SYMBOL); } } for (s = PRIO (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (PRIO_SYMBOL); } } return (first_tag_global (PREVIOUS (table), name)); } else { return (STOP); } } #define PORTCHECK_TAX(p, q) {\ if (q == A68_FALSE) {\ diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_TAG_NOT_PORTABLE);\ }} /** @brief Check portability of sub tree. @param p Node in syntax tree. **/ void portcheck (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { portcheck (SUB (p)); if (OPTION_PORTCHECK (&program)) { if (IS (p, INDICANT) && MOID (p) != NO_MOID) { PORTCHECK_TAX (p, PORTABLE (MOID (p))); PORTABLE (MOID (p)) = A68_TRUE; } else if (IS (p, IDENTIFIER)) { PORTCHECK_TAX (p, PORTABLE (TAX (p))); PORTABLE (TAX (p)) = A68_TRUE; } else if (IS (p, OPERATOR)) { PORTCHECK_TAX (p, PORTABLE (TAX (p))); PORTABLE (TAX (p)) = A68_TRUE; } } } } /** @brief Whether routine can be "lengthety-mapped". @param z Name of routine. @return See brief description. **/ static BOOL_T is_mappable_routine (char *z) { #define ACCEPT(u, v) {\ if (strlen (u) >= strlen (v)) {\ if (strcmp (&u[strlen (u) - strlen (v)], v) == 0) {\ return (A68_TRUE);\ }}} /* Math routines */ ACCEPT (z, "arccos"); ACCEPT (z, "arcsin"); ACCEPT (z, "arctan"); ACCEPT (z, "cbrt"); ACCEPT (z, "cos"); ACCEPT (z, "curt"); ACCEPT (z, "exp"); ACCEPT (z, "ln"); ACCEPT (z, "log"); ACCEPT (z, "pi"); ACCEPT (z, "sin"); ACCEPT (z, "sqrt"); ACCEPT (z, "tan"); /* 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 (A68_FALSE); #undef ACCEPT } /** @brief Map "short sqrt" onto "sqrt" etcetera. @param u Name of routine. @return Tag to map onto. **/ static TAG_T *bind_lengthety_identifier (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 { char *v; TAG_T *w; u = &u[strlen ("short")]; v = TEXT (add_token (&top_token, u)); w = find_tag_local (a68g_standenv, IDENTIFIER, v); if (w != NO_TAG && is_mappable_routine (v)) { return (w); } } while (CAR (u, "short")); } else if (CAR (u, "long")) { do { char *v; TAG_T *w; u = &u[strlen ("long")]; v = TEXT (add_token (&top_token, u)); w = find_tag_local (a68g_standenv, IDENTIFIER, v); if (w != NO_TAG && is_mappable_routine (v)) { return (w); } } while (CAR (u, "long")); } return (NO_TAG); #undef CAR } /** @brief Bind identifier tags to the symbol table. @param p Node in syntax tree. **/ 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 (is_one_of (p, IDENTIFIER, DEFINING_IDENTIFIER, STOP)) { int att = first_tag_global (TABLE (p), NSYMBOL (p)); TAG_T *z; if (att == STOP) { if ((z = bind_lengthety_identifier (NSYMBOL (p))) != NO_TAG) { MOID (p) = MOID (z); /* } else { diagnostic_node (A68_ERROR, p, ERROR_UNDECLARED_TAG); z = add_tag (TABLE (p), IDENTIFIER, p, MODE (ERROR), NORMAL_IDENTIFIER); MOID (p) = MODE (ERROR); */ } TAX (p) = z; } else { z = 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 { diagnostic_node (A68_ERROR, p, ERROR_UNDECLARED_TAG); z = add_tag (TABLE (p), IDENTIFIER, p, MODE (ERROR), NORMAL_IDENTIFIER); MOID (p) = MODE (ERROR); } TAX (p) = z; if (IS (p, DEFINING_IDENTIFIER)) { NODE (z) = p; } } } } } /** @brief Bind indicant tags to the symbol table. @param p Node in syntax tree. **/ 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 (is_one_of (p, INDICANT, DEFINING_INDICANT, STOP)) { TAG_T *z = 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; } } } } } /** @brief Enter specifier identifiers in the symbol table. @param p Node in syntax tree. **/ 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)); } } } /** @brief Enter specifier identifiers in the symbol table. @param p Node in syntax tree. **/ static void tax_specifier_list (NODE_T * p) { if (p != NO_NODE) { if (IS (p, OPEN_SYMBOL)) { tax_specifier_list (NEXT (p)); } else if (is_one_of (p, CLOSE_SYMBOL, VOID_SYMBOL, STOP)) { ; } else if (IS (p, IDENTIFIER)) { TAG_T *z = 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); } } } /** @brief Enter parameter identifiers in the symbol table. @param p Node in syntax tree. **/ 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)); } } } } /** @brief Enter parameter identifiers in the symbol table. @param p Node in syntax tree. **/ static void tax_parameter_list (NODE_T * p) { if (p != NO_NODE) { if (is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP)) { tax_parameter_list (NEXT (p)); } else if (IS (p, CLOSE_SYMBOL)) { ; } else if (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 (add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, PARAMETER_IDENTIFIER)) = LOC_SYMBOL; } else if (IS (p, DECLARER)) { TAG_T *s; tax_parameter_list (NEXT (p)); /* last identifier entries are identifiers with this declarer */ for (s = IDENTIFIERS (TABLE (p)); s != NO_TAG && MOID (s) == NO_MOID; FORWARD (s)) { MOID (s) = MOID (p); } tax_parameters (SUB (p)); } } } /** @brief Enter FOR identifiers in the symbol table. @param p Node in syntax tree. **/ 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) add_tag (TABLE (p), IDENTIFIER, p, MODE (INT), LOOP_IDENTIFIER); } } } } /** @brief Enter routine texts in the symbol table. @param p Node in syntax tree. **/ 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 = add_tag (TABLE (p), ANONYMOUS, p, MOID (p), ROUTINE_TEXT); TAX (p) = z; HEAP (z) = LOC_SYMBOL; USE (z) = A68_TRUE; } } } /** @brief Enter format texts in the symbol table. @param p Node in syntax tree. **/ 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 = add_tag (TABLE (p), ANONYMOUS, p, MODE (FORMAT), FORMAT_TEXT); TAX (p) = z; USE (z) = A68_TRUE; } else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE) { TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, MODE (FORMAT), FORMAT_IDENTIFIER); TAX (p) = z; USE (z) = A68_TRUE; } } } /** @brief Enter FORMAT pictures in the symbol table. @param p Node in syntax tree. **/ static void tax_pictures (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { tax_pictures (SUB (p)); if (IS (p, PICTURE)) { TAX (p) = add_tag (TABLE (p), ANONYMOUS, p, MODE (COLLITEM), FORMAT_IDENTIFIER); } } } /** @brief Enter generators in the symbol table. @param p Node in syntax tree. **/ 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 = add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (SUB (p)), GENERATOR); HEAP (z) = LOC_SYMBOL; USE (z) = A68_TRUE; TAX (p) = z; } } } } /** @brief Find a firmly related operator for operands. @param c Symbol table. @param n Name of operator. @param l Left operand mode. @param r Right operand mode. @param self Own tag of "n", as to not relate to itself. @return Pointer to entry in table. **/ static TAG_T *find_firmly_related_op (TABLE_T * c, 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 && 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 && is_firm (MOID (t), r)) { return (s); } } } } } } return (NO_TAG); } /** @brief Check for firmly related operators in this range. @param p Node in syntax tree. @param s Operator tag to start from. **/ static void test_firmly_related_ops_local (NODE_T * p, TAG_T * s) { if (s != NO_TAG) { PACK_T *u = PACK (MOID (s)); 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) { if (TAG_TABLE (t) == a68g_standenv) { diagnostic_node (A68_ERROR, p, ERROR_OPERATOR_RELATED, MOID (s), NSYMBOL (NODE (s)), MOID (t), NSYMBOL (NODE (t))); ABEND (A68_TRUE, "standard environ error", NO_TEXT); } else { diagnostic_node (A68_ERROR, p, ERROR_OPERATOR_RELATED, MOID (s), NSYMBOL (NODE (s)), MOID (t), NSYMBOL (NODE (t))); } } if (NEXT (s) != NO_TAG) { test_firmly_related_ops_local ((p == NO_NODE ? NO_NODE : NODE (NEXT (s))), NEXT (s)); } } } /** @brief Find firmly related operators in this program. @param p Node in syntax tree. **/ static void test_firmly_related_ops (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NO_NODE && 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)); } } /** @brief Driver for the processing of TAXes. @param p Node in syntax tree. **/ void 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 (a68g_standenv)); } /** @brief Whether tag has already been declared in this range. @param n Name of tag. @param a Attribute of tag. **/ static void already_declared (NODE_T * n, int a) { if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) { diagnostic_node (A68_ERROR, n, ERROR_MULTIPLE_TAG); } } /** @brief Whether tag has already been declared in this range. @param n Name of tag. @param a Attribute of tag. **/ static void already_declared_hidden (NODE_T * n, int a) { TAG_T *s; if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG) { diagnostic_node (A68_ERROR, n, ERROR_MULTIPLE_TAG); } if ((s = find_tag_global (PREVIOUS (TABLE (n)), a, NSYMBOL (n))) != NO_TAG) { if (TAG_TABLE (s) == a68g_standenv) { diagnostic_node (A68_WARNING, n, WARNING_HIDES_PRELUDE, MOID (s), NSYMBOL (n)); } else { diagnostic_node (A68_WARNING, n, WARNING_HIDES, NSYMBOL (n)); } } } /** @brief Add tag to local symbol table. @param s Table where to insert. @param a Attribute. @param n Name of tag. @param m Mode of tag. @param p Node in syntax tree. @return Entry in symbol table. **/ TAG_T *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 = 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 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:{ ABEND (A68_TRUE, ERROR_INTERNAL_CONSISTENCY, "add tag"); } } return (z); } else { return (NO_TAG); } } /** @brief Find a tag, searching symbol tables towards the root. @param table Symbol table to search. @param a Attribute of tag. @param name Name of tag. @return Entry in symbol table. **/ TAG_T *find_tag_global (TABLE_T * table, int a, 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 PRIO_SYMBOL:{ s = PRIO (table); break; } default:{ ABEND (A68_TRUE, "impossible state in find_tag_global", NO_TEXT); break; } } for (; s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (s); } } return (find_tag_global (PREVIOUS (table), a, name)); } else { return (NO_TAG); } } /** @brief Whether identifier or label global. @param table Symbol table to search. @param name Name of tag. @return Attribute of tag. **/ int is_identifier_or_label_global (TABLE_T * table, char *name) { if (table != NO_TABLE) { TAG_T *s; for (s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (IDENTIFIER); } } for (s = LABELS (table); s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (LABEL); } } return (is_identifier_or_label_global (PREVIOUS (table), name)); } else { return (0); } } /** @brief Find a tag, searching only local symbol table. @param table Symbol table to search. @param a Attribute of tag. @param name Name of tag. @return Entry in symbol table. **/ TAG_T *find_tag_local (TABLE_T * table, int a, char *name) { if (table != NO_TABLE) { TAG_T *s = NO_TAG; if (a == OP_SYMBOL) { s = OPERATORS (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 { ABEND (A68_TRUE, "impossible state in find_tag_local", NO_TEXT); } for (; s != NO_TAG; FORWARD (s)) { if (NSYMBOL (NODE (s)) == name) { return (s); } } } return (NO_TAG); } /** @brief Whether context specifies HEAP or LOC for an identifier. @param p Node in syntax tree. @return Attribute of generator. **/ static int tab_qualifier (NODE_T * p) { if (p != NO_NODE) { if (is_one_of (p, UNIT, ASSIGNATION, TERTIARY, SECONDARY, GENERATOR, STOP)) { return (tab_qualifier (SUB (p))); } else if (is_one_of (p, LOC_SYMBOL, HEAP_SYMBOL, NEW_SYMBOL, STOP)) { return (ATTRIBUTE (p) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL); } else { return (LOC_SYMBOL); } } else { return (LOC_SYMBOL); } } /** @brief Enter identity declarations in the symbol table. @param p Node in syntax tree. @param m Mode of identifiers to enter (picked from the left-most one in fi. INT i = 1, j = 2). **/ 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)); MOID (p) = *m; HEAP (entry) = LOC_SYMBOL; TAX (p) = entry; MOID (entry) = *m; if (ATTRIBUTE (*m) == REF_SYMBOL) { HEAP (entry) = tab_qualifier (NEXT_NEXT (p)); } tax_identity_dec (NEXT_NEXT (p), m); } else { tax_tags (p); } } } /** @brief Enter variable declarations in the symbol table. @param p Node in syntax tree. @param q Qualifier of generator (HEAP, LOC) picked from left-most identifier. @param m Mode of identifiers to enter (picked from the left-most one in fi. INT i, j, k). **/ static void tax_variable_dec (NODE_T * p, int *q, MOID_T ** m) { if (p != NO_NODE) { if (IS (p, VARIABLE_DECLARATION)) { tax_variable_dec (SUB (p), q, m); tax_variable_dec (NEXT (p), q, m); } else if (IS (p, DECLARER)) { tax_tags (SUB (p)); *m = MOID (p); tax_variable_dec (NEXT (p), q, m); } else if (IS (p, QUALIFIER)) { *q = ATTRIBUTE (SUB (p)); tax_variable_dec (NEXT (p), q, m); } else if (IS (p, COMMA_SYMBOL)) { tax_variable_dec (NEXT (p), q, m); } else if (IS (p, DEFINING_IDENTIFIER)) { TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p)); MOID (p) = *m; TAX (p) = entry; HEAP (entry) = *q; if (*q == LOC_SYMBOL) { TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB (*m), GENERATOR); HEAP (z) = LOC_SYMBOL; USE (z) = A68_TRUE; BODY (entry) = z; } else { BODY (entry) = NO_TAG; } MOID (entry) = *m; tax_variable_dec (NEXT (p), q, m); } else { tax_tags (p); } } } /** @brief Enter procedure variable declarations in the symbol table. @param p Node in syntax tree. @param q Qualifier of generator (HEAP, LOC) picked from left-most identifier. **/ static void tax_proc_variable_dec (NODE_T * p, int *q) { if (p != NO_NODE) { if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) { tax_proc_variable_dec (SUB (p), q); tax_proc_variable_dec (NEXT (p), q); } else if (IS (p, QUALIFIER)) { *q = ATTRIBUTE (SUB (p)); tax_proc_variable_dec (NEXT (p), q); } else if (is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP)) { tax_proc_variable_dec (NEXT (p), q); } else if (IS (p, DEFINING_IDENTIFIER)) { TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p)); TAX (p) = entry; HEAP (entry) = *q; MOID (entry) = MOID (p); if (*q == LOC_SYMBOL) { TAG_T *z = add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (p), GENERATOR); HEAP (z) = LOC_SYMBOL; USE (z) = A68_TRUE; BODY (entry) = z; } else { BODY (entry) = NO_TAG; } tax_proc_variable_dec (NEXT (p), q); } else { tax_tags (p); } } } /** @brief Enter procedure declarations in the symbol table. @param p Node in syntax tree. **/ 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 (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; CODEX (entry) |= PROC_DECLARATION_MASK; HEAP (entry) = LOC_SYMBOL; MOID (entry) = m; tax_proc_dec (NEXT (p)); } else { tax_tags (p); } } } /** @brief Check validity of operator declaration. @param p Node in syntax tree. @param u Moid for a operator-plan. **/ 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 + count_operands (pack); } else { k = count_pack_members (PACK (u)); } if (k < 1 && k > 2) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_OPERAND_NUMBER); k = 0; } if (k == 1 && a68g_strchr (NOMADS, NSYMBOL (p)[0]) != NO_TEXT) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_OPERATOR_INVALID, NOMADS); } else if (k == 2 && !find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_DYADIC_PRIORITY); } } /** @brief Enter operator declarations in the symbol table. @param p Node in syntax tree. @param m Mode of operators to enter (picked from the left-most one). **/ 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; tax_op_dec (NEXT (p), m); } else { tax_tags (p); } } } /** @brief Enter brief operator declarations in the symbol table. @param p Node in syntax tree. **/ 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 (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; tax_brief_op_dec (NEXT (p)); } else { tax_tags (p); } } } /** @brief Enter priority declarations in the symbol table. @param p Node in syntax tree. **/ 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 (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; tax_prio_dec (NEXT (p)); } else { tax_tags (p); } } } /** @brief Enter TAXes in the symbol table. @param p Node in syntax tree. **/ 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); } else if (IS (p, PROCEDURE_DECLARATION)) { tax_proc_dec (p); } else if (IS (p, PROCEDURE_VARIABLE_DECLARATION)) { tax_proc_variable_dec (p, &heap); } 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 { tax_tags (SUB (p)); } } } /** @brief Reset symbol table nest count. @param p Node in syntax tree. **/ void reset_symbol_table_nest_count (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NO_NODE && is_new_lexical_level (p)) { NEST (TABLE (SUB (p))) = symbol_table_count++; } reset_symbol_table_nest_count (SUB (p)); } } /** @brief Bind routines in symbol table to the tree. @param p Node in syntax tree. **/ void 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; } bind_routine_tags_to_tree (SUB (p)); } } /** @brief Bind formats in symbol table to tree. @param p Node in syntax tree. **/ 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)); } } /** @brief Fill outer level of symbol table. @param p Node in syntax tree. @param s Parent symbol table. **/ void 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)) { fill_symbol_table_outer (SUB (p), TABLE (SUB (p))); } else if (SUB (p) != NO_NODE && IS (p, FORMAT_TEXT)) { fill_symbol_table_outer (SUB (p), TABLE (SUB (p))); } else { fill_symbol_table_outer (SUB (p), s); } } } /** @brief Flood branch in tree with local symbol table "s". @param p Node in syntax tree. @param s Parent symbol table. **/ 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 (is_new_lexical_level (p)) { PREVIOUS (TABLE (SUB (p))) = s; } else { flood_with_symbol_table_restricted (SUB (p), s); } } } } /** @brief Final structure of symbol table after parsing. @param p Node in syntax tree. @param l Current lexical level. **/ void 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), new_symbol_table (s)); } /* specifiers are ranges */ else if (IS (q, SPECIFIED_UNIT)) { flood_with_symbol_table_restricted (SUB (q), new_symbol_table (s)); } /* level count and recursion */ if (SUB (q) != NO_NODE) { if (is_new_lexical_level (q)) { LEX_LEVEL (SUB (q)) = l + 1; PREVIOUS (TABLE (SUB (q))) = s; 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; finalise_symbol_table_setup (SUB (q), l + 2); } } } else { TABLE (SUB (q)) = s; 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))); } } } /** @brief First structure of symbol table for parsing. @param p Node in syntax tree. **/ void preliminary_symbol_table_setup (NODE_T * p) { NODE_T *q; TABLE_T *s = TABLE (p); BOOL_T not_a_for_range = A68_FALSE; /* let the tree point to the current symbol table */ for (q = p; q != NO_NODE; FORWARD (q)) { TABLE (q) = s; } /* insert new tables when required */ for (q = p; q != NO_NODE && !not_a_for_range; FORWARD (q)) { if (SUB (q) != NO_NODE) { /* BEGIN ... END, CODE ... EDOC, DEF ... FED, DO ... OD, $ ... $, { ... } are ranges */ if (is_one_of (q, BEGIN_SYMBOL, DO_SYMBOL, ALT_DO_SYMBOL, FORMAT_DELIMITER_SYMBOL, ACCO_SYMBOL, STOP)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } /* ( ... ) is a range */ else if (IS (q, OPEN_SYMBOL)) { if (whether (q, OPEN_SYMBOL, THEN_BAR_SYMBOL, STOP)) { TABLE (SUB (q)) = s; preliminary_symbol_table_setup (SUB (q)); FORWARD (q); TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); if ((FORWARD (q)) == NO_NODE) { not_a_for_range = A68_TRUE; } else { if (IS (q, THEN_BAR_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } if (IS (q, OPEN_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } } else { /* don't worry about STRUCT (...), UNION (...), PROC (...) yet */ TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } /* IF ... THEN ... ELSE ... FI are ranges */ else if (IS (q, IF_SYMBOL)) { if (whether (q, IF_SYMBOL, THEN_SYMBOL, STOP)) { TABLE (SUB (q)) = s; preliminary_symbol_table_setup (SUB (q)); FORWARD (q); TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); if ((FORWARD (q)) == NO_NODE) { not_a_for_range = A68_TRUE; } else { if (IS (q, ELSE_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } if (IS (q, IF_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } } else { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } /* CASE ... IN ... OUT ... ESAC are ranges */ else if (IS (q, CASE_SYMBOL)) { if (whether (q, CASE_SYMBOL, IN_SYMBOL, STOP)) { TABLE (SUB (q)) = s; preliminary_symbol_table_setup (SUB (q)); FORWARD (q); TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); if ((FORWARD (q)) == NO_NODE) { not_a_for_range = A68_TRUE; } else { if (IS (q, OUT_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } if (IS (q, CASE_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } } else { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); } } /* UNTIL ... OD is a range */ else if (IS (q, UNTIL_SYMBOL) && SUB (q) != NO_NODE) { TABLE (SUB (q)) = new_symbol_table (s); preliminary_symbol_table_setup (SUB (q)); /* WHILE ... DO ... OD are ranges */ } else if (IS (q, WHILE_SYMBOL)) { TABLE_T *u = new_symbol_table (s); TABLE (SUB (q)) = u; preliminary_symbol_table_setup (SUB (q)); if ((FORWARD (q)) == NO_NODE) { not_a_for_range = A68_TRUE; } else if (IS (q, ALT_DO_SYMBOL)) { TABLE (SUB (q)) = new_symbol_table (u); preliminary_symbol_table_setup (SUB (q)); } } else { TABLE (SUB (q)) = s; preliminary_symbol_table_setup (SUB (q)); } } } /* FOR identifiers will go to the DO ... OD range */ if (!not_a_for_range) { for (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 ((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); } } } } } } /** @brief Mark a mode as in use. @param m Mode to mark. **/ static void mark_mode (MOID_T * m) { if (m != NO_MOID && USE (m) == A68_FALSE) { PACK_T *p = PACK (m); USE (m) = A68_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. @param p Node in syntax tree. **/ void mark_moids (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { mark_moids (SUB (p)); if (MOID (p) != NO_MOID) { mark_mode (MOID (p)); } } } /** @brief Mark various tags as used. @param p Node in syntax tree. **/ void 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. */ mark_auxilliary (SUB (p)); } else if (IS (p, OPERATOR)) { TAG_T *z; if (TAX (p) != NO_TAG) { USE (TAX (p)) = A68_TRUE; } if ((z = find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) != NO_TAG) { USE (z) = A68_TRUE; } } else if (IS (p, INDICANT)) { TAG_T *z = find_tag_global (TABLE (p), INDICANT, NSYMBOL (p)); if (z != NO_TAG) { TAX (p) = z; USE (z) = A68_TRUE; } } else if (IS (p, IDENTIFIER)) { if (TAX (p) != NO_TAG) { USE (TAX (p)) = A68_TRUE; } } } } /** @brief Check a single tag. @param s Tag to check. **/ static void unused (TAG_T * s) { for (; s != NO_TAG; FORWARD (s)) { if (LINE_NUMBER (NODE (s)) > 0 && !USE (s)) { diagnostic_node (A68_WARNING, NODE (s), WARNING_TAG_UNUSED, NODE (s)); } } } /** @brief Driver for traversing tree and warn for unused tags. @param p Node in syntax tree. **/ void warn_for_unused_tags (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NO_NODE) { if (is_new_lexical_level (p) && ATTRIBUTE (TABLE (SUB (p))) != ENVIRON_SYMBOL) { 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)))); } } warn_for_unused_tags (SUB (p)); } } /** @brief Mark jumps and procedured jumps. @param p Node in syntax tree. **/ void 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)) = A68_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) && (find_tag_global (TABLE (u), LABEL, NSYMBOL (u)) == NO_TAG)) { (void) add_tag (TABLE (u), LABEL, u, NO_MOID, LOCAL_LABEL); diagnostic_node (A68_ERROR, u, ERROR_UNDECLARED_TAG); } else { USE (TAX (u)) = A68_TRUE; } } else { jumps_from_procs (SUB (p)); } } } /** @brief Assign offset tags. @param t Tag to start from. @param base First (base) address. @return End address. **/ static ADDR_T assign_offset_tags (TAG_T * t, ADDR_T base) { ADDR_T sum = base; for (; t != NO_TAG; FORWARD (t)) { ABEND (MOID (t) == NO_MOID, "tag has no mode", NSYMBOL (NODE (t))); SIZE (t) = moid_size (MOID (t)); if (VALUE (t) == NO_TEXT) { OFFSET (t) = sum; sum += SIZE (t); } } return (sum); } /** @brief Assign offsets table. @param c Symbol table . **/ void assign_offsets_table (TABLE_T * c) { AP_INCREMENT (c) = assign_offset_tags (IDENTIFIERS (c), 0); AP_INCREMENT (c) = assign_offset_tags (OPERATORS (c), AP_INCREMENT (c)); AP_INCREMENT (c) = assign_offset_tags (ANONYMOUS (c), AP_INCREMENT (c)); AP_INCREMENT (c) = A68_ALIGN (AP_INCREMENT (c)); } /** @brief Assign offsets. @param p Node in syntax tree. **/ void assign_offsets (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (SUB (p) != NO_NODE && is_new_lexical_level (p)) { assign_offsets_table (TABLE (SUB (p))); } assign_offsets (SUB (p)); } } /** @brief Assign offsets packs in moid list. @param q Moid to start from. **/ void assign_offsets_packs (MOID_T * q) { for (; q != NO_MOID; FORWARD (q)) { if (EQUIVALENT (q) == NO_MOID && IS (q, STRUCT_SYMBOL)) { PACK_T *p = PACK (q); ADDR_T offset = 0; for (; p != NO_PACK; FORWARD (p)) { SIZE (p) = moid_size (MOID (p)); OFFSET (p) = offset; offset += SIZE (p); } } } } /**************************************/ /* MODE checker and coercion inserter */ /**************************************/ /** @brief Give accurate error message. @param n Node in syntax tree. @param p Mode 1. @param q Mode 2. @param context Context. @param deflex Deflexing regime. @param depth Depth of recursion. @return Error text. **/ static char *mode_error_text (NODE_T * n, MOID_T * p, MOID_T * q, int context, int deflex, int depth) { #define TAIL(z) (&(z)[strlen (z)]) static char txt[BUFFER_SIZE]; if (depth == 1) { txt[0] = NULL_CHAR; } if (IS (p, SERIES_MODE)) { PACK_T *u = PACK (p); if (u == NO_PACK) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0); } else { for (; u != NO_PACK; FORWARD (u)) { if (MOID (u) != NO_MOID) { if (IS (MOID (u), SERIES_MODE)) { (void) mode_error_text (n, MOID (u), q, context, deflex, depth + 1); } else if (!is_coercible (MOID (u), q, context, deflex)) { int len = (int) strlen (txt); if (len > BUFFER_SIZE / 2) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0); } else { if (strlen (txt) > 0) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0); } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) >= 0); } } } } } if (depth == 1) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s", moid_to_string (q, MOID_ERROR_WIDTH, n)) >= 0); } } else if (IS (p, STOWED_MODE) && IS (q, FLEX_SYMBOL)) { PACK_T *u = PACK (p); if (u == NO_PACK) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0); } else { for (; u != NO_PACK; FORWARD (u)) { if (!is_coercible (MOID (u), SLICE (SUB (q)), context, deflex)) { int len = (int) strlen (txt); if (len > BUFFER_SIZE / 2) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0); } else { if (strlen (txt) > 0) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0); } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) >= 0); } } } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s", moid_to_string (SLICE (SUB (q)), MOID_ERROR_WIDTH, n)) >= 0); } } else if (IS (p, STOWED_MODE) && IS (q, ROW_SYMBOL)) { PACK_T *u = PACK (p); if (u == NO_PACK) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0); } else { for (; u != NO_PACK; FORWARD (u)) { if (!is_coercible (MOID (u), SLICE (q), context, deflex)) { int len = (int) strlen (txt); if (len > BUFFER_SIZE / 2) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0); } else { if (strlen (txt) > 0) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0); } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) >= 0); } } } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s", moid_to_string (SLICE (q), MOID_ERROR_WIDTH, n)) >= 0); } } else if (IS (p, STOWED_MODE) && (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL))) { PACK_T *u = PACK (p), *v = PACK (q); if (u == NO_PACK) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0); } else { for (; u != NO_PACK && v != NO_PACK; FORWARD (u), FORWARD (v)) { if (!is_coercible (MOID (u), MOID (v), context, deflex)) { int len = (int) strlen (txt); if (len > BUFFER_SIZE / 2) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0); } else { if (strlen (txt) > 0) { ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0); } ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s cannot be coerced to %s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n), moid_to_string (MOID (v), MOID_ERROR_WIDTH, n)) >= 0); } } } } } return (txt); #undef TAIL } /** @brief Cannot coerce error. @param p Node in syntax tree. @param from Mode 1. @param to Mode 2. @param context Context. @param deflex Deflexing regime. @param att Attribute of context. **/ static void cannot_coerce (NODE_T * p, MOID_T * from, MOID_T * to, int context, int deflex, int att) { char *txt = mode_error_text (p, from, to, context, deflex, 1); if (att == STOP) { if (strlen (txt) == 0) { diagnostic_node (A68_ERROR, p, "M cannot be coerced to M in C context", from, to, context); } else { diagnostic_node (A68_ERROR, p, "Y in C context", txt, context); } } else { if (strlen (txt) == 0) { diagnostic_node (A68_ERROR, p, "M cannot be coerced to M in C-A", from, to, context, att); } else { diagnostic_node (A68_ERROR, p, "Y in C-A", txt, context, att); } } } /** @brief Make SOID data structure. @param s Soid buffer. @param sort Sort. @param type Mode. @param attribute Attribute. **/ static void make_soid (SOID_T * s, int sort, MOID_T * type, int attribute) { ATTRIBUTE (s) = attribute; SORT (s) = sort; MOID (s) = type; CAST (s) = A68_FALSE; } /** @brief Driver for mode checker. @param p Node in syntax tree. **/ void mode_checker (NODE_T * p) { if (IS (p, PARTICULAR_PROGRAM)) { SOID_T x, y; top_soid_list = NO_SOID; make_soid (&x, STRONG, MODE (VOID), 0); mode_check_enclosed (SUB (p), &x, &y); MOID (p) = MOID (&y); } } /** @brief Driver for coercion inserions. @param p Node in syntax tree. **/ void coercion_inserter (NODE_T * p) { if (IS (p, PARTICULAR_PROGRAM)) { SOID_T q; make_soid (&q, STRONG, MODE (VOID), 0); coerce_enclosed (SUB (p), &q); } } /** @brief Whether mode is not well defined. @param p Mode. @return See brief description. **/ static BOOL_T is_mode_isnt_well (MOID_T * p) { if (p == NO_MOID) { return (A68_TRUE); } else if (!IF_MODE_IS_WELL (p)) { return (A68_TRUE); } else if (PACK (p) != NO_PACK) { PACK_T *q = PACK (p); for (; q != NO_PACK; FORWARD (q)) { if (!IF_MODE_IS_WELL (MOID (q))) { return (A68_TRUE); } } } return (A68_FALSE); } /** @brief Add SOID data to free chain. @param root Top soid list. **/ void free_soid_list (SOID_T *root) { if (root != NO_SOID) { SOID_T *q; for (q = root; NEXT (q) != NO_SOID; FORWARD (q)) { /* skip */; } NEXT (q) = top_soid_list; top_soid_list = root; } } /** @brief Add SOID data structure to soid list. @param root Top soid list. @param where Node in syntax tree. @param soid Entry to add. **/ static void add_to_soid_list (SOID_T ** root, NODE_T * where, SOID_T * soid) { if (*root != NO_SOID) { add_to_soid_list (&(NEXT (*root)), where, soid); } else { SOID_T *new_one; if (top_soid_list == NO_SOID) { new_one = (SOID_T *) get_temp_heap_space ((size_t) SIZE_AL (SOID_T)); } else { new_one = top_soid_list; FORWARD (top_soid_list); } make_soid (new_one, SORT (soid), MOID (soid), 0); NODE (new_one) = where; NEXT (new_one) = NO_SOID; *root = new_one; } } /** @brief Pack soids in moid, gather resulting moids from terminators in a clause. @param top_sl Top soid list. @param attribute Mode attribute. @return Mode table entry. **/ static MOID_T *pack_soids_in_moid (SOID_T * top_sl, int attribute) { MOID_T *x = 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 = 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) register_extra_mode (&TOP_MOID (&program), x); return (x); } /** @brief Whether "p" is compatible with "q". @param p Mode. @param q Mode. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T 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 || DEFLEX (p) == q); } else if (ISNT (p, REF_SYMBOL) && ISNT (q, REF_SYMBOL)) { return (DEFLEX (p) == DEFLEX (q)); } } else if (deflex == SAFE_DEFLEXING) { if (ISNT (p, REF_SYMBOL) && ISNT (q, REF_SYMBOL)) { return (DEFLEX (p) == DEFLEX (q)); } } return (p == q); } /** @brief Whether mode is deprefable. @param p Mode. @return See brief description. **/ BOOL_T is_deprefable (MOID_T * p) { if (IS (p, REF_SYMBOL)) { return (A68_TRUE); } else { return ((BOOL_T) (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)); } } /** @brief Depref mode once. @param p Mode. @return Single-depreffed mode. **/ static MOID_T *depref_once (MOID_T * p) { if (IS_REF_FLEX (p)) { return (SUB_SUB (p)); } else if (IS (p, REF_SYMBOL)) { return (SUB (p)); } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { return (SUB (p)); } else { return (NO_MOID); } } /** @brief Depref mode completely. @param p Mode. @return Completely depreffed mode. **/ MOID_T *depref_completely (MOID_T * p) { while (is_deprefable (p)) { p = depref_once (p); } return (p); } /** @brief Deproc_completely. @param p Mode. @return Completely deprocedured mode. **/ static MOID_T *deproc_completely (MOID_T * p) { while (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { p = depref_once (p); } return (p); } /** @brief Depref rows. @param p Mode. @param q Mode. @return Possibly depreffed mode. **/ static MOID_T *depref_rows (MOID_T * p, MOID_T * q) { if (q == MODE (ROWS)) { while (is_deprefable (p)) { p = depref_once (p); } return (p); } else { return (q); } } /** @brief Derow mode, strip FLEX and BOUNDS. @param p Mode. @return See brief description. **/ static MOID_T *derow (MOID_T * p) { if (IS (p, ROW_SYMBOL) || IS (p, FLEX_SYMBOL)) { return (derow (SUB (p))); } else { return (p); } } /** @brief Whether rows type. @param p Mode. @return See brief description. **/ static BOOL_T is_rows_type (MOID_T * p) { switch (ATTRIBUTE (p)) { case ROW_SYMBOL: case FLEX_SYMBOL: { return (A68_TRUE); } case UNION_SYMBOL: { PACK_T *t = PACK (p); BOOL_T go_on = A68_TRUE; while (t != NO_PACK && go_on) { go_on &= is_rows_type (MOID (t)); FORWARD (t); } return (go_on); } default: { return (A68_FALSE); } } } /** @brief Whether mode is PROC (REF FILE) VOID or FORMAT. @param p Mode. @return See brief description. **/ static BOOL_T is_proc_ref_file_void_or_format (MOID_T * p) { if (p == MODE (PROC_REF_FILE_VOID)) { return (A68_TRUE); } else if (p == MODE (FORMAT)) { return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Whether mode can be transput. @param p Mode. @param rw Indicates Read or Write. @return See brief description. **/ static BOOL_T is_transput_mode (MOID_T * p, char rw) { if (p == MODE (INT)) { return (A68_TRUE); } else if (p == MODE (LONG_INT)) { return (A68_TRUE); } else if (p == MODE (LONGLONG_INT)) { return (A68_TRUE); } else if (p == MODE (REAL)) { return (A68_TRUE); } else if (p == MODE (LONG_REAL)) { return (A68_TRUE); } else if (p == MODE (LONGLONG_REAL)) { return (A68_TRUE); } else if (p == MODE (BOOL)) { return (A68_TRUE); } else if (p == MODE (CHAR)) { return (A68_TRUE); } else if (p == MODE (BITS)) { return (A68_TRUE); } else if (p == MODE (LONG_BITS)) { return (A68_TRUE); } else if (p == MODE (LONGLONG_BITS)) { return (A68_TRUE); } else if (p == MODE (COMPLEX)) { return (A68_TRUE); } else if (p == MODE (LONG_COMPLEX)) { return (A68_TRUE); } else if (p == MODE (LONGLONG_COMPLEX)) { return (A68_TRUE); } else if (p == MODE (ROW_CHAR)) { return (A68_TRUE); } else if (p == MODE (STRING)) { return (A68_TRUE); } else if (p == MODE (SOUND)) { return (A68_TRUE); } else if (IS (p, UNION_SYMBOL) || IS (p, STRUCT_SYMBOL)) { PACK_T *q = PACK (p); BOOL_T k = A68_TRUE; for (; q != NO_PACK && k; FORWARD (q)) { k = (BOOL_T) (k & (is_transput_mode (MOID (q), rw) || is_proc_ref_file_void_or_format (MOID (q)))); } return (k); } else if (IS (p, FLEX_SYMBOL)) { if (SUB (p) == MODE (ROW_CHAR)) { return (A68_TRUE); } else { return ((BOOL_T) (rw == 'w' ? is_transput_mode (SUB (p), rw) : A68_FALSE)); } } else if (IS (p, ROW_SYMBOL)) { return ((BOOL_T) (is_transput_mode (SUB (p), rw) || is_proc_ref_file_void_or_format (SUB (p)))); } else { return (A68_FALSE); } } /** @brief Whether mode is printable. @param p Mode. @return See brief description. **/ static BOOL_T is_printable_mode (MOID_T * p) { if (is_proc_ref_file_void_or_format (p)) { return (A68_TRUE); } else { return (is_transput_mode (p, 'w')); } } /** @brief Whether mode is readable. @param p Mode. @return See brief description. **/ static BOOL_T is_readable_mode (MOID_T * p) { if (is_proc_ref_file_void_or_format (p)) { return (A68_TRUE); } else { return ((BOOL_T) (IS (p, REF_SYMBOL) ? is_transput_mode (SUB (p), 'r') : A68_FALSE)); } } /** @brief Whether name struct. @param p Mode. @return See brief description. **/ static BOOL_T is_name_struct (MOID_T * p) { return ((BOOL_T) (NAME (p) != NO_MOID ? IS (DEFLEX (SUB (p)), STRUCT_SYMBOL) : A68_FALSE)); } /** @brief Yield mode to unite to. @param m Mode. @param u United mode. @return See brief description. **/ MOID_T *unites_to (MOID_T * m, MOID_T * u) { /* Uniting U (m) */ MOID_T *v = NO_MOID; PACK_T *p; if (u == MODE (SIMPLIN) || u == MODE (SIMPLOUT)) { return (m); } for (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); } /** @brief Whether moid in pack. @param u Mode. @param v Pack. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T is_moid_in_pack (MOID_T * u, PACK_T * v, int deflex) { for (; v != NO_PACK; FORWARD (v)) { if (is_equal_modes (u, MOID (v), deflex)) { return (A68_TRUE); } } return (A68_FALSE); } /** @brief Whether "p" is a subset of "q". @param p Mode. @param q Mode. @param deflex Deflexing regime. @return See brief description. **/ BOOL_T is_subset (MOID_T * p, MOID_T * q, int deflex) { PACK_T *u = PACK (p); BOOL_T j = A68_TRUE; for (; u != NO_PACK && j; FORWARD (u)) { j = (BOOL_T) (j && is_moid_in_pack (MOID (u), PACK (q), deflex)); } return (j); } /** @brief Whether "p" can be united to UNION "q". @param p Mode. @param q Mode. @param deflex Deflexing regime. @return See brief description. **/ BOOL_T is_unitable (MOID_T * p, MOID_T * q, int deflex) { if (IS (q, UNION_SYMBOL)) { if (IS (p, UNION_SYMBOL)) { return (is_subset (p, q, deflex)); } else { return (is_moid_in_pack (p, PACK (q), deflex)); } } return (A68_FALSE); } /** @brief Whether all or some components of "u" can be firmly coerced to a component mode of "v".. @param u Mode. @param v Mode . @param all All coercible. @param some Some coercible. **/ static void investigate_firm_relations (PACK_T * u, PACK_T * v, BOOL_T * all, BOOL_T * some) { *all = A68_TRUE; *some = A68_FALSE; for (; v != NO_PACK; FORWARD (v)) { PACK_T *w; BOOL_T k = A68_FALSE; for (w = u; w != NO_PACK; FORWARD (w)) { k |= is_coercible (MOID (w), MOID (v), FIRM, FORCE_DEFLEXING); } *some |= k; *all &= k; } } /** @brief Whether there is a soft path from "p" to "q". @param p Mode. @param q Mode. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T is_softly_coercible (MOID_T * p, MOID_T * q, int deflex) { if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { return (is_softly_coercible (SUB (p), q, deflex)); } else { return (A68_FALSE); } } /** @brief Whether there is a weak path from "p" to "q". @param p Mode. @param q Mode. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T is_weakly_coercible (MOID_T * p, MOID_T * q, int deflex) { if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (is_deprefable (p)) { return (is_weakly_coercible (depref_once (p), q, deflex)); } else { return (A68_FALSE); } } /** @brief Whether there is a meek path from "p" to "q". @param p Mode. @param q Mode. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T is_meekly_coercible (MOID_T * p, MOID_T * q, int deflex) { if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (is_deprefable (p)) { return (is_meekly_coercible (depref_once (p), q, deflex)); } else { return (A68_FALSE); } } /** @brief Whether there is a firm path from "p" to "q". @param p Mode. @param q Mode. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T is_firmly_coercible (MOID_T * p, MOID_T * q, int deflex) { if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (q == MODE (ROWS) && is_rows_type (p)) { return (A68_TRUE); } else if (is_unitable (p, q, deflex)) { return (A68_TRUE); } else if (is_deprefable (p)) { return (is_firmly_coercible (depref_once (p), q, deflex)); } else { return (A68_FALSE); } } /** @brief Whether "p" widens to "q". @param p Mode. @param q Mode. @return See brief description. **/ static MOID_T *widens_to (MOID_T * p, MOID_T * q) { if (p == MODE (INT)) { if (q == MODE (LONG_INT) || q == MODE (LONGLONG_INT) || q == MODE (LONG_REAL) || q == MODE (LONGLONG_REAL) || q == MODE (LONG_COMPLEX) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONG_INT)); } else if (q == MODE (REAL) || q == MODE (COMPLEX)) { return (MODE (REAL)); } else { return (NO_MOID); } } else if (p == MODE (LONG_INT)) { if (q == MODE (LONGLONG_INT)) { return (MODE (LONGLONG_INT)); } else if (q == MODE (LONG_REAL) || q == MODE (LONGLONG_REAL) || q == MODE (LONG_COMPLEX) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONG_REAL)); } else { return (NO_MOID); } } else if (p == MODE (LONGLONG_INT)) { if (q == MODE (LONGLONG_REAL) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONGLONG_REAL)); } else { return (NO_MOID); } } else if (p == MODE (REAL)) { if (q == MODE (LONG_REAL) || q == MODE (LONGLONG_REAL) || q == MODE (LONG_COMPLEX) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONG_REAL)); } else if (q == MODE (COMPLEX)) { return (MODE (COMPLEX)); } else { return (NO_MOID); } } else if (p == MODE (COMPLEX)) { if (q == MODE (LONG_COMPLEX) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONG_COMPLEX)); } else { return (NO_MOID); } } else if (p == MODE (LONG_REAL)) { if (q == MODE (LONGLONG_REAL) || q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONGLONG_REAL)); } else if (q == MODE (LONG_COMPLEX)) { return (MODE (LONG_COMPLEX)); } else { return (NO_MOID); } } else if (p == MODE (LONG_COMPLEX)) { if (q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONGLONG_COMPLEX)); } else { return (NO_MOID); } } else if (p == MODE (LONGLONG_REAL)) { if (q == MODE (LONGLONG_COMPLEX)) { return (MODE (LONGLONG_COMPLEX)); } else { return (NO_MOID); } } else if (p == MODE (BITS)) { if (q == MODE (LONG_BITS) || q == MODE (LONGLONG_BITS)) { return (MODE (LONG_BITS)); } else if (q == MODE (ROW_BOOL)) { return (MODE (ROW_BOOL)); } else if (q == MODE (FLEX_ROW_BOOL)) { return (MODE (FLEX_ROW_BOOL)); } else { return (NO_MOID); } } else if (p == MODE (LONG_BITS)) { if (q == MODE (LONGLONG_BITS)) { return (MODE (LONGLONG_BITS)); } else if (q == MODE (ROW_BOOL)) { return (MODE (ROW_BOOL)); } else if (q == MODE (FLEX_ROW_BOOL)) { return (MODE (FLEX_ROW_BOOL)); } else { return (NO_MOID); } } else if (p == MODE (LONGLONG_BITS)) { if (q == MODE (ROW_BOOL)) { return (MODE (ROW_BOOL)); } else if (q == MODE (FLEX_ROW_BOOL)) { return (MODE (FLEX_ROW_BOOL)); } else { return (NO_MOID); } } else if (p == MODE (BYTES) && q == MODE (ROW_CHAR)) { return (MODE (ROW_CHAR)); } else if (p == MODE (LONG_BYTES) && q == MODE (ROW_CHAR)) { return (MODE (ROW_CHAR)); } else if (p == MODE (BYTES) && q == MODE (FLEX_ROW_CHAR)) { return (MODE (FLEX_ROW_CHAR)); } else if (p == MODE (LONG_BYTES) && q == MODE (FLEX_ROW_CHAR)) { return (MODE (FLEX_ROW_CHAR)); } else { return (NO_MOID); } } /** @brief Whether "p" widens to "q". @param p Mode. @param q Mode. @return See brief description. **/ static BOOL_T is_widenable (MOID_T * p, MOID_T * q) { MOID_T *z = widens_to (p, q); if (z != NO_MOID) { return ((BOOL_T) (z == q ? A68_TRUE : is_widenable (z, q))); } else { return (A68_FALSE); } } /** @brief Whether "p" is a REF ROW. @param p Mode. @return See brief description. **/ static BOOL_T is_ref_row (MOID_T * p) { return ((BOOL_T) (NAME (p) != NO_MOID ? IS (DEFLEX (SUB (p)), ROW_SYMBOL) : A68_FALSE)); } /** @brief Whether strong name. @param p Mode. @param q Mode. @return See brief description. **/ static BOOL_T is_strong_name (MOID_T * p, MOID_T * q) { if (p == q) { return (A68_TRUE); } else if (is_ref_row (q)) { return (is_strong_name (p, NAME (q))); } else { return (A68_FALSE); } } /** @brief Whether strong slice. @param p Mode. @param q Mode. @return See brief description. **/ static BOOL_T is_strong_slice (MOID_T * p, MOID_T * q) { if (p == q || is_widenable (p, q)) { return (A68_TRUE); } else if (SLICE (q) != NO_MOID) { return (is_strong_slice (p, SLICE (q))); } else if (IS (q, FLEX_SYMBOL)) { return (is_strong_slice (p, SUB (q))); } else if (is_ref_row (q)) { return (is_strong_name (p, q)); } else { return (A68_FALSE); } } /** @brief Whether strongly coercible. @param p Mode. @param q Mode. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T is_strongly_coercible (MOID_T * p, MOID_T * q, int deflex) { /* Keep this sequence of statements */ if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (q == MODE (VOID)) { return (A68_TRUE); } else if ((q == MODE (SIMPLIN) || q == MODE (ROW_SIMPLIN)) && is_readable_mode (p)) { return (A68_TRUE); } else if (q == MODE (ROWS) && is_rows_type (p)) { return (A68_TRUE); } else if (is_unitable (p, derow (q), deflex)) { return (A68_TRUE); } if (is_ref_row (q) && is_strong_name (p, q)) { return (A68_TRUE); } else if (SLICE (q) != NO_MOID && is_strong_slice (p, q)) { return (A68_TRUE); } else if (IS (q, FLEX_SYMBOL) && is_strong_slice (p, q)) { return (A68_TRUE); } else if (is_widenable (p, q)) { return (A68_TRUE); } else if (is_deprefable (p)) { return (is_strongly_coercible (depref_once (p), q, deflex)); } else if (q == MODE (SIMPLOUT) || q == MODE (ROW_SIMPLOUT)) { return (is_printable_mode (p)); } else { return (A68_FALSE); } } /** @brief Whether firm. @param p Mode. @param q Mode. @return See brief description. **/ BOOL_T is_firm (MOID_T * p, MOID_T * q) { return ((BOOL_T) (is_firmly_coercible (p, q, SAFE_DEFLEXING) || is_firmly_coercible (q, p, SAFE_DEFLEXING))); } /** @brief Whether coercible stowed. @param p Mode. @param q Mode. @param c Context. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T is_coercible_stowed (MOID_T * p, MOID_T * q, int c, int deflex) { if (c == STRONG) { if (q == MODE (VOID)) { return (A68_TRUE); } else if (IS (q, FLEX_SYMBOL)) { PACK_T *u = PACK (p); BOOL_T j = A68_TRUE; for (; u != NO_PACK && j; FORWARD (u)) { j &= is_coercible (MOID (u), SLICE (SUB (q)), c, deflex); } return (j); } else if (IS (q, ROW_SYMBOL)) { PACK_T *u = PACK (p); BOOL_T j = A68_TRUE; for (; u != NO_PACK && j; FORWARD (u)) { j &= is_coercible (MOID (u), SLICE (q), c, deflex); } return (j); } else if (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL)) { PACK_T *u = PACK (p), *v = PACK (q); if (DIM (p) != DIM (q)) { return (A68_FALSE); } else { BOOL_T j = A68_TRUE; while (u != NO_PACK && v != NO_PACK && j) { j &= is_coercible (MOID (u), MOID (v), c, deflex); FORWARD (u); FORWARD (v); } return (j); } } else { return (A68_FALSE); } } else { return (A68_FALSE); } } /** @brief Whether coercible series. @param p Mode. @param q Mode. @param c Context. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T is_coercible_series (MOID_T * p, MOID_T * q, int c, int deflex) { if (c != STRONG) { return (A68_FALSE); } else if (p == NO_MOID || q == NO_MOID) { return (A68_FALSE); } else if (IS (p, SERIES_MODE) && PACK (p) == NO_PACK) { return (A68_FALSE); } else if (IS (q, SERIES_MODE) && PACK (q) == NO_PACK) { return (A68_FALSE); } else if (PACK (p) == NO_PACK) { return (is_coercible (p, q, c, deflex)); } else { PACK_T *u = PACK (p); BOOL_T j = A68_TRUE; for (; u != NO_PACK && j; FORWARD (u)) { if (MOID (u) != NO_MOID) { j &= is_coercible (MOID (u), q, c, deflex); } } return (j); } } /** @brief Basic coercions. @param p Mode. @param q Mode. @param c Context. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T basic_coercions (MOID_T * p, MOID_T * q, int c, int deflex) { if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (c == NO_SORT) { return ((BOOL_T) (p == q)); } else if (c == SOFT) { return (is_softly_coercible (p, q, deflex)); } else if (c == WEAK) { return (is_weakly_coercible (p, q, deflex)); } else if (c == MEEK) { return (is_meekly_coercible (p, q, deflex)); } else if (c == FIRM) { return (is_firmly_coercible (p, q, deflex)); } else if (c == STRONG) { return (is_strongly_coercible (p, q, deflex)); } else { return (A68_FALSE); } } /** @brief Whether "p" can be coerced to "q" in a "c" context. @param p Mode. @param q Mode. @param c Context. @param deflex Deflexing regime. @return See brief description. **/ BOOL_T is_coercible (MOID_T * p, MOID_T * q, int c, int deflex) { if (is_mode_isnt_well (p) || is_mode_isnt_well (q)) { return (A68_TRUE); } else if (is_equal_modes (p, q, deflex)) { return (A68_TRUE); } else if (p == MODE (HIP)) { return (A68_TRUE); } else if (IS (p, STOWED_MODE)) { return (is_coercible_stowed (p, q, c, deflex)); } else if (IS (p, SERIES_MODE)) { return (is_coercible_series (p, q, c, deflex)); } else if (p == MODE (VACUUM) && IS (DEFLEX (q), ROW_SYMBOL)) { return (A68_TRUE); } else { return (basic_coercions (p, q, c, deflex)); } } /** @brief Whether coercible in context. @param p Soid. @param q Soid. @param deflex Deflexing regime. @return See brief description. **/ static BOOL_T is_coercible_in_context (SOID_T * p, SOID_T * q, int deflex) { if (SORT (p) != SORT (q)) { return (A68_FALSE); } else if (MOID (p) == MOID (q)) { return (A68_TRUE); } else { return (is_coercible (MOID (p), MOID (q), SORT (q), deflex)); } } /** @brief Whether list "y" is balanced. @param n Node in syntax tree. @param y Soid list. @param sort Sort. @return See brief description. **/ static BOOL_T is_balanced (NODE_T * n, SOID_T * y, int sort) { if (sort == STRONG) { return (A68_TRUE); } else { BOOL_T k = A68_FALSE; for (; y != NO_SOID && !k; FORWARD (y)) { k = (BOOL_T) (ISNT (MOID (y), STOWED_MODE)); } if (k == A68_FALSE) { diagnostic_node (A68_ERROR, n, ERROR_NO_UNIQUE_MODE); } return (k); } } /** @brief A moid from "m" to which all other members can be coerced. @param m Mode. @param sort Sort. @param return_depreffed Whether to depref. @param deflex Deflexing regime. @return See brief description. **/ MOID_T *get_balanced_mode (MOID_T * m, int sort, BOOL_T return_depreffed, int deflex) { MOID_T *common = NO_MOID; if (m != NO_MOID && !is_mode_isnt_well (m) && IS (m, UNION_SYMBOL)) { int depref_level; BOOL_T go_on = A68_TRUE; /* Test for increasing depreffing */ for (depref_level = 0; go_on; depref_level++) { PACK_T *p; go_on = A68_FALSE; /* Test the whole pack */ for (p = PACK (m); p != NO_PACK; FORWARD (p)) { /* HIPs are not eligible of course */ if (MOID (p) != MODE (HIP)) { MOID_T *candidate = MOID (p); int k; /* Depref as far as allowed */ for (k = depref_level; k > 0 && is_deprefable (candidate); k--) { candidate = depref_once (candidate); } /* Only need testing if all allowed deprefs succeeded */ if (k == 0) { PACK_T *q; MOID_T *to = (return_depreffed ? depref_completely (candidate) : candidate); BOOL_T all_coercible = A68_TRUE; go_on = A68_TRUE; for (q = PACK (m); q != NO_PACK && all_coercible; FORWARD (q)) { MOID_T *from = MOID (q); if (p != q && from != to) { all_coercible &= 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 == NO_MOID) { common = mark; } else if (IS (candidate, FLEX_SYMBOL) && DEFLEX (candidate) == common) { /* We prefer FLEX */ common = mark; } } } } }/* for */ }/* for */ } return (common == NO_MOID ? m : common); } /** @brief Whether we can search a common mode from a clause or not. @param att Attribute. @return See brief description. **/ static BOOL_T clause_allows_balancing (int att) { switch (att) { case CLOSED_CLAUSE: case CONDITIONAL_CLAUSE: case CASE_CLAUSE: case SERIAL_CLAUSE: case CONFORMITY_CLAUSE: { return (A68_TRUE); } } return (A68_FALSE); } /** @brief A unique mode from "z". @param z Soid. @param deflex Deflexing regime. @return See brief description. **/ static MOID_T *determine_unique_mode (SOID_T * z, int deflex) { if (z == NO_SOID) { return (NO_MOID); } else { MOID_T *x = MOID (z); if (is_mode_isnt_well (x)) { return (MODE (ERROR)); } x = make_united_mode (x); if (clause_allows_balancing (ATTRIBUTE (z))) { return (get_balanced_mode (x, STRONG, NO_DEPREF, deflex)); } else { return (x); } } } /** @brief Give a warning when a value is silently discarded. @param p Node in syntax tree. @param x Soid. @param y Soid. @param c Context. **/ static void warn_for_voiding (NODE_T * p, SOID_T * x, SOID_T * y, int c) { (void) c; if (CAST (x) == A68_FALSE) { if (MOID (x) == MODE (VOID) && MOID (y) != MODE (ERROR) && !(MOID (y) == MODE (VOID) || !is_nonproc (MOID (y)))) { if (IS (p, FORMULA)) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_VOIDED, MOID (y)); } else { diagnostic_node (A68_WARNING, p, WARNING_VOIDED, MOID (y)); } } } } /** @brief Warn for things that are likely unintended. @param p Node in syntax tree. @param m Moid. @param c Context. @param u Attribute. **/ static void 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)) { diagnostic_node (A68_WARNING, p, WARNING_UNINTENDED, MOID (p), u, m, c); } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) { semantic_pitfall (SUB (p), m, c, u); } } /** @brief Insert coercion "a" in the tree. @param l Node in syntax tree. @param a Attribute. @param m (coerced) moid **/ static void make_coercion (NODE_T * l, int a, MOID_T * m) { make_sub (l, l, a); MOID (l) = depref_rows (MOID (l), m); } /** @brief Make widening coercion. @param n Node in syntax tree. @param p Mode. @param q Mode. **/ static void make_widening_coercion (NODE_T * n, MOID_T * p, MOID_T * q) { MOID_T *z = widens_to (p, q); make_coercion (n, WIDENING, z); if (z != q) { make_widening_coercion (n, z, q); } } /** @brief Make ref rowing coercion. @param n Node in syntax tree. @param p Mode. @param q Mode. **/ static void make_ref_rowing_coercion (NODE_T * n, MOID_T * p, MOID_T * q) { if (DEFLEX (p) != DEFLEX (q)) { if (is_widenable (p, q)) { make_widening_coercion (n, p, q); } else if (is_ref_row (q)) { make_ref_rowing_coercion (n, p, NAME (q)); make_coercion (n, ROWING, q); } } } /** @brief Make rowing coercion. @param n Node in syntax tree. @param p Mode. @param q Mode. **/ static void make_rowing_coercion (NODE_T * n, MOID_T * p, MOID_T * q) { if (DEFLEX (p) != DEFLEX (q)) { if (is_widenable (p, q)) { make_widening_coercion (n, p, q); } else if (SLICE (q) != NO_MOID) { make_rowing_coercion (n, p, SLICE (q)); make_coercion (n, ROWING, q); } else if (IS (q, FLEX_SYMBOL)) { make_rowing_coercion (n, p, SUB (q)); } else if (is_ref_row (q)) { make_ref_rowing_coercion (n, p, q); } } } /** @brief Make uniting coercion. @param n Node in syntax tree. @param q Mode. **/ static void make_uniting_coercion (NODE_T * n, MOID_T * q) { make_coercion (n, UNITING, derow (q)); if (IS (q, ROW_SYMBOL) || IS (q, FLEX_SYMBOL)) { make_rowing_coercion (n, derow (q), q); } } /** @brief Make depreffing coercion. @param n Node in syntax tree. @param p Mode. @param q Mode. **/ static void make_depreffing_coercion (NODE_T * n, MOID_T * p, MOID_T * q) { if (DEFLEX (p) == DEFLEX (q)) { return; } else if (q == MODE (SIMPLOUT) && is_printable_mode (p)) { make_coercion (n, UNITING, q); } else if (q == MODE (ROW_SIMPLOUT) && is_printable_mode (p)) { make_coercion (n, UNITING, MODE (SIMPLOUT)); make_coercion (n, ROWING, MODE (ROW_SIMPLOUT)); } else if (q == MODE (SIMPLIN) && is_readable_mode (p)) { make_coercion (n, UNITING, q); } else if (q == MODE (ROW_SIMPLIN) && is_readable_mode (p)) { make_coercion (n, UNITING, MODE (SIMPLIN)); make_coercion (n, ROWING, MODE (ROW_SIMPLIN)); } else if (q == MODE (ROWS) && is_rows_type (p)) { make_coercion (n, UNITING, MODE (ROWS)); MOID (n) = MODE (ROWS); } else if (is_widenable (p, q)) { make_widening_coercion (n, p, q); } else if (is_unitable (p, derow (q), SAFE_DEFLEXING)) { make_uniting_coercion (n, q); } else if (is_ref_row (q) && is_strong_name (p, q)) { make_ref_rowing_coercion (n, p, q); } else if (SLICE (q) != NO_MOID && is_strong_slice (p, q)) { make_rowing_coercion (n, p, q); } else if (IS (q, FLEX_SYMBOL) && is_strong_slice (p, q)) { make_rowing_coercion (n, p, q); } else if (IS (p, REF_SYMBOL)) { MOID_T *r = depref_once (p); make_coercion (n, DEREFERENCING, r); make_depreffing_coercion (n, r, q); } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { MOID_T *r = SUB (p); make_coercion (n, DEPROCEDURING, r); make_depreffing_coercion (n, r, q); } else if (p != q) { cannot_coerce (n, p, q, NO_SORT, SKIP_DEFLEXING, 0); } } /** @brief Whether p is a nonproc mode (that is voided directly). @param p Mode. @return See brief description. **/ static BOOL_T is_nonproc (MOID_T * p) { if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) { return (A68_FALSE); } else if (IS (p, REF_SYMBOL)) { return (is_nonproc (SUB (p))); } else { return (A68_TRUE); } } /** @brief Make_void: voiden in an appropriate way. @param p Node in syntax tree. @param q Mode. **/ static void make_void (NODE_T * p, MOID_T * q) { switch (ATTRIBUTE (p)) { case ASSIGNATION: case IDENTITY_RELATION: case GENERATOR: case CAST: case DENOTATION: { make_coercion (p, VOIDING, MODE (VOID)); return; } } /* 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 (is_nonproc (q)) { make_coercion (p, VOIDING, MODE (VOID)); return; } else { /* Descend the chain of e.g. REF PROC .. until a nonproc moid remains */ MOID_T *z = q; while (!is_nonproc (z)) { if (IS (z, REF_SYMBOL)) { make_coercion (p, DEREFERENCING, SUB (z)); } if (IS (z, PROC_SYMBOL) && NODE_PACK (p) == NO_PACK) { make_coercion (p, DEPROCEDURING, SUB (z)); } z = SUB (z); } if (z != MODE (VOID)) { make_coercion (p, VOIDING, MODE (VOID)); } return; } } } /* All other is voided straight away */ make_coercion (p, VOIDING, MODE (VOID)); } /** @brief Make strong coercion. @param n Node in syntax tree. @param p Mode. @param q Mode. **/ static void make_strong (NODE_T * n, MOID_T * p, MOID_T * q) { if (q == MODE (VOID) && p != MODE (VOID)) { make_void (n, p); } else { make_depreffing_coercion (n, p, q); } } /** @brief Mode check on bounds. @param p Node in syntax tree. **/ static void mode_check_bounds (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, UNIT)) { SOID_T x, y; make_soid (&x, STRONG, MODE (INT), 0); mode_check_unit (p, &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&y), MODE (INT), MEEK, SAFE_DEFLEXING, UNIT); } mode_check_bounds (NEXT (p)); } else { mode_check_bounds (SUB (p)); mode_check_bounds (NEXT (p)); } } /** @brief Mode check declarer. @param p Node in syntax tree. **/ 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)); } } /** @brief Mode check identity declaration. @param p Node in syntax tree. **/ 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; make_soid (&x, STRONG, MOID (p), 0); mode_check_unit (NEXT_NEXT (p), &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { 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 */ 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; } } } } /** @brief Mode check variable declaration. @param p Node in syntax tree. **/ 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 (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) { SOID_T x, y; make_soid (&x, STRONG, SUB_MOID (p), 0); mode_check_unit (NEXT_NEXT (p), &x, &y); if (!is_coercible_in_context (&y, &x, FORCE_DEFLEXING)) { 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 */ 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; } } } } /** @brief Mode check routine text. @param p Node in syntax tree. @param y Resulting soid. **/ 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)); make_soid (&w, STRONG, MOID (p), 0); mode_check_unit (NEXT_NEXT (p), &w, y); if (!is_coercible_in_context (y, &w, FORCE_DEFLEXING)) { cannot_coerce (NEXT_NEXT (p), MOID (y), MOID (&w), STRONG, FORCE_DEFLEXING, UNIT); } } /** @brief Mode check proc declaration. @param p Node in syntax tree. **/ static void mode_check_proc_declaration (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, ROUTINE_TEXT)) { SOID_T x, y; 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)); } } /** @brief Mode check brief op declaration. @param p Node in syntax tree. **/ 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; make_soid (&y2, NO_SORT, MOID (NEXT_NEXT (p)), 0); make_soid (&x, NO_SORT, MOID (p), 0); 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)); } } /** @brief Mode check op declaration. @param p Node in syntax tree. **/ static void mode_check_op_declaration (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, DEFINING_OPERATOR)) { SOID_T y, x; make_soid (&x, STRONG, MOID (p), 0); mode_check_unit (NEXT_NEXT (p), &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { 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)); } } /** @brief Mode check declaration list. @param p Node in syntax tree. **/ 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; } } } } /** @brief Mode check serial clause. @param r Resulting soids. @param p Node in syntax tree. @param x Expected soid. @param k Whether statement yields a value other than VOID. **/ static void mode_check_serial (SOID_T ** r, NODE_T * p, SOID_T * x, BOOL_T k) { if (p == NO_NODE) { return; } else if (IS (p, INITIALISER_SERIES)) { mode_check_serial (r, SUB (p), x, A68_FALSE); mode_check_serial (r, NEXT (p), x, k); } else if (IS (p, DECLARATION_LIST)) { mode_check_declaration_list (SUB (p)); } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) { mode_check_serial (r, NEXT (p), x, k); } else if (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, A68_TRUE); } else { mode_check_serial (r, SUB (p), x, A68_FALSE); } mode_check_serial (r, NEXT (p), x, k); } else { mode_check_serial (r, SUB (p), x, A68_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; make_soid (&w, STRONG, MODE (VOID), 0); mode_check_unit (p, &w, &y); } if (NEXT (p) != NO_NODE) { mode_check_serial (r, NEXT (p), x, k); } else { if (k) { add_to_soid_list (r, p, &y); } } } } /** @brief Mode check serial clause units. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. @param att Attribute (SERIAL or ENQUIRY). **/ static void mode_check_serial_units (NODE_T * p, SOID_T * x, SOID_T * y, int att) { SOID_T *top_sl = NO_SOID; (void) att; mode_check_serial (&top_sl, SUB (p), x, A68_TRUE); if (is_balanced (p, top_sl, SORT (x))) { MOID_T *result = pack_soids_in_moid (top_sl, SERIES_MODE); make_soid (y, SORT (x), result, SERIAL_CLAUSE); } else { make_soid (y, SORT (x), (MOID (x) != NO_MOID ? MOID (x) : MODE (ERROR)), 0); } free_soid_list (top_sl); } /** @brief Mode check unit list. @param r Resulting soids. @param p Node in syntax tree. @param x Expected soid. **/ 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); add_to_soid_list (r, p, &y); mode_check_unit_list (r, NEXT (p), x); } } /** @brief Mode check struct display. @param r Resulting soids. @param p Node in syntax tree. @param fields Pack. **/ 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) { make_soid (&x, STRONG, MOID (*fields), 0); FORWARD (*fields); } else { make_soid (&x, STRONG, NO_MOID, 0); } mode_check_unit (p, &x, &y); add_to_soid_list (r, p, &y); mode_check_struct_display (r, NEXT (p), fields); } } /** @brief Mode check get specified moids. @param p Node in syntax tree. @param u United mode to add to. **/ static void mode_check_get_specified_moids (NODE_T * p, MOID_T * u) { for (; p != NO_NODE; FORWARD (p)) { if (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)); add_mode_to_pack (&(PACK (u)), m, NO_TEXT, NODE (m)); } } } /** @brief Mode check specified unit list. @param r Resulting soids. @param p Node in syntax tree. @param x Expected soid. @param u Resulting united mode. **/ static 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 (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 && !is_unitable (m, u, SAFE_DEFLEXING)) { diagnostic_node (A68_ERROR, p, ERROR_NO_COMPONENT, m, u); } } else if (IS (p, UNIT)) { SOID_T y; mode_check_unit (p, x, &y); add_to_soid_list (r, p, &y); } } } /** @brief Mode check united case parts. @param ry Resulting soids. @param p Node in syntax tree. @param x Expected soid. **/ 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 */ make_soid (&enq_expct, STRONG, NO_MOID, 0); mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); /* Deduce the united mode from the enquiry clause */ u = depref_completely (MOID (&enq_yield)); u = make_united_mode (u); u = depref_completely (u); /* Also deduce the united mode from the specifiers */ v = new_moid (); ATTRIBUTE (v) = SERIES_MODE; mode_check_get_specified_moids (NEXT_SUB (NEXT (p)), v); v = make_united_mode (v); /* Determine a resulting union */ if (u == MODE (HIP)) { w = v; } else { if (IS (u, UNION_SYMBOL)) { BOOL_T uv, vu, some; investigate_firm_relations (PACK (u), PACK (v), &uv, &some); 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 = absorb_related_subsets (u); } } else { diagnostic_node (A68_ERROR, NEXT_SUB (p), ERROR_NO_UNION, 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 (is_one_of (p, OUT_PART, CHOICE, STOP)) { mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE); } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) { mode_check_united_case_parts (ry, SUB (p), x); } } } /** @brief Mode check united case. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_united_case (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T *top_sl = NO_SOID; MOID_T *z; mode_check_united_case_parts (&top_sl, p, x); if (!is_balanced (p, top_sl, SORT (x))) { if (MOID (x) != NO_MOID) { make_soid (y, SORT (x), MOID (x), CONFORMITY_CLAUSE); } else { make_soid (y, SORT (x), MODE (ERROR), 0); } } else { z = pack_soids_in_moid (top_sl, SERIES_MODE); make_soid (y, SORT (x), z, CONFORMITY_CLAUSE); } free_soid_list (top_sl); } /** @brief Mode check unit list 2. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ 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 (MOID (x), FLEX_SYMBOL)) { SOID_T y2; make_soid (&y2, SORT (x), SLICE (SUB_MOID (x)), 0); mode_check_unit_list (&top_sl, SUB (p), &y2); } else if (IS (MOID (x), ROW_SYMBOL)) { SOID_T y2; 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); } make_soid (y, STRONG, pack_soids_in_moid (top_sl, STOWED_MODE), 0); free_soid_list (top_sl); } /** @brief Mode check closed. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ 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 (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) { mode_check_closed (NEXT (p), x, y); } MOID (p) = MOID (y); } /** @brief Mode check collateral. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_collateral (NODE_T * p, SOID_T * x, SOID_T * y) { if (p == NO_NODE) { return; } else if (whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP)) { if (SORT (x) == STRONG) { if (MOID (x) == NO_MOID) { diagnostic_node (A68_ERROR, p, ERROR_VACUO, "REF MODE"); } else { MOID_T *z = (IS (MOID (x), FLEX_SYMBOL) ? SUB_MOID (x) : MOID (x)); make_soid (y, STRONG, MODE (VACUUM), 0); if (SUB (z) != NO_MOID && HAS_ROWS (SUB (z))) { diagnostic_node (A68_ERROR, p, ERROR_VACUUM, "REF", MOID (x)); } } } else { make_soid (y, STRONG, MODE (UNDEFINED), 0); } } else { if (IS (p, UNIT_LIST)) { mode_check_unit_list_2 (p, x, y); } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) { mode_check_collateral (NEXT (p), x, y); } MOID (p) = MOID (y); } } /** @brief Mode check conditional 2. @param ry Resulting soids. @param p Node in syntax tree. @param x Expected soid. **/ static void mode_check_conditional_2 (SOID_T ** ry, NODE_T * p, SOID_T * x) { SOID_T enq_expct, enq_yield; make_soid (&enq_expct, STRONG, MODE (BOOL), 0); mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); } FORWARD (p); mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, ELSE_PART, CHOICE, STOP)) { mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE); } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) { mode_check_conditional_2 (ry, SUB (p), x); } } } /** @brief Mode check conditional. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_conditional (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T *top_sl = NO_SOID; MOID_T *z; mode_check_conditional_2 (&top_sl, p, x); if (!is_balanced (p, top_sl, SORT (x))) { if (MOID (x) != NO_MOID) { make_soid (y, SORT (x), MOID (x), CONDITIONAL_CLAUSE); } else { make_soid (y, SORT (x), MODE (ERROR), 0); } } else { z = pack_soids_in_moid (top_sl, SERIES_MODE); make_soid (y, SORT (x), z, CONDITIONAL_CLAUSE); } free_soid_list (top_sl); } /** @brief Mode check int case 2. @param ry Resulting soids. @param p Node in syntax tree. @param x Expected soid. **/ static void mode_check_int_case_2 (SOID_T ** ry, NODE_T * p, SOID_T * x) { SOID_T enq_expct, enq_yield; make_soid (&enq_expct, STRONG, MODE (INT), 0); mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) { 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 (is_one_of (p, OUT_PART, CHOICE, STOP)) { mode_check_serial (ry, NEXT_SUB (p), x, A68_TRUE); } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) { mode_check_int_case_2 (ry, SUB (p), x); } } } /** @brief Mode check int case. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_int_case (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T *top_sl = NO_SOID; MOID_T *z; mode_check_int_case_2 (&top_sl, p, x); if (!is_balanced (p, top_sl, SORT (x))) { if (MOID (x) != NO_MOID) { make_soid (y, SORT (x), MOID (x), CASE_CLAUSE); } else { make_soid (y, SORT (x), MODE (ERROR), 0); } } else { z = pack_soids_in_moid (top_sl, SERIES_MODE); make_soid (y, SORT (x), z, CASE_CLAUSE); } free_soid_list (top_sl); } /** @brief Mode check loop 2. @param p Node in syntax tree. @param y Resulting soid. **/ 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 (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) { SOID_T ix, iy; make_soid (&ix, STRONG, MODE (INT), 0); mode_check_unit (NEXT_SUB (p), &ix, &iy); if (!is_coercible_in_context (&iy, &ix, SAFE_DEFLEXING)) { cannot_coerce (NEXT_SUB (p), MOID (&iy), MODE (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; make_soid (&enq_expct, STRONG, MODE (BOOL), 0); mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); } mode_check_loop_2 (NEXT (p), y); } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) { SOID_T *z = NO_SOID; SOID_T ix; NODE_T *do_p = NEXT_SUB (p), *un_p; make_soid (&ix, STRONG, MODE (VOID), 0); if (IS (do_p, SERIAL_CLAUSE)) { mode_check_serial (&z, do_p, &ix, A68_TRUE); un_p = NEXT (do_p); } else { un_p = do_p; } if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) { SOID_T enq_expct, enq_yield; make_soid (&enq_expct, STRONG, MODE (BOOL), 0); mode_check_serial_units (NEXT_SUB (un_p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE); if (!is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING)) { cannot_coerce (un_p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE); } } free_soid_list (z); } } /** @brief Mode check loop. @param p Node in syntax tree. @param y Resulting soid. **/ static void mode_check_loop (NODE_T * p, SOID_T * y) { SOID_T *z = NO_SOID; mode_check_loop_2 (p, /* y */ z); make_soid (y, STRONG, MODE (VOID), 0); } /** @brief Mode check enclosed. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ 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, PARALLEL_CLAUSE)) { mode_check_collateral (SUB (NEXT_SUB (p)), x, y); make_soid (y, STRONG, MODE (VOID), 0); MOID (NEXT_SUB (p)) = MODE (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); } /** @brief Search table for operator. @param t Tag chain to search. @param n Name of operator. @param x Lhs mode. @param y Rhs mode. @return Tag entry. **/ static TAG_T *search_table_for_operator (TAG_T * t, char *n, MOID_T * x, MOID_T * y) { if (is_mode_isnt_well (x)) { return (error_tag); } else if (y != NO_MOID && is_mode_isnt_well (y)) { return (error_tag); } for (; t != NO_TAG; FORWARD (t)) { if (NSYMBOL (NODE (t)) == n) { PACK_T *p = PACK (MOID (t)); if (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 && is_coercible (y, MOID (p), FIRM, ALIAS_DEFLEXING)) { /* Matched in case of a dyadic */ return (t); } } } } return (NO_TAG); } /** @brief Search chain of symbol tables and return matching operator "x n y" or "n x". @param s Symbol table to start search. @param n Name of token. @param x Lhs mode. @param y Rhs mode. @return Tag entry. **/ static TAG_T *search_table_chain_for_operator (TABLE_T * s, char * n, MOID_T * x, MOID_T * y) { if (is_mode_isnt_well (x)) { return (error_tag); } else if (y != NO_MOID && is_mode_isnt_well (y)) { return (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); } /** @brief Return a matching operator "x n y". @param s Symbol table to start search. @param n Name of token. @param x Lhs mode. @param y Rhs mode. @return Tag entry. **/ static TAG_T *find_operator (TABLE_T * s, char *n, MOID_T * x, MOID_T * y) { /* Coercions to operand modes are FIRM */ TAG_T *z; MOID_T *u, *v; /* (A) Catch exceptions first */ if (x == NO_MOID && y == NO_MOID) { return (NO_TAG); } else if (is_mode_isnt_well (x)) { return (error_tag); } else if (y != NO_MOID && is_mode_isnt_well (y)) { return (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 (is_coercible (x, MODE (COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (COMPLEX), NO_MOID); if (z != NO_TAG) { return (z); } } if (is_coercible (x, MODE (LONG_COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONG_COMPLEX), NO_MOID); if (z != NO_TAG) { return (z); } } if (is_coercible (x, MODE (LONGLONG_COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONGLONG_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 = depref_completely (x); v = depref_completely (y); if ((u == MODE (ROW_REAL) || u == MODE (ROWROW_REAL)) || (v == MODE (ROW_REAL) || v == MODE (ROWROW_REAL)) || (u == MODE (ROW_COMPLEX) || u == MODE (ROWROW_COMPLEX)) || (v == MODE (ROW_COMPLEX) || v == MODE (ROWROW_COMPLEX))) { if (u == MODE (INT)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (REAL), y); if (z != NO_TAG) { return (z); } z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (COMPLEX), y); if (z != NO_TAG) { return (z); } } else if (v == MODE (INT)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, x, MODE (REAL)); if (z != NO_TAG) { return (z); } z = search_table_for_operator (OPERATORS (a68g_standenv), n, x, MODE (COMPLEX)); if (z != NO_TAG) { return (z); } } else if (u == MODE (REAL)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (COMPLEX), y); if (z != NO_TAG) { return (z); } } else if (v == MODE (REAL)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, x, MODE (COMPLEX)); if (z != NO_TAG) { return (z); } } } /* (C.3) Look in standenv for an appropriate cross-term */ u = make_series_from_moids (x, y); u = make_united_mode (u); v = get_balanced_mode (u, STRONG, NO_DEPREF, SAFE_DEFLEXING); z = search_table_for_operator (OPERATORS (a68g_standenv), n, v, v); if (z != NO_TAG) { return (z); } if (is_coercible_series (u, MODE (REAL), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (REAL), MODE (REAL)); if (z != NO_TAG) { return (z); } } if (is_coercible_series (u, MODE (LONG_REAL), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONG_REAL), MODE (LONG_REAL)); if (z != NO_TAG) { return (z); } } if (is_coercible_series (u, MODE (LONGLONG_REAL), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONGLONG_REAL), MODE (LONGLONG_REAL)); if (z != NO_TAG) { return (z); } } if (is_coercible_series (u, MODE (COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (COMPLEX), MODE (COMPLEX)); if (z != NO_TAG) { return (z); } } if (is_coercible_series (u, MODE (LONG_COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONG_COMPLEX), MODE (LONG_COMPLEX)); if (z != NO_TAG) { return (z); } } if (is_coercible_series (u, MODE (LONGLONG_COMPLEX), STRONG, SAFE_DEFLEXING)) { z = search_table_for_operator (OPERATORS (a68g_standenv), n, MODE (LONGLONG_COMPLEX), MODE (LONGLONG_COMPLEX)); if (z != NO_TAG) { return (z); } } /* (C.4) Now allow for depreffing for REF REAL +:= INT and alike */ v = get_balanced_mode (u, STRONG, DEPREF, SAFE_DEFLEXING); z = search_table_for_operator (OPERATORS (a68g_standenv), n, v, v); if (z != NO_TAG) { return (z); } return (NO_TAG); } /** @brief Mode check monadic operator. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ 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; u = determine_unique_mode (y, SAFE_DEFLEXING); if (is_mode_isnt_well (u)) { make_soid (y, SORT (x), MODE (ERROR), 0); } else if (u == MODE (HIP)) { diagnostic_node (A68_ERROR, NEXT (p), ERROR_INVALID_OPERAND, u); make_soid (y, SORT (x), MODE (ERROR), 0); } else { if (a68g_strchr (NOMADS, *(NSYMBOL (p))) != NO_TEXT) { t = NO_TAG; diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_OPERATOR_INVALID, NOMADS); make_soid (y, SORT (x), MODE (ERROR), 0); } else { t = find_operator (TABLE (p), NSYMBOL (p), u, NO_MOID); if (t == NO_TAG) { diagnostic_node (A68_ERROR, p, ERROR_NO_MONADIC, u); make_soid (y, SORT (x), MODE (ERROR), 0); } } if (t != NO_TAG) { MOID (p) = MOID (t); } TAX (p) = t; if (t != NO_TAG && t != error_tag) { MOID (p) = MOID (t); make_soid (y, SORT (x), SUB_MOID (t), 0); } else { MOID (p) = MODE (ERROR); make_soid (y, SORT (x), MODE (ERROR), 0); } } } } /** @brief Mode check monadic formula. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_monadic_formula (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T e; make_soid (&e, FIRM, NO_MOID, 0); mode_check_formula (NEXT (p), &e, y); mode_check_monadic_operator (p, &e, y); make_soid (y, SORT (x), MOID (y), 0); } /** @brief Mode check formula. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_formula (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T ls, rs; TAG_T *op; MOID_T *u, *v; 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; make_soid (&e, FIRM, NO_MOID, 0); mode_check_unit (SUB (p), &e, &ls); } u = determine_unique_mode (&ls, SAFE_DEFLEXING); MOID (p) = u; if (NEXT (p) == NO_NODE) { 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; make_soid (&e, FIRM, NO_MOID, 0); mode_check_unit (SUB (q), &e, &rs); } v = determine_unique_mode (&rs, SAFE_DEFLEXING); MOID (q) = v; if (is_mode_isnt_well (u) || is_mode_isnt_well (v)) { make_soid (y, SORT (x), MODE (ERROR), 0); } else if (u == MODE (HIP)) { diagnostic_node (A68_ERROR, p, ERROR_INVALID_OPERAND, u); make_soid (y, SORT (x), MODE (ERROR), 0); } else if (v == MODE (HIP)) { diagnostic_node (A68_ERROR, q, ERROR_INVALID_OPERAND, u); make_soid (y, SORT (x), MODE (ERROR), 0); } else { op = find_operator (TABLE (NEXT (p)), NSYMBOL (NEXT (p)), u, v); if (op == NO_TAG) { diagnostic_node (A68_ERROR, NEXT (p), ERROR_NO_DYADIC, u, v); make_soid (y, SORT (x), MODE (ERROR), 0); } if (op != NO_TAG) { MOID (NEXT (p)) = MOID (op); } TAX (NEXT (p)) = op; if (op != NO_TAG && op != error_tag) { make_soid (y, SORT (x), SUB_MOID (op), 0); } else { make_soid (y, SORT (x), MODE (ERROR), 0); } } } } /** @brief Mode check assignation. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_assignation (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T name, tmp, value; MOID_T *name_moid, *source_moid, *dest_moid, *ori; /* Get destination mode */ make_soid (&name, SOFT, NO_MOID, 0); mode_check_unit (SUB (p), &name, &tmp); dest_moid = MOID (&tmp); /* SOFT coercion */ ori = determine_unique_mode (&tmp, SAFE_DEFLEXING); name_moid = deproc_completely (ori); if (ATTRIBUTE (name_moid) != REF_SYMBOL) { if (IF_MODE_IS_WELL (name_moid)) { diagnostic_node (A68_ERROR, p, ERROR_NO_NAME, ori, ATTRIBUTE (SUB (p))); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } MOID (p) = name_moid; /* Get source mode */ make_soid (&name, STRONG, SUB (name_moid), 0); mode_check_unit (NEXT_NEXT (p), &name, &value); if (!is_coercible_in_context (&value, &name, FORCE_DEFLEXING)) { source_moid = MOID (&value); cannot_coerce (p, MOID (&value), MOID (&name), STRONG, FORCE_DEFLEXING, UNIT); make_soid (y, SORT (x), MODE (ERROR), 0); } else { make_soid (y, SORT (x), name_moid, 0); } } /** @brief Mode check identity relation. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_identity_relation (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T e, l, r; MOID_T *lhs, *rhs, *oril, *orir; NODE_T *ln = p, *rn = NEXT_NEXT (p); make_soid (&e, SOFT, NO_MOID, 0); mode_check_unit (SUB (ln), &e, &l); mode_check_unit (SUB (rn), &e, &r); /* SOFT coercion */ oril = determine_unique_mode (&l, SAFE_DEFLEXING); orir = determine_unique_mode (&r, SAFE_DEFLEXING); lhs = deproc_completely (oril); rhs = deproc_completely (orir); if (IF_MODE_IS_WELL (lhs) && lhs != MODE (HIP) && ATTRIBUTE (lhs) != REF_SYMBOL) { diagnostic_node (A68_ERROR, ln, ERROR_NO_NAME, oril, ATTRIBUTE (SUB (ln))); lhs = MODE (ERROR); } if (IF_MODE_IS_WELL (rhs) && rhs != MODE (HIP) && ATTRIBUTE (rhs) != REF_SYMBOL) { diagnostic_node (A68_ERROR, rn, ERROR_NO_NAME, orir, ATTRIBUTE (SUB (rn))); rhs = MODE (ERROR); } if (lhs == MODE (HIP) && rhs == MODE (HIP)) { diagnostic_node (A68_ERROR, p, ERROR_NO_UNIQUE_MODE); } if (is_coercible (lhs, rhs, STRONG, SAFE_DEFLEXING)) { lhs = rhs; } else if (is_coercible (rhs, lhs, STRONG, SAFE_DEFLEXING)) { rhs = lhs; } else { cannot_coerce (NEXT (p), rhs, lhs, SOFT, SKIP_DEFLEXING, TERTIARY); lhs = rhs = MODE (ERROR); } MOID (ln) = lhs; MOID (rn) = rhs; make_soid (y, SORT (x), MODE (BOOL), 0); } /** @brief Mode check bool functions ANDF and ORF. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ 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); make_soid (&e, STRONG, MODE (BOOL), 0); mode_check_unit (SUB (ln), &e, &l); if (!is_coercible_in_context (&l, &e, SAFE_DEFLEXING)) { cannot_coerce (ln, MOID (&l), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY); } mode_check_unit (SUB (rn), &e, &r); if (!is_coercible_in_context (&r, &e, SAFE_DEFLEXING)) { cannot_coerce (rn, MOID (&r), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY); } MOID (ln) = MODE (BOOL); MOID (rn) = MODE (BOOL); make_soid (y, SORT (x), MODE (BOOL), 0); } /** @brief Mode check cast. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_cast (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w; mode_check_declarer (p); make_soid (&w, STRONG, MOID (p), 0); CAST (&w) = A68_TRUE; mode_check_enclosed (SUB_NEXT (p), &w, y); if (!is_coercible_in_context (y, &w, SAFE_DEFLEXING)) { cannot_coerce (NEXT (p), MOID (y), MOID (&w), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); } make_soid (y, SORT (x), MOID (p), 0); } /** @brief Mode check assertion. @param p Node in syntax tree. **/ static void mode_check_assertion (NODE_T * p) { SOID_T w, y; make_soid (&w, STRONG, MODE (BOOL), 0); mode_check_enclosed (SUB_NEXT (p), &w, &y); SORT (&y) = SORT (&w); /* Patch */ if (!is_coercible_in_context (&y, &w, NO_DEFLEXING)) { cannot_coerce (NEXT (p), MOID (&y), MOID (&w), MEEK, NO_DEFLEXING, ENCLOSED_CLAUSE); } } /** @brief Mode check argument list. @param r Resulting soids. @param p Node in syntax tree. @param x Proc argument pack. @param v Partial locale pack. @param w Partial proc pack. **/ 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) { make_soid (&z, STRONG, MOID (*x), 0); add_mode_to_pack_end (v, MOID (*x), NO_TEXT, p); FORWARD (*x); } else { make_soid (&z, STRONG, NO_MOID, 0); } mode_check_unit (p, &z, &y); add_to_soid_list (r, p, &y); } else if (IS (p, TRIMMER)) { SOID_T z; if (SUB (p) != NO_NODE) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_SYNTAX, ARGUMENT); make_soid (&z, STRONG, MODE (ERROR), 0); add_mode_to_pack_end (v, MODE (VOID), NO_TEXT, p); add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p); FORWARD (*x); } else if (*x != NO_PACK) { make_soid (&z, STRONG, MOID (*x), 0); add_mode_to_pack_end (v, MODE (VOID), NO_TEXT, p); add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p); FORWARD (*x); } else { make_soid (&z, STRONG, NO_MOID, 0); } add_to_soid_list (r, p, &z); } else if (IS (p, SUB_SYMBOL) && !OPTION_BRACKETS (&program)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_SYNTAX, CALL); } } } /** @brief Mode check argument list 2. @param p Node in syntax tree. @param x Proc argument pack. @param y Soid. @param v Partial locale pack. @param w Partial proc pack. **/ 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); make_soid (y, STRONG, pack_soids_in_moid (top_sl, STOWED_MODE), 0); free_soid_list (top_sl); } /** @brief Mode check meek int. @param p Node in syntax tree. **/ static void mode_check_meek_int (NODE_T * p) { SOID_T x, y; make_soid (&x, STRONG, MODE (INT), 0); mode_check_unit (p, &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&y), MOID (&x), MEEK, SAFE_DEFLEXING, 0); } } /** @brief Mode check trimmer. @param p Node in syntax tree. **/ 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)); } } /** @brief Mode check indexer. @param p Node in syntax tree. @param subs Subscript counter. @param trims Trimmer counter. **/ 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); } } /** @brief Mode check call. @param p Node in syntax tree. @param n Mode. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_call (NODE_T * p, MOID_T * n, SOID_T * x, SOID_T * y) { SOID_T d; MOID (p) = n; /* "partial_locale" is the mode of the locale */ PARTIAL_LOCALE (GINFO (p)) = 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)) = 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 */ 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))) = count_pack_members (PACK (PARTIAL_PROC (GINFO (p)))); DIM (PARTIAL_LOCALE (GINFO (p))) = count_pack_members (PACK (PARTIAL_LOCALE (GINFO (p)))); PARTIAL_PROC (GINFO (p)) = register_extra_mode (&TOP_MOID (&program), PARTIAL_PROC (GINFO (p))); PARTIAL_LOCALE (GINFO (p)) = register_extra_mode (&TOP_MOID (&program), PARTIAL_LOCALE (GINFO (p))); if (DIM (MOID (&d)) != DIM (n)) { diagnostic_node (A68_ERROR, p, ERROR_ARGUMENT_NUMBER, n); make_soid (y, SORT (x), SUB (n), 0); /* make_soid (y, SORT (x), MODE (ERROR), 0); */ } else { if (!is_coercible (MOID (&d), n, STRONG, ALIAS_DEFLEXING)) { cannot_coerce (p, MOID (&d), n, STRONG, ALIAS_DEFLEXING, ARGUMENT); } if (DIM (PARTIAL_PROC (GINFO (p))) == 0) { make_soid (y, SORT (x), SUB (n), 0); } else { if (OPTION_PORTCHECK (&program)) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, NEXT (p), WARNING_EXTENSION); } make_soid (y, SORT (x), PARTIAL_PROC (GINFO (p)), 0); } } } /** @brief Mode check slice. @param p Node in syntax tree. @param ori Original MODE. @param x Expected soid. @param y Resulting soid. @return Whether construct is a CALL or a SLICE. **/ static void mode_check_slice (NODE_T * p, MOID_T * ori, SOID_T * x, SOID_T * y) { BOOL_T is_ref; int rowdim, subs, trims; MOID_T *m = depref_completely (ori), *n = ori; /* WEAK coercion */ while ((IS (n, REF_SYMBOL) && !is_ref_row (n)) || (IS (n, PROC_SYMBOL) && PACK (n) == NO_PACK)) { n = depref_once (n); } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_ROW_OR_PROC, n, ATTRIBUTE (SUB (p))); } make_soid (y, SORT (x), MODE (ERROR), 0); } MOID (p) = n; subs = trims = 0; mode_check_indexer (SUB_NEXT (p), &subs, &trims); if ((is_ref = is_ref_row (n)) != 0) { rowdim = DIM (DEFLEX (SUB (n))); } else { rowdim = DIM (DEFLEX (n)); } if ((subs + trims) != rowdim) { diagnostic_node (A68_ERROR, p, ERROR_INDEXER_NUMBER, n); make_soid (y, SORT (x), MODE (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 (m, FLEX_SYMBOL)) { m = SUB (m); } m = SLICE (m); } ABEND (m == NO_MOID, "No mode in mode_check_slice", NO_TEXT); subs--; } /* A trim cannot be but deflexed */ if (ANNOTATION (NEXT (p)) == TRIMMER && TRIM (m) != NO_MOID) { ABEND (TRIM (m) == NO_MOID, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); make_soid (y, SORT (x), TRIM (m), 0); } else { make_soid (y, SORT (x), m, 0); } } } /** @brief Mode check specification. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. @return Whether construct is a CALL or SLICE. **/ static int mode_check_specification (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w, d; MOID_T *m, *ori; make_soid (&w, WEAK, NO_MOID, 0); mode_check_unit (SUB (p), &w, &d); ori = determine_unique_mode (&d, SAFE_DEFLEXING); m = depref_completely (ori); if (IS (m, PROC_SYMBOL)) { /* Assume CALL */ mode_check_call (p, m, x, y); return (CALL); } else if (IS (m, ROW_SYMBOL) || IS (m, FLEX_SYMBOL)) { /* Assume SLICE */ mode_check_slice (p, ori, x, y); return (SLICE); } else { if (m != MODE (ERROR)) { diagnostic_node (A68_SYNTAX_ERROR, p, ERROR_MODE_SPECIFICATION, m); } make_soid (y, SORT (x), MODE (ERROR), 0); return (PRIMARY); } } /** @brief Mode check selection. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_selection (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w, d; BOOL_T coerce; MOID_T *n, *str, *ori; PACK_T *t, *t_2; char *fs; BOOL_T deflex = A68_FALSE; NODE_T *secondary = SUB_NEXT (p); make_soid (&w, WEAK, NO_MOID, 0); mode_check_unit (secondary, &w, &d); n = ori = determine_unique_mode (&d, SAFE_DEFLEXING); coerce = A68_TRUE; while (coerce) { if (IS (n, STRUCT_SYMBOL)) { coerce = A68_FALSE; t = PACK (n); } else if (IS (n, REF_SYMBOL) && (IS (SUB (n), ROW_SYMBOL) || IS (SUB (n), FLEX_SYMBOL)) && MULTIPLE (n) != NO_MOID) { coerce = A68_FALSE; deflex = A68_TRUE; t = PACK (MULTIPLE (n)); } else if ((IS (n, ROW_SYMBOL) || IS (n, FLEX_SYMBOL)) && MULTIPLE (n) != NO_MOID) { coerce = A68_FALSE; deflex = A68_TRUE; t = PACK (MULTIPLE (n)); } else if (IS (n, REF_SYMBOL) && is_name_struct (n)) { coerce = A68_FALSE; t = PACK (NAME (n)); } else if (is_deprefable (n)) { coerce = A68_TRUE; n = SUB (n); t = NO_PACK; } else { coerce = A68_FALSE; t = NO_PACK; } } if (t == NO_PACK) { if (IF_MODE_IS_WELL (MOID (&d))) { diagnostic_node (A68_ERROR, secondary, ERROR_NO_STRUCT, ori, ATTRIBUTE (secondary)); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } MOID (NEXT (p)) = n; fs = NSYMBOL (SUB (p)); str = n; while (IS (str, REF_SYMBOL)) { str = SUB (str); } if (IS (str, FLEX_SYMBOL)) { str = SUB (str); } if (IS (str, ROW_SYMBOL)) { str = SUB (str); } t_2 = PACK (str); while (t != NO_PACK && t_2 != NO_PACK) { if (TEXT (t) == fs) { MOID_T *ret = MOID (t); if (deflex && TRIM (ret) != NO_MOID) { ret = TRIM (ret); } make_soid (y, SORT (x), ret, 0); MOID (p) = ret; NODE_PACK (SUB (p)) = t_2; return; } FORWARD (t); FORWARD (t_2); } make_soid (&d, NO_SORT, n, 0); diagnostic_node (A68_ERROR, p, ERROR_NO_FIELD, str, fs); make_soid (y, SORT (x), MODE (ERROR), 0); } /** @brief Mode check diagonal. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_diagonal (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w, d; NODE_T *tert; MOID_T *n, *ori; int rowdim; BOOL_T is_ref; if (IS (p, TERTIARY)) { make_soid (&w, STRONG, MODE (INT), 0); mode_check_unit (p, &w, &d); if (!is_coercible_in_context (&d, &w, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&d), MOID (&w), MEEK, SAFE_DEFLEXING, 0); } tert = NEXT_NEXT (p); } else { tert = NEXT (p); } make_soid (&w, WEAK, NO_MOID, 0); mode_check_unit (tert, &w, &d); n = ori = determine_unique_mode (&d, SAFE_DEFLEXING); while (IS (n, REF_SYMBOL) && !is_ref_row (n)) { n = depref_once (n); } if (n != NO_MOID && (IS (n, FLEX_SYMBOL) || IS_REF_FLEX (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if ((is_ref = is_ref_row (n)) != A68_FALSE) { rowdim = DIM (DEFLEX (SUB (n))); } else { rowdim = DIM (DEFLEX (n)); } if (rowdim != 2) { diagnostic_node (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); make_soid (y, SORT (x), MODE (ERROR), 0); return; } MOID (tert) = n; if (is_ref) { n = NAME (n); ABEND (ISNT (n, REF_SYMBOL), "mode table error", PM (n)); } else { n = SLICE (n); } ABEND (n == NO_MOID, "No mode in mode_check_diagonal", NO_TEXT); make_soid (y, SORT (x), n, 0); } /** @brief Mode check transpose. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_transpose (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w, d; NODE_T *tert = NEXT (p); MOID_T *n, *ori; int rowdim; BOOL_T is_ref; make_soid (&w, WEAK, NO_MOID, 0); mode_check_unit (tert, &w, &d); n = ori = determine_unique_mode (&d, SAFE_DEFLEXING); while (IS (n, REF_SYMBOL) && !is_ref_row (n)) { n = depref_once (n); } if (n != NO_MOID && (IS (n, FLEX_SYMBOL) || IS_REF_FLEX (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if ((is_ref = is_ref_row (n)) != A68_FALSE) { rowdim = DIM (DEFLEX (SUB (n))); } else { rowdim = DIM (DEFLEX (n)); } if (rowdim != 2) { diagnostic_node (A68_ERROR, p, ERROR_NO_MATRIX, ori, TERTIARY); make_soid (y, SORT (x), MODE (ERROR), 0); return; } MOID (tert) = n; ABEND (n == NO_MOID, "No mode in mode_check_transpose", NO_TEXT); make_soid (y, SORT (x), n, 0); } /** @brief Mode check row or column function. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_row_column_function (NODE_T * p, SOID_T * x, SOID_T * y) { SOID_T w, d; NODE_T *tert; MOID_T *n, *ori; int rowdim; BOOL_T is_ref; if (IS (p, TERTIARY)) { make_soid (&w, STRONG, MODE (INT), 0); mode_check_unit (p, &w, &d); if (!is_coercible_in_context (&d, &w, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&d), MOID (&w), MEEK, SAFE_DEFLEXING, 0); } tert = NEXT_NEXT (p); } else { tert = NEXT (p); } make_soid (&w, WEAK, NO_MOID, 0); mode_check_unit (tert, &w, &d); n = ori = determine_unique_mode (&d, SAFE_DEFLEXING); while (IS (n, REF_SYMBOL) && !is_ref_row (n)) { n = depref_once (n); } if (n != NO_MOID && (IS (n, FLEX_SYMBOL) || IS_REF_FLEX (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_FLEX_ARGUMENT, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || is_ref_row (n))) { if (IF_MODE_IS_WELL (n)) { diagnostic_node (A68_ERROR, p, ERROR_NO_VECTOR, ori, TERTIARY); } make_soid (y, SORT (x), MODE (ERROR), 0); return; } if ((is_ref = is_ref_row (n)) != A68_FALSE) { rowdim = DIM (DEFLEX (SUB (n))); } else { rowdim = DIM (DEFLEX (n)); } if (rowdim != 1) { diagnostic_node (A68_ERROR, p, ERROR_NO_VECTOR, ori, TERTIARY); make_soid (y, SORT (x), MODE (ERROR), 0); return; } MOID (tert) = n; ABEND (n == NO_MOID, "No mode in mode_check_diagonal", NO_TEXT); make_soid (y, SORT (x), ROWED (n), 0); } /** @brief Mode check format text. @param p Node in syntax tree. **/ 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; make_soid (&x, STRONG, MODE (FORMAT), 0); mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { 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; make_soid (&x, STRONG, MODE (ROW_INT), 0); mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); } } else if (IS (p, DYNAMIC_REPLICATOR)) { SOID_T x, y; make_soid (&x, STRONG, MODE (INT), 0); mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y); if (!is_coercible_in_context (&y, &x, SAFE_DEFLEXING)) { cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE); } } } } /** @brief Mode check unit. @param p Node in syntax tree. @param x Expected soid. @param y Resulting soid. **/ static void mode_check_unit (NODE_T * p, SOID_T * x, SOID_T * y) { if (p == NO_NODE) { return; } else if (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); warn_for_voiding (p, x, y, ATTRIBUTE (p)); } else if (IS (p, CAST)) { mode_check_cast (SUB (p), x, y); warn_for_voiding (p, x, y, CAST); } else if (IS (p, DENOTATION)) { make_soid (y, SORT (x), MOID (SUB (p)), 0); warn_for_voiding (p, x, y, DENOTATION); } else if (IS (p, IDENTIFIER)) { if ((TAX (p) == NO_TAG) && (MOID (p) == NO_MOID)) { int att = first_tag_global (TABLE (p), NSYMBOL (p)); if (att == STOP) { (void) add_tag (TABLE (p), IDENTIFIER, p, MODE (ERROR), NORMAL_IDENTIFIER); diagnostic_node (A68_ERROR, p, ERROR_UNDECLARED_TAG); MOID (p) = MODE (ERROR); } else { TAG_T *z = find_tag_global (TABLE (p), att, NSYMBOL (p)); if (att == IDENTIFIER && z != NO_TAG) { MOID (p) = MOID (z); } else { (void) add_tag (TABLE (p), IDENTIFIER, p, MODE (ERROR), NORMAL_IDENTIFIER); diagnostic_node (A68_ERROR, p, ERROR_UNDECLARED_TAG); MOID (p) = MODE (ERROR); } } } make_soid (y, SORT (x), MOID (p), 0); 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); make_soid (y, SORT (x), MODE (FORMAT), 0); warn_for_voiding (p, x, y, FORMAT_TEXT); /* Ex secondary */ } else if (IS (p, GENERATOR)) { mode_check_declarer (SUB (p)); make_soid (y, SORT (x), MOID (SUB (p)), 0); warn_for_voiding (p, x, y, GENERATOR); } else if (IS (p, SELECTION)) { mode_check_selection (SUB (p), x, y); warn_for_voiding (p, x, y, SELECTION); /* Ex tertiary */ } else if (IS (p, NIHIL)) { make_soid (y, STRONG, MODE (HIP), 0); } else if (IS (p, FORMULA)) { mode_check_formula (p, x, y); if (ISNT (MOID (y), REF_SYMBOL)) { warn_for_voiding (p, x, y, FORMULA); } } else if (IS (p, DIAGONAL_FUNCTION)) { mode_check_diagonal (SUB (p), x, y); warn_for_voiding (p, x, y, DIAGONAL_FUNCTION); } else if (IS (p, TRANSPOSE_FUNCTION)) { mode_check_transpose (SUB (p), x, y); warn_for_voiding (p, x, y, TRANSPOSE_FUNCTION); } else if (IS (p, ROW_FUNCTION)) { mode_check_row_column_function (SUB (p), x, y); warn_for_voiding (p, x, y, ROW_FUNCTION); } else if (IS (p, COLUMN_FUNCTION)) { mode_check_row_column_function (SUB (p), x, y); warn_for_voiding (p, x, y, COLUMN_FUNCTION); /* Ex unit */ } else if (is_one_of (p, JUMP, SKIP, STOP)) { make_soid (y, STRONG, MODE (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); warn_for_voiding (p, x, y, IDENTITY_RELATION); } else if (IS (p, ROUTINE_TEXT)) { mode_check_routine_text (SUB (p), y); make_soid (y, SORT (x), MOID (p), 0); warn_for_voiding (p, x, y, ROUTINE_TEXT); } else if (IS (p, ASSERTION)) { mode_check_assertion (SUB (p)); make_soid (y, STRONG, MODE (VOID), 0); } else if (IS (p, AND_FUNCTION)) { mode_check_bool_function (SUB (p), x, y); warn_for_voiding (p, x, y, AND_FUNCTION); } else if (IS (p, OR_FUNCTION)) { mode_check_bool_function (SUB (p), x, y); warn_for_voiding (p, x, y, OR_FUNCTION); } else if (IS (p, CODE_CLAUSE)) { make_soid (y, STRONG, MODE (HIP), 0); } MOID (p) = MOID (y); } /** @brief Coerce bounds. @param p Node in syntax tree. **/ static void coerce_bounds (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { SOID_T q; make_soid (&q, MEEK, MODE (INT), 0); coerce_unit (p, &q); } else { coerce_bounds (SUB (p)); } } } /** @brief Coerce declarer. @param p Node in syntax tree. **/ 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)); } } } /** @brief Coerce identity declaration. @param p Node in syntax tree. **/ 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; 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; } } } } /** @brief Coerce variable declaration. @param p Node in syntax tree. **/ 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 (whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP)) { SOID_T q; make_soid (&q, STRONG, SUB_MOID (p), 0); coerce_unit (NEXT_NEXT (p), &q); break; } } default: { coerce_variable_declaration (SUB (p)); coerce_variable_declaration (NEXT (p)); break; } } } } /** @brief Coerce routine text. @param p Node in syntax tree. **/ static void coerce_routine_text (NODE_T * p) { SOID_T w; if (IS (p, PARAMETER_PACK)) { FORWARD (p); } make_soid (&w, STRONG, MOID (p), 0); coerce_unit (NEXT_NEXT (p), &w); } /** @brief Coerce proc declaration. @param p Node in syntax tree. **/ 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)); } } /** @brief Coerce_op_declaration. @param p Node in syntax tree. **/ static void coerce_op_declaration (NODE_T * p) { if (p == NO_NODE) { return; } else if (IS (p, DEFINING_OPERATOR)) { SOID_T q; make_soid (&q, STRONG, MOID (p), 0); coerce_unit (NEXT_NEXT (p), &q); } else { coerce_op_declaration (SUB (p)); coerce_op_declaration (NEXT (p)); } } /** @brief Coerce brief op declaration. @param p Node in syntax tree. **/ 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)); } } /** @brief Coerce declaration list. @param p Node in syntax tree. **/ 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; } } } } /** @brief Coerce serial. @param p Node in syntax tree. @param q Soid. @param k Whether k yields value other than VOID. **/ static void coerce_serial (NODE_T * p, SOID_T * q, BOOL_T k) { if (p == NO_NODE) { return; } else if (IS (p, INITIALISER_SERIES)) { coerce_serial (SUB (p), q, A68_FALSE); coerce_serial (NEXT (p), q, k); } else if (IS (p, DECLARATION_LIST)) { coerce_declaration_list (SUB (p)); } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) { coerce_serial (NEXT (p), q, k); } else if (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) || IS (z, OCCA_SYMBOL)) { coerce_serial (SUB (p), q, A68_TRUE); } else { coerce_serial (SUB (p), q, A68_FALSE); } } else { coerce_serial (SUB (p), q, A68_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; make_soid (&strongvoid, STRONG, MODE (VOID), 0); coerce_unit (p, &strongvoid); } } } /** @brief Coerce closed. @param p Node in syntax tree. @param q Soid. **/ static void coerce_closed (NODE_T * p, SOID_T * q) { if (IS (p, SERIAL_CLAUSE)) { coerce_serial (p, q, A68_TRUE); } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) { coerce_closed (NEXT (p), q); } } /** @brief Coerce conditional. @param p Node in syntax tree. @param q Soid. **/ static void coerce_conditional (NODE_T * p, SOID_T * q) { SOID_T w; make_soid (&w, MEEK, MODE (BOOL), 0); coerce_serial (NEXT_SUB (p), &w, A68_TRUE); FORWARD (p); coerce_serial (NEXT_SUB (p), q, A68_TRUE); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, ELSE_PART, CHOICE, STOP)) { coerce_serial (NEXT_SUB (p), q, A68_TRUE); } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) { coerce_conditional (SUB (p), q); } } } /** @brief Coerce unit list. @param p Node in syntax tree. @param q Soid. **/ 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 (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); } } /** @brief Coerce int case. @param p Node in syntax tree. @param q Soid. **/ static void coerce_int_case (NODE_T * p, SOID_T * q) { SOID_T w; make_soid (&w, MEEK, MODE (INT), 0); coerce_serial (NEXT_SUB (p), &w, A68_TRUE); FORWARD (p); coerce_unit_list (NEXT_SUB (p), q); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, OUT_PART, CHOICE, STOP)) { coerce_serial (NEXT_SUB (p), q, A68_TRUE); } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) { coerce_int_case (SUB (p), q); } } } /** @brief Coerce spec unit list. @param p Node in syntax tree. @param q Soid. **/ static void coerce_spec_unit_list (NODE_T * p, SOID_T * q) { for (; p != NO_NODE; FORWARD (p)) { if (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); } } } /** @brief Coerce united case. @param p Node in syntax tree. @param q Soid. **/ static void coerce_united_case (NODE_T * p, SOID_T * q) { SOID_T w; make_soid (&w, MEEK, MOID (SUB (p)), 0); coerce_serial (NEXT_SUB (p), &w, A68_TRUE); FORWARD (p); coerce_spec_unit_list (NEXT_SUB (p), q); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, OUT_PART, CHOICE, STOP)) { coerce_serial (NEXT_SUB (p), q, A68_TRUE); } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) { coerce_united_case (SUB (p), q); } } } /** @brief Coerce loop. @param p Node in syntax tree. **/ static void coerce_loop (NODE_T * p) { if (IS (p, FOR_PART)) { coerce_loop (NEXT (p)); } else if (is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP)) { SOID_T w; make_soid (&w, MEEK, MODE (INT), 0); coerce_unit (NEXT_SUB (p), &w); coerce_loop (NEXT (p)); } else if (IS (p, WHILE_PART)) { SOID_T w; make_soid (&w, MEEK, MODE (BOOL), 0); coerce_serial (NEXT_SUB (p), &w, A68_TRUE); coerce_loop (NEXT (p)); } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) { SOID_T w; NODE_T *do_p = NEXT_SUB (p), *un_p; make_soid (&w, STRONG, MODE (VOID), 0); coerce_serial (do_p, &w, A68_TRUE); if (IS (do_p, SERIAL_CLAUSE)) { un_p = NEXT (do_p); } else { un_p = do_p; } if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) { SOID_T sw; make_soid (&sw, MEEK, MODE (BOOL), 0); coerce_serial (NEXT_SUB (un_p), &sw, A68_TRUE); } } } /** @brief Coerce struct display. @param r Pack. @param p Node in syntax tree. **/ 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 (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; make_soid (&s, STRONG, MOID (*r), 0); coerce_unit (p, &s); FORWARD (*r); coerce_struct_display (r, NEXT (p)); } } /** @brief Coerce collateral. @param p Node in syntax tree. @param q Soid. **/ static void coerce_collateral (NODE_T * p, SOID_T * q) { if (!(whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || 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 (MOID (q), FLEX_SYMBOL)) { SOID_T w; make_soid (&w, STRONG, SLICE (SUB_MOID (q)), 0); coerce_unit_list (p, &w); } else if (IS (MOID (q), ROW_SYMBOL)) { SOID_T w; make_soid (&w, STRONG, SLICE (MOID (q)), 0); coerce_unit_list (p, &w); } else { /* if (MOID (q) != MODE (VOID)) */ coerce_unit_list (p, q); } } } /** @brief Coerce_enclosed. @param p Node in syntax tree. @param q Soid. **/ 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, 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) = depref_rows (MOID (p), MOID (q)); } /** @brief Get monad moid. @param p Node in syntax tree. **/ static MOID_T *get_monad_moid (NODE_T * p) { if (TAX (p) != NO_TAG && TAX (p) != error_tag) { MOID (p) = MOID (TAX (p)); return (MOID (PACK (MOID (p)))); } else { return (MODE (ERROR)); } } /** @brief Coerce monad oper. @param p Node in syntax tree. @param q Soid. **/ static void coerce_monad_oper (NODE_T * p, SOID_T * q) { if (p != NO_NODE) { SOID_T z; make_soid (&z, FIRM, MOID (PACK (MOID (TAX (p)))), 0); INSERT_COERCIONS (NEXT (p), MOID (q), &z); } } /** @brief Coerce monad formula. @param p Node in syntax tree. **/ static void coerce_monad_formula (NODE_T * p) { SOID_T e; make_soid (&e, STRONG, get_monad_moid (p), 0); coerce_operand (NEXT (p), &e); coerce_monad_oper (p, &e); } /** @brief Coerce operand. @param p Node in syntax tree. @param q Soid. **/ 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)) { make_sub (p, p, FORMULA); INSERT_COERCIONS (p, MOID (p), q); make_sub (p, p, TERTIARY); } MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, FORMULA)) { coerce_formula (SUB (p), q); INSERT_COERCIONS (p, MOID (p), q); MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, SECONDARY)) { coerce_unit (SUB (p), q); MOID (p) = MOID (SUB (p)); } } /** @brief Coerce formula. @param p Node in syntax tree. @param q Soid. **/ static void coerce_formula (NODE_T * p, SOID_T * q) { (void) q; if (IS (p, MONADIC_FORMULA) && NEXT (p) == NO_NODE) { coerce_monad_formula (SUB (p)); } else { if (TAX (NEXT (p)) != NO_TAG && TAX (NEXT (p)) != 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))); make_soid (&s, STRONG, u, 0); coerce_operand (p, &s); make_soid (&s, STRONG, v, 0); coerce_operand (nq, &s); } } } /** @brief Coerce assignation. @param p Node in syntax tree. **/ static void coerce_assignation (NODE_T * p) { SOID_T w; make_soid (&w, SOFT, MOID (p), 0); coerce_unit (SUB (p), &w); make_soid (&w, STRONG, SUB_MOID (p), 0); coerce_unit (NEXT_NEXT (p), &w); } /** @brief Coerce relation. @param p Node in syntax tree. **/ static void coerce_relation (NODE_T * p) { SOID_T w; make_soid (&w, STRONG, MOID (p), 0); coerce_unit (SUB (p), &w); make_soid (&w, STRONG, MOID (NEXT_NEXT (p)), 0); coerce_unit (SUB (NEXT_NEXT (p)), &w); } /** @brief Coerce bool function. @param p Node in syntax tree. **/ static void coerce_bool_function (NODE_T * p) { SOID_T w; make_soid (&w, STRONG, MODE (BOOL), 0); coerce_unit (SUB (p), &w); coerce_unit (SUB (NEXT_NEXT (p)), &w); } /** @brief Coerce assertion. @param p Node in syntax tree. **/ static void coerce_assertion (NODE_T * p) { SOID_T w; make_soid (&w, MEEK, MODE (BOOL), 0); coerce_enclosed (SUB_NEXT (p), &w); } /** @brief Coerce selection. @param p Node in syntax tree. **/ static void coerce_selection (NODE_T * p) { SOID_T w; make_soid (&w, /* WEAK */ STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } /** @brief Coerce cast. @param p Node in syntax tree. **/ static void coerce_cast (NODE_T * p) { SOID_T w; coerce_declarer (p); make_soid (&w, STRONG, MOID (p), 0); coerce_enclosed (NEXT (p), &w); } /** @brief Coerce argument list. @param r Pack. @param p Node in syntax tree. **/ 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; make_soid (&s, STRONG, MOID (*r), 0); coerce_unit (p, &s); FORWARD (*r); } else if (IS (p, TRIMMER)) { FORWARD (*r); } } } /** @brief Coerce call. @param p Node in syntax tree. **/ static void coerce_call (NODE_T * p) { MOID_T *proc = MOID (p); SOID_T w; PACK_T *t; make_soid (&w, MEEK, proc, 0); coerce_unit (SUB (p), &w); FORWARD (p); t = PACK (proc); coerce_argument_list (&t, SUB (p)); } /** @brief Coerce meek int. @param p Node in syntax tree. **/ static void coerce_meek_int (NODE_T * p) { SOID_T x; make_soid (&x, MEEK, MODE (INT), 0); coerce_unit (p, &x); } /** @brief Coerce trimmer. @param p Node in syntax tree. **/ 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)); } } } /** @brief Coerce indexer. @param p Node in syntax tree. **/ 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)); } } } /** @brief Coerce_slice. @param p Node in syntax tree. **/ static void coerce_slice (NODE_T * p) { SOID_T w; MOID_T *row; row = MOID (p); make_soid (&w, /* WEAK */ STRONG, row, 0); coerce_unit (SUB (p), &w); coerce_indexer (SUB_NEXT (p)); } /** @brief Mode coerce diagonal. @param p Node in syntax tree. **/ static void coerce_diagonal (NODE_T * p) { SOID_T w; if (IS (p, TERTIARY)) { make_soid (&w, MEEK, MODE (INT), 0); coerce_unit (SUB (p), &w); FORWARD (p); } make_soid (&w, /* WEAK */ STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } /** @brief Mode coerce transpose. @param p Node in syntax tree. **/ static void coerce_transpose (NODE_T * p) { SOID_T w; make_soid (&w, /* WEAK */ STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } /** @brief Mode coerce row or column function. @param p Node in syntax tree. **/ static void coerce_row_column_function (NODE_T * p) { SOID_T w; if (IS (p, TERTIARY)) { make_soid (&w, MEEK, MODE (INT), 0); coerce_unit (SUB (p), &w); FORWARD (p); } make_soid (&w, /* WEAK */ STRONG, MOID (NEXT (p)), 0); coerce_unit (SUB_NEXT (p), &w); } /** @brief Coerce format text. @param p Node in syntax tree. **/ 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; make_soid (&x, STRONG, MODE (FORMAT), 0); coerce_enclosed (SUB (NEXT_SUB (p)), &x); } else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE) { SOID_T x; make_soid (&x, STRONG, MODE (ROW_INT), 0); coerce_enclosed (SUB (NEXT_SUB (p)), &x); } else if (IS (p, DYNAMIC_REPLICATOR)) { SOID_T x; make_soid (&x, STRONG, MODE (INT), 0); coerce_enclosed (SUB (NEXT_SUB (p)), &x); } } } /** @brief Coerce unit. @param p Node in syntax tree. @param q Soid. **/ static void coerce_unit (NODE_T * p, SOID_T * q) { if (p == NO_NODE) { return; } else if (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)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, SLICE)) { coerce_slice (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, CAST)) { coerce_cast (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (is_one_of (p, DENOTATION, IDENTIFIER, STOP)) { INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, FORMAT_TEXT)) { coerce_format_text (SUB (p)); 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)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, GENERATOR)) { coerce_declarer (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); /* Ex tertiary */ } else if (IS (p, NIHIL)) { if (ATTRIBUTE (MOID (q)) != REF_SYMBOL && MOID (q) != MODE (VOID)) { diagnostic_node (A68_ERROR, p, ERROR_NO_NAME_REQUIRED); } MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, FORMULA)) { coerce_formula (SUB (p), q); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, DIAGONAL_FUNCTION)) { coerce_diagonal (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, TRANSPOSE_FUNCTION)) { coerce_transpose (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, ROW_FUNCTION)) { coerce_row_column_function (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, COLUMN_FUNCTION)) { coerce_row_column_function (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); /* Ex unit */ } else if (IS (p, JUMP)) { if (MOID (q) == MODE (PROC_VOID)) { make_sub (p, p, PROCEDURING); } MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, SKIP)) { MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, ASSIGNATION)) { coerce_assignation (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); MOID (p) = depref_rows (MOID (p), MOID (q)); } else if (IS (p, IDENTITY_RELATION)) { coerce_relation (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, ROUTINE_TEXT)) { coerce_routine_text (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (is_one_of (p, AND_FUNCTION, OR_FUNCTION, STOP)) { coerce_bool_function (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } else if (IS (p, ASSERTION)) { coerce_assertion (SUB (p)); INSERT_COERCIONS (p, MOID (p), q); } } /** @brief Widen denotation depending on mode required, this is an extension to A68. @param p Node in syntax tree. **/ void widen_denotation (NODE_T * p) { #define WIDEN {\ *q = *(SUB (q));\ ATTRIBUTE (q) = DENOTATION;\ MOID (q) = lm;\ STATUS_SET (q, OPTIMAL_MASK);\ } #define WARN_WIDENING\ if (OPTION_PORTCHECK (&program) && !(STATUS_TEST (SUB (q), OPTIMAL_MASK))) {\ diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, q, WARNING_WIDENING_NOT_PORTABLE);\ } NODE_T *q; for (q = p; q != NO_NODE; FORWARD (q)) { widen_denotation (SUB (q)); if (IS (q, WIDENING) && IS (SUB (q), DENOTATION)) { MOID_T *lm = MOID (q), *m = MOID (SUB (q)); if (lm == MODE (LONGLONG_INT) && m == MODE (LONG_INT)) { WARN_WIDENING; WIDEN; } if (lm == MODE (LONG_INT) && m == MODE (INT)) { WARN_WIDENING; WIDEN; } if (lm == MODE (LONGLONG_REAL) && m == MODE (LONG_REAL)) { WARN_WIDENING; WIDEN; } if (lm == MODE (LONG_REAL) && m == MODE (REAL)) { WARN_WIDENING; WIDEN; } if (lm == MODE (LONG_REAL) && m == MODE (LONG_INT)) { WIDEN; } if (lm == MODE (REAL) && m == MODE (INT)) { WIDEN; } if (lm == MODE (LONGLONG_BITS) && m == MODE (LONG_BITS)) { WARN_WIDENING; WIDEN; } if (lm == MODE (LONG_BITS) && m == MODE (BITS)) { WARN_WIDENING; WIDEN; } return; } } #undef WIDEN #undef WARN_WIDENING } /********************************************************************/ /* Static scope checker, at run time we check dynamic scope as well */ /********************************************************************/ /* Static scope checker. Also a little preparation for the monitor: - indicates UNITs that can be interrupted. */ /** @brief Scope_make_tuple. @param e Level. @param t Whether transient. @return Tuple (e, t). **/ static TUPLE_T scope_make_tuple (int e, int t) { static TUPLE_T z; LEVEL (&z) = e; TRANSIENT (&z) = (BOOL_T) t; return (z); } /** @brief Link scope information into the list. @param sl Chain to link into. @param p Node in syntax tree. @param tup Tuple to link. **/ static void scope_add (SCOPE_T ** sl, NODE_T * p, TUPLE_T tup) { if (sl != NO_VAR) { SCOPE_T *ns = (SCOPE_T *) get_temp_heap_space ((unsigned) SIZE_AL (SCOPE_T)); WHERE (ns) = p; TUPLE (ns) = tup; NEXT (ns) = *sl; *sl = ns; } } /** @brief Scope_check. @param top Top of scope chain. @param mask What to check. @param dest Level to check against. @return Whether errors were detected. **/ static BOOL_T scope_check (SCOPE_T * top, int mask, int dest) { SCOPE_T *s; int errors = 0; /* Transient names cannot be stored */ if (mask & TRANSIENT) { for (s = top; s != NO_SCOPE; FORWARD (s)) { if (TRANSIENT (&TUPLE (s)) & TRANSIENT) { diagnostic_node (A68_ERROR, WHERE (s), ERROR_TRANSIENT_NAME); STATUS_SET (WHERE (s), SCOPE_ERROR_MASK); errors++; } } } for (s = top; s != NO_SCOPE; FORWARD (s)) { if (dest < LEVEL (&TUPLE (s)) && ! STATUS_TEST (WHERE (s), SCOPE_ERROR_MASK)) { /* Potential scope violations */ MOID_T *sw = MOID (WHERE (s)); if (sw != NO_MOID) { if (IS (sw, REF_SYMBOL) || IS (sw, PROC_SYMBOL) || IS (sw, FORMAT_SYMBOL) || IS (sw, UNION_SYMBOL)) { diagnostic_node (A68_WARNING, WHERE (s), WARNING_SCOPE_STATIC, MOID (WHERE (s)), ATTRIBUTE (WHERE (s))); } } STATUS_SET (WHERE (s), SCOPE_ERROR_MASK); errors++; } } return ((BOOL_T) (errors == 0)); } /** @brief Scope_check_multiple. @param top Top of scope chain. @param mask What to check. @param dest Level to check against. @return Whether error. **/ static BOOL_T scope_check_multiple (SCOPE_T * top, int mask, SCOPE_T * dest) { BOOL_T no_err = A68_TRUE; for (; dest != NO_SCOPE; FORWARD (dest)) { no_err &= scope_check (top, mask, LEVEL (&TUPLE (dest))); } return (no_err); } /** @brief Check_identifier_usage. @param t Tag. @param p Node in syntax tree. **/ 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) { diagnostic_node (A68_WARNING, p, WARNING_UNINITIALISED); } check_identifier_usage (t, SUB (p)); } } /** @brief Scope_find_youngest_outside. @param s Chain to link into. @param treshold Threshold level. @return Youngest tuple 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); } /** @brief Scope_find_youngest. @param s Chain to link into. @return Youngest tuple outside. **/ static TUPLE_T scope_find_youngest (SCOPE_T * s) { return (scope_find_youngest_outside (s, A68_MAX_INT)); } /* Routines for determining scope of ROUTINE TEXT or FORMAT TEXT */ /** @brief Get_declarer_elements. @param p Node in syntax tree. @param r Chain to link into. @param no_ref Whether no REF seen yet. **/ static void get_declarer_elements (NODE_T * p, SCOPE_T ** r, BOOL_T 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 (p, REF_SYMBOL)) { get_declarer_elements (NEXT (p), r, A68_FALSE); } else if (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); } } } /** @brief Gather_scopes_for_youngest. @param p Node in syntax tree. @param s Chain to link into. **/ static void gather_scopes_for_youngest (NODE_T * p, SCOPE_T ** s) { for (; p != NO_NODE; FORWARD (p)) { if ((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 (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, A68_TRUE); } else { gather_scopes_for_youngest (SUB (p), s); } } } /** @brief Get_youngest_environs. @param p Node in syntax tree. **/ static void get_youngest_environs (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (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)); } } } /** @brief Bind_scope_to_tag. @param p Node in syntax tree. **/ static void bind_scope_to_tag (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, DEFINING_IDENTIFIER) && MOID (p) == MODE (FORMAT)) { if (IS (NEXT_NEXT (p), FORMAT_TEXT)) { SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p))); SCOPE_ASSIGNED (TAX (p)) = A68_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)) = A68_TRUE; } return; } else { bind_scope_to_tag (SUB (p)); } } } /** @brief Bind_scope_to_tags. @param p Node in syntax tree. **/ static void bind_scope_to_tags (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { if (is_one_of (p, PROCEDURE_DECLARATION, IDENTITY_DECLARATION, STOP)) { bind_scope_to_tag (SUB (p)); } else { bind_scope_to_tags (SUB (p)); } } } /** @brief Scope_bounds. @param p Node in syntax tree. **/ 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)); } } } /** @brief Scope_declarer. @param p Node in syntax tree. **/ 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 (p, REF_SYMBOL)) { scope_declarer (NEXT (p)); } else if (is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP)) { ; } else { scope_declarer (SUB (p)); scope_declarer (NEXT (p)); } } } /** @brief Scope_identity_declaration. @param p Node in syntax tree. **/ 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)) = A68_TRUE; } STATUS_SET (unit, INTERRUPTIBLE_MASK); return; } } } /** @brief Scope_variable_declaration. @param p Node in syntax tree. **/ 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 (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)); STATUS_SET (unit, INTERRUPTIBLE_MASK); return; } } } } /** @brief Scope_procedure_declaration. @param p Node in syntax tree. **/ static void scope_procedure_declaration (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { scope_procedure_declaration (SUB (p)); if (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)); STATUS_SET (unit, INTERRUPTIBLE_MASK); return; } } } /** @brief Scope_declaration_list. @param p Node in syntax tree. **/ 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 (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)); } } } /** @brief Scope_arguments. @param p Node in syntax tree. **/ 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)); } } } /** @brief Is_coercion. @param p Node in syntax tree. **/ BOOL_T 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 (A68_TRUE); } default: { return (A68_FALSE); } } } else { return (A68_FALSE); } } /** @brief Scope_coercion. @param p Node in syntax tree. @param s Chain to link into. **/ 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); (void) scope_check (z, TRANSIENT, LEX_LEVEL (p)); scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT)); } else { scope_coercion (SUB (p), s); } } else { scope_statement (p, s); } } /** @brief Scope_format_text. @param p Node in syntax tree. @param s Chain to link into. **/ 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); } } } /** @brief Scope_operand. @param p Node in syntax tree. @param s Chain to link into. **/ 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); } } /** @brief Scope_formula. @param p Node in syntax tree. @param s Chain to link into. **/ 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; } /** @brief Scope_routine_text. @param p Node in syntax tree. @param s Chain to link into. **/ static void scope_routine_text (NODE_T * p, SCOPE_T ** s) { NODE_T *q = SUB (p), *routine = (IS (q, PARAMETER_PACK) ? NEXT (q) : q); SCOPE_T *x = NO_SCOPE; TUPLE_T routine_tuple; scope_statement (NEXT_NEXT (routine), &x); (void) scope_check (x, TRANSIENT, LEX_LEVEL (p)); routine_tuple = scope_make_tuple (YOUNGEST_ENVIRON (TAX (p)), NOT_TRANSIENT); scope_add (s, p, routine_tuple); } /** @brief Scope_statement. @param p Node in syntax tree. @param s Chain to link into. **/ static void scope_statement (NODE_T * p, SCOPE_T ** s) { if (is_coercion (p)) { scope_coercion (p, s); } else if (is_one_of (p, PRIMARY, SECONDARY, TERTIARY, UNIT, STOP)) { scope_statement (SUB (p), s); } else if (is_one_of (p, DENOTATION, NIHIL, STOP)) { scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT)); } else if (IS (p, IDENTIFIER)) { if (IS (MOID (p), REF_SYMBOL)) { 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)) == A68_TRUE) { scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT)); } else if (MOID (p) == MODE (FORMAT) && SCOPE_ASSIGNED (TAX (p)) == A68_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 (m, REF_SYMBOL)) { 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 (SUB (m), FLEX_SYMBOL)) { scope_add (s, SUB (p), scope_make_tuple (LEX_LEVEL (p), TRANSIENT)); } scope_bounds (SUB (NEXT_SUB (p))); } if (IS (MOID (p), REF_SYMBOL)) { 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 (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, DIAGONAL_FUNCTION)) { NODE_T *q = SUB (p); SCOPE_T *ns = NO_SCOPE; if (IS (q, TERTIARY)) { scope_statement (SUB (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); ns = NO_SCOPE; FORWARD (q); } scope_statement (SUB_NEXT (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); scope_add (s, p, scope_find_youngest (ns)); } else if (IS (p, TRANSPOSE_FUNCTION)) { NODE_T *q = SUB (p); SCOPE_T *ns = NO_SCOPE; scope_statement (SUB_NEXT (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); scope_add (s, p, scope_find_youngest (ns)); } else if (IS (p, ROW_FUNCTION)) { NODE_T *q = SUB (p); SCOPE_T *ns = NO_SCOPE; if (IS (q, TERTIARY)) { scope_statement (SUB (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); ns = NO_SCOPE; FORWARD (q); } scope_statement (SUB_NEXT (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); scope_add (s, p, scope_find_youngest (ns)); } else if (IS (p, COLUMN_FUNCTION)) { NODE_T *q = SUB (p); SCOPE_T *ns = NO_SCOPE; if (IS (q, TERTIARY)) { scope_statement (SUB (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); ns = NO_SCOPE; FORWARD (q); } scope_statement (SUB_NEXT (q), &ns); (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (q)); scope_add (s, p, scope_find_youngest (ns)); } 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 (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 (is_one_of (p, JUMP, SKIP, STOP)) { ; } } /** @brief Scope_statement_list. @param p Node in syntax tree. @param s Chain to link into. **/ static void scope_statement_list (NODE_T * p, SCOPE_T ** s) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNIT)) { STATUS_SET (p, INTERRUPTIBLE_MASK); scope_statement (p, s); } else { scope_statement_list (SUB (p), s); } } } /** @brief Scope_serial_clause. @param p Node in syntax tree. @param s Chain to link into. @param terminator Whether unit terminates clause. **/ static void scope_serial_clause (NODE_T * p, SCOPE_T ** s, BOOL_T terminator) { if (p != NO_NODE) { if (IS (p, INITIALISER_SERIES)) { scope_serial_clause (SUB (p), s, A68_FALSE); scope_serial_clause (NEXT (p), s, terminator); } else if (IS (p, DECLARATION_LIST)) { scope_declaration_list (SUB (p)); } else if (is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP)) { scope_serial_clause (NEXT (p), s, terminator); } else if (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, A68_TRUE); } else { scope_serial_clause (SUB (p), s, A68_FALSE); } } else { scope_serial_clause (SUB (p), s, A68_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)) { STATUS_SET (p, INTERRUPTIBLE_MASK); if (terminator) { scope_statement (p, s); } else { scope_statement (p, NO_VAR); } } } } /** @brief Scope_closed_clause. @param p Node in syntax tree. @param s Chain to link into. **/ 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, A68_TRUE); } else if (is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP)) { scope_closed_clause (NEXT (p), s); } } } /** @brief Scope_collateral_clause. @param p Node in syntax tree. @param s Chain to link into. **/ static void scope_collateral_clause (NODE_T * p, SCOPE_T ** s) { if (p != NO_NODE) { if (!(whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP) || whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))) { scope_statement_list (p, s); } } } /** @brief Scope_conditional_clause. @param p Node in syntax tree. @param s Chain to link into. **/ static void scope_conditional_clause (NODE_T * p, SCOPE_T ** s) { scope_serial_clause (NEXT_SUB (p), NO_VAR, A68_TRUE); FORWARD (p); scope_serial_clause (NEXT_SUB (p), s, A68_TRUE); if ((FORWARD (p)) != NO_NODE) { if (is_one_of (p, ELSE_PART, CHOICE, STOP)) { scope_serial_clause (NEXT_SUB (p), s, A68_TRUE); } else if (is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP)) { scope_conditional_clause (SUB (p), s); } } } /** @brief Scope_case_clause. @param p Node in syntax tree. @param s Chain to link into. **/ static void scope_case_clause (NODE_T * p, SCOPE_T ** s) { SCOPE_T *n = NO_SCOPE; scope_serial_clause (NEXT_SUB (p), &n, A68_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 (is_one_of (p, OUT_PART, CHOICE, STOP)) { scope_serial_clause (NEXT_SUB (p), s, A68_TRUE); } else if (is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP)) { scope_case_clause (SUB (p), s); } else if (is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP)) { scope_case_clause (SUB (p), s); } } } /** @brief Scope_loop_clause. @param p Node in syntax tree. **/ static void scope_loop_clause (NODE_T * p) { if (p != NO_NODE) { if (IS (p, FOR_PART)) { scope_loop_clause (NEXT (p)); } else if (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, A68_TRUE); scope_loop_clause (NEXT (p)); } else if (is_one_of (p, DO_PART, ALT_DO_PART, STOP)) { NODE_T *do_p = NEXT_SUB (p), *un_p; if (IS (do_p, SERIAL_CLAUSE)) { scope_serial_clause (do_p, NO_VAR, A68_TRUE); un_p = NEXT (do_p); } else { un_p = do_p; } if (un_p != NO_NODE && IS (un_p, UNTIL_PART)) { scope_serial_clause (NEXT_SUB (un_p), NO_VAR, A68_TRUE); } } } } /** @brief Scope_enclosed_clause. @param p Node in syntax tree. @param s Chain to link into. **/ 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 (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 (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)); } } /** @brief Whether a symbol table contains no (anonymous) definition. @param t Symbol table. \return TRUE or FALSE **/ static BOOL_T empty_table (TABLE_T * t) { if (IDENTIFIERS (t) == NO_TAG) { return ((BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG)); } else if (PRIO (IDENTIFIERS (t)) == LOOP_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) { return ((BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG)); } else if (PRIO (IDENTIFIERS (t)) == SPECIFIER_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG) { return ((BOOL_T) (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG)); } else { return (A68_FALSE); } } /** @brief Indicate non-local environs. @param p Node in syntax tree. @param max Lex level threshold. **/ 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); } } } } } /** @brief Scope_checker. @param p Node in syntax tree. **/ void scope_checker (NODE_T * p) { /* 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); } /* syntax.c*/ algol68g-2.8/source/a68g.c0000644000175000001440000056773012223643510012154 00000000000000/** @file a68g.c @author J. Marcel van der Veer @brief Driver routines for the compiler-interpreter. @section Copyright This file is part of Algol68G - an Algol 68 compiler-interpreter. Copyright 2001-2013 J. Marcel van der Veer . @section License 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 . @section Description Algol68G is an Algol 68 compiler-interpreter. Please refer to the documentation that comes with this distribution for a detailed description of Algol68G. **/ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" int global_argc; /* Keep argc and argv for reference from A68 */ char **global_argv; BOOL_T in_execution; BYTE_T *system_stack_offset; MODES_T a68_modes; MODULE_T program; NODE_T **node_register = NO_VAR; char a68g_cmd_name[BUFFER_SIZE]; clock_t clock_res; int new_nodes, new_modes, new_postulates, new_node_infos, new_genie_infos; int stack_size; int symbol_table_count, mode_count; int term_heigth, term_width; static int max_simplout_size; static POSTULATE_T *postulates; #define EXTENSIONS 11 static char * extensions[EXTENSIONS] = { NO_TEXT, ".a68", ".A68", ".a68g", ".A68G", ".algol", ".ALGOL", ".algol68", ".ALGOL68", ".algol68g", ".ALGOL68G" }; static void announce_phase (char *); static void compiler_interpreter (void); static void default_mem_sizes (int); static void moid_to_string_2 (char *, MOID_T *, int *, NODE_T *); #if defined HAVE_COMPILER static void build_script (void); static void load_script (void); static void rewrite_script_source (void); #endif #if ! defined HAVE_SNPRINTF /* Apparently some systems do not support snprintf. This stub looks unsafe but should work with a68g. */ /* @brief Print in a fixed-length buffer. @param buf Buffer to use. @param size Size of buffer. @param fmt Format string. @return Characters printed. */ int a68g_snprintf (char *buf, size_t size, char *fmt, ...) { va_list p; int len; va_start (p, fmt); (void) vsprintf (buf, fmt, p); len = (int) strlen (buf); ABEND (len >= (int) size, "snprintf overflow", NO_TEXT); va_end (p); return (len); } #endif /** @brief Return error test from errno. @return See brief description. */ char *error_specification (void) { static char txt[BUFFER_SIZE]; if (errno == 0) { ASSERT (snprintf (txt, SNPRINTF_SIZE, "no information") >= 0); } else { ASSERT (snprintf (txt, SNPRINTF_SIZE, "%s", strerror (errno)) >= 0); } if (strlen (txt) > 0) { txt[0] = TO_LOWER (txt[0]); } return (txt); } /** @brief Open a file in ~/.a68g, if possible. @param fn File name. @param mode File mode. @param new_fn Edited file name. @return Pointer to descriptor. */ FILE *a68g_fopen (char *fn, char *mode, char *new_fn) { #if defined HAVE_WIN32 || ! defined HAVE_DIRENT_H ASSERT (snprintf (new_fn, SNPRINTF_SIZE, "%s", fn) >= 0); return (fopen (new_fn, mode)); #else char dn[BUFFER_SIZE]; int rc; RESET_ERRNO; ASSERT (snprintf (dn, SNPRINTF_SIZE, "%s/%s", getenv ("HOME"), A68_DIR) >= 0); rc = mkdir (dn, (mode_t) (S_IRUSR | S_IWUSR | S_IXUSR)); if (rc == 0 || (rc == -1 && errno == EEXIST)) { struct stat status; if (stat (dn, &status) == 0 && S_ISDIR (ST_MODE (&status)) != 0) { FILE *f; ASSERT (snprintf (new_fn, SNPRINTF_SIZE, "%s/%s", dn, fn) >= 0); f = fopen (new_fn, mode); if (f != NO_FILE) { return (f); } } } ASSERT (snprintf (new_fn, SNPRINTF_SIZE, "%s", fn) >= 0); return (fopen (new_fn, mode)); #endif } /** @brief Print k bytes from z; debugging routine. @param z Byte string. @param k Length. **/ void print_bytes (BYTE_T *z, int k) { int j; for (j = 0; j < k; j ++) { printf ("%02x ", z[j]); } printf ("\n"); ASSERT (fflush (stdout) == 0); /* print_bytes */ } /** @brief Unformatted write of z to stdout. @param str Prompt. @param z Mp number to print. @param digits Precision in mp-digits. **/ void raw_write_mp (char *str, MP_T * z, int digits) { int i; printf ("\n%s", str); for (i = 1; i <= digits; i++) { printf (" %07d", (int) MP_DIGIT (z, i)); } printf (" ^ %d", (int) MP_EXPONENT (z)); printf (" status=%d", (int) MP_STATUS (z)); ASSERT (fflush (stdout) == 0); /* raw_write_mp */ } /** @brief State license of running a68g image. @param f File number to write to. **/ void state_license (FILE_T f) { #define PR(s)\ ASSERT (snprintf(output_line, SNPRINTF_SIZE, "%s\n", (s)) >= 0);\ WRITE (f, output_line); if (f == STDOUT_FILENO) { io_close_tty_line (); } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Algol 68 Genie %s\n", PACKAGE_VERSION) >= 0); WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Copyright (c) 2013 %s.\n", PACKAGE_BUGREPORT) >= 0); WRITE (f, output_line); PR (""); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "This is free software covered by the GNU General Public License.\n") >= 0); WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "There is ABSOLUTELY NO WARRANTY for Algol 68 Genie;\n") >= 0); WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n") >= 0); WRITE (f, output_line); PR ("See the GNU General Public License for more details."); PR (""); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Please report bugs to %s.\n", PACKAGE_BUGREPORT) >= 0); WRITE (f, output_line); PR (""); #undef PR } /** @brief State version of running a68g image. @param f File number to write to. **/ void state_version (FILE_T f) { if (f == STDOUT_FILENO) { io_close_tty_line (); } state_license (f); WRITELN (f, ""); #if defined HAVE_WIN32 ASSERT (snprintf (output_line, SNPRINTF_SIZE, "This is a WIN32 executable.\n") >= 0); WRITE (f, output_line); #endif #if defined HAVE_COMPILER ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Compilation is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Compilation is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_PARALLEL_CLAUSE ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Parallel-clause is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Parallel-clause is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_CURSES ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Curses is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Curses is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_REGEX_H ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Regular expressions are supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Regular expressions are not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_HTTP ASSERT (snprintf (output_line, SNPRINTF_SIZE, "TCP/IP is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "TCP/IP is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_GNU_PLOTUTILS ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU libplot is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU libplot is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_GNU_GSL ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU Scientific Library is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU Scientific Library is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined HAVE_POSTGRESQL ASSERT (snprintf (output_line, SNPRINTF_SIZE, "PostgreSQL is supported.\n") >= 0); #else ASSERT (snprintf (output_line, SNPRINTF_SIZE, "PostgreSQL is not supported.\n") >= 0); #endif WRITE (f, output_line); #if defined _CS_GNU_LIBC_VERSION && ! defined HAVE_WIN32 if (confstr (_CS_GNU_LIBC_VERSION, input_line, BUFFER_SIZE) > (size_t) 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU libc version %s.\n", input_line) >= 0); WRITE (f, output_line); } #if (defined HAVE_PARALLEL_CLAUSE && defined _CS_GNU_LIBPTHREAD_VERSION) if (confstr (_CS_GNU_LIBPTHREAD_VERSION, input_line, BUFFER_SIZE) > (size_t) 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "GNU libpthread version %s.\n", input_line) >= 0); WRITE (f, output_line); } #endif #endif } /** @brief Give brief help if someone types 'a68g --help'. @param f File number. **/ void online_help (FILE_T f) { if (f == STDOUT_FILENO) { io_close_tty_line (); } state_license (f); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "Usage: %s [options | filename]", a68g_cmd_name) >= 0); WRITELN (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "For help: %s --apropos [keyword]", a68g_cmd_name) >= 0); WRITELN (f, output_line); } /** @brief First initialisations. **/ static void init_before_tokeniser (void) { /* Heap management set-up */ init_heap (); top_keyword = NO_KEYWORD; top_token = NO_TOKEN; TOP_NODE (&program) = NO_NODE; TOP_MOID (&program) = NO_MOID; TOP_LINE (&program) = NO_LINE; STANDENV_MOID (&program) = NO_MOID; set_up_tables (); /* Various initialisations */ ERROR_COUNT (&program) = WARNING_COUNT (&program) = 0; RESET_ERRNO; } /** @brief Main entry point. @param argc Arg count. @param argv Arg string. @return Exit code. **/ int main (int argc, char *argv[]) { BYTE_T stack_offset; int argcc, k; global_argc = argc; global_argv = argv; FILE_DIAGS_FD (&program) = -1; /* Get command name and discard path */ bufcpy (a68g_cmd_name, argv[0], BUFFER_SIZE); for (k = (int) strlen (a68g_cmd_name) - 1; k >= 0; k--) { #if defined WIN32 char delim = '\\'; #else char delim = '/'; #endif if (a68g_cmd_name[k] == delim) { MOVE (&a68g_cmd_name[0], &a68g_cmd_name[k + 1], (int) strlen (a68g_cmd_name) - k + 1); k = -1; } } /* Try to read maximum line width on the terminal, used to pretty print diagnostics to same. */ a68g_getty (&term_heigth, &term_width); /* Determine clock resolution */ { clock_t t0 = clock (), t1; do { t1 = clock (); } while (t1 == t0); clock_res = (t1 - t0) / (clock_t) CLOCKS_PER_SEC; } /* Set the main thread id */ #if defined HAVE_PARALLEL_CLAUSE main_thread_id = pthread_self (); #endif heap_is_fluid = A68_TRUE; system_stack_offset = &stack_offset; init_file_entries (); if (!setjmp (RENDEZ_VOUS (&program))) { init_tty (); /* Initialise option handling */ init_options (); SOURCE_SCAN (&program) = 1; default_options (&program); default_mem_sizes (1); /* Initialise core */ stack_segment = NO_BYTE; heap_segment = NO_BYTE; handle_segment = NO_BYTE; get_stack_size (); /* Well, let's start */ TOP_REFINEMENT (&program) = NO_REFINEMENT; FILE_INITIAL_NAME (&program) = NO_TEXT; FILE_GENERIC_NAME (&program) = NO_TEXT; FILE_SOURCE_NAME (&program) = NO_TEXT; FILE_LISTING_NAME (&program) = NO_TEXT; FILE_OBJECT_NAME (&program) = NO_TEXT; FILE_LIBRARY_NAME (&program) = NO_TEXT; FILE_BINARY_NAME (&program) = NO_TEXT; FILE_PRETTY_NAME (&program) = NO_TEXT; FILE_SCRIPT_NAME (&program) = NO_TEXT; FILE_DIAGS_NAME (&program) = NO_TEXT; /* Options are processed here */ read_rc_options (); read_env_options (); /* Posix copies arguments from the command line */ if (argc <= 1) { online_help (STDOUT_FILENO); a68g_exit (EXIT_FAILURE); } for (argcc = 1; argcc < argc; argcc++) { add_option_list (&(OPTION_LIST (&program)), argv[argcc], NO_LINE); } if (!set_options (OPTION_LIST (&program), A68_TRUE)) { a68g_exit (EXIT_FAILURE); } if (OPTION_REGRESSION_TEST (&program)) { bufcpy (a68g_cmd_name, "a68g", BUFFER_SIZE); } /* Attention for --version */ if (OPTION_VERSION (&program)) { state_version (STDOUT_FILENO); } /* Start the UI */ init_before_tokeniser (); /* Running a script */ #if defined HAVE_COMPILER if (OPTION_RUN_SCRIPT (&program)) { load_script (); } #endif /* We translate the program */ if (FILE_INITIAL_NAME (&program) == NO_TEXT || strlen (FILE_INITIAL_NAME (&program)) == 0) { SCAN_ERROR (!OPTION_VERSION (&program), NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE); } else { compiler_interpreter (); } a68g_exit (ERROR_COUNT (&program) == 0 ? EXIT_SUCCESS : EXIT_FAILURE); return (EXIT_SUCCESS); } else { diagnostics_to_terminal (TOP_LINE (&program), A68_ALL_DIAGNOSTICS); a68g_exit (EXIT_FAILURE); return (EXIT_FAILURE); } } /** @brief Test extension and strip. @param ext Extension to try. @return Whether stripped. **/ static BOOL_T strip_extension (char * ext) { int nlen, xlen; if (ext == NO_TEXT) { return (A68_FALSE); } nlen = (int) strlen (FILE_SOURCE_NAME (&program)); xlen = (int) strlen (ext); if (nlen > xlen && strcmp (&(FILE_SOURCE_NAME (&program)[nlen - xlen]), ext) == 0) { char *fn = (char *) get_heap_space ((size_t) (nlen + 1)); bufcpy (fn, FILE_SOURCE_NAME (&program), nlen); fn[nlen - xlen] = NULL_CHAR; FILE_GENERIC_NAME (&program) = new_string (fn, NO_TEXT); return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Try opening with an extension. **/ static void open_with_extensions (void) { int k; FILE_SOURCE_FD (&program) = -1; for (k = 0; k < EXTENSIONS && FILE_SOURCE_FD (&program) == -1; k ++) { int len; char * fn; if (extensions[k] == NO_TEXT) { len = (int) strlen (FILE_INITIAL_NAME (&program)) + 1; fn = (char *) get_heap_space ((size_t) len); bufcpy (fn, FILE_INITIAL_NAME (&program), len); } else { len = (int) strlen (FILE_INITIAL_NAME (&program)) + (int) strlen (extensions[k]) + 1; fn = (char *) get_heap_space ((size_t) len); bufcpy (fn, FILE_INITIAL_NAME (&program), len); bufcat (fn, extensions[k], len); } FILE_SOURCE_FD (&program) = open (fn, O_RDONLY | O_BINARY); if (FILE_SOURCE_FD (&program) != -1) { int l; BOOL_T cont = A68_TRUE; FILE_SOURCE_NAME (&program) = new_string (fn, NO_TEXT); FILE_GENERIC_NAME (&program) = new_string (fn, NO_TEXT); for (l = 0; l < EXTENSIONS && cont; l ++) { if (strip_extension (extensions[l])) { cont = A68_FALSE; } } } } } /** @brief Pretty print memory size. **/ char *pretty_size (int k) { if (k >= 10 * MEGABYTE) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%dM", k / MEGABYTE) >= 0); } else if (k >= 10 * KILOBYTE) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%dk", k / KILOBYTE) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%d", k) >= 0); } return (edit_line); } /** @brief Verbose statistics, only useful when debugging a68g. **/ static void verbosity (void) { ; } /** @brief Drives compilation and interpretation. **/ static void compiler_interpreter (void) { int k, len, num; BOOL_T path_set = A68_FALSE; BOOL_T emitted = A68_FALSE; TREE_LISTING_SAFE (&program) = A68_FALSE; CROSS_REFERENCE_SAFE (&program) = A68_FALSE; in_execution = A68_FALSE; new_nodes = 0; new_modes = 0; new_postulates = 0; new_node_infos = 0; new_genie_infos = 0; init_postulates (); /* File set-up */ SCAN_ERROR (FILE_INITIAL_NAME (&program) == NO_TEXT, NO_LINE, NO_TEXT, ERROR_NO_SOURCE_FILE); FILE_BINARY_OPENED (&program) = A68_FALSE; FILE_BINARY_WRITEMOOD (&program) = A68_TRUE; FILE_LIBRARY_OPENED (&program) = A68_FALSE; FILE_LIBRARY_WRITEMOOD (&program) = A68_TRUE; FILE_LISTING_OPENED (&program) = A68_FALSE; FILE_LISTING_WRITEMOOD (&program) = A68_TRUE; FILE_OBJECT_OPENED (&program) = A68_FALSE; FILE_OBJECT_WRITEMOOD (&program) = A68_TRUE; FILE_PRETTY_OPENED (&program) = A68_FALSE; FILE_SCRIPT_OPENED (&program) = A68_FALSE; FILE_SCRIPT_WRITEMOOD (&program) = A68_FALSE; FILE_SOURCE_OPENED (&program) = A68_FALSE; FILE_SOURCE_WRITEMOOD (&program) = A68_FALSE; FILE_DIAGS_OPENED (&program) = A68_FALSE; FILE_DIAGS_WRITEMOOD (&program) = A68_TRUE; /* Open the source file. Open it for binary reading for systems that require so (Win32). Accept various silent extensions. */ errno = 0; FILE_SOURCE_NAME (&program) = NO_TEXT; FILE_GENERIC_NAME (&program) = NO_TEXT; open_with_extensions (); if (FILE_SOURCE_FD (&program) == -1) { scan_error (NO_LINE, NO_TEXT, ERROR_SOURCE_FILE_OPEN); } ABEND (FILE_SOURCE_NAME (&program) == NO_TEXT, "no source file name", NO_TEXT); ABEND (FILE_GENERIC_NAME (&program) == NO_TEXT, "no generic file name", NO_TEXT); /* Isolate the path name */ FILE_PATH (&program) = new_string (FILE_GENERIC_NAME (&program), NO_TEXT); path_set = A68_FALSE; for (k = (int) strlen (FILE_PATH (&program)); k >= 0 && path_set == A68_FALSE; k--) { #if defined WIN32 char delim = '\\'; #else char delim = '/'; #endif if (FILE_PATH (&program)[k] == delim) { FILE_PATH (&program)[k + 1] = NULL_CHAR; path_set = A68_TRUE; } } if (path_set == A68_FALSE) { FILE_PATH (&program)[0] = NULL_CHAR; } /* Object file */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (OBJECT_EXTENSION); FILE_OBJECT_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_OBJECT_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_OBJECT_NAME (&program), OBJECT_EXTENSION, len); /* Binary */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (LIBRARY_EXTENSION); FILE_BINARY_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_BINARY_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_BINARY_NAME (&program), BINARY_EXTENSION, len); /* Library file */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (LIBRARY_EXTENSION); FILE_LIBRARY_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_LIBRARY_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_LIBRARY_NAME (&program), LIBRARY_EXTENSION, len); /* Listing file */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (LISTING_EXTENSION); FILE_LISTING_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_LISTING_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_LISTING_NAME (&program), LISTING_EXTENSION, len); /* Pretty file */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (PRETTY_EXTENSION); FILE_PRETTY_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_PRETTY_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_PRETTY_NAME (&program), PRETTY_EXTENSION, len); /* Script file */ len = 1 + (int) strlen (FILE_GENERIC_NAME (&program)) + (int) strlen (SCRIPT_EXTENSION); FILE_SCRIPT_NAME (&program) = (char *) get_heap_space ((size_t) len); bufcpy (FILE_SCRIPT_NAME (&program), FILE_GENERIC_NAME (&program), len); bufcat (FILE_SCRIPT_NAME (&program), SCRIPT_EXTENSION, len); /* Tokeniser */ FILE_SOURCE_OPENED (&program) = A68_TRUE; announce_phase ("initialiser"); error_tag = (TAG_T *) new_tag (); if (ERROR_COUNT (&program) == 0) { int frame_stack_size_2 = frame_stack_size; int expr_stack_size_2 = expr_stack_size; int heap_size_2 = heap_size; int handle_pool_size_2 = handle_pool_size; BOOL_T ok; announce_phase ("tokeniser"); ok = lexical_analyser (); if (!ok || errno != 0) { diagnostics_to_terminal (TOP_LINE (&program), A68_ALL_DIAGNOSTICS); return; } /* Maybe the program asks for more memory through a PRAGMAT. We restart */ if (frame_stack_size_2 != frame_stack_size || expr_stack_size_2 != expr_stack_size || heap_size_2 != heap_size || handle_pool_size_2 != handle_pool_size) { discard_heap (); init_before_tokeniser (); SOURCE_SCAN (&program) ++; ok = lexical_analyser (); verbosity (); } if (!ok || errno != 0) { diagnostics_to_terminal (TOP_LINE (&program), A68_ALL_DIAGNOSTICS); return; } ASSERT (close (FILE_SOURCE_FD (&program)) == 0); FILE_SOURCE_OPENED (&program) = A68_FALSE; prune_echoes (OPTION_LIST (&program)); TREE_LISTING_SAFE (&program) = A68_TRUE; num = 0; renumber_nodes (TOP_NODE (&program), &num); } /* Final initialisations */ if (ERROR_COUNT (&program) == 0) { a68g_standenv = NO_TABLE; init_postulates (); mode_count = 0; make_special_mode (&MODE (HIP), mode_count++); make_special_mode (&MODE (UNDEFINED), mode_count++); make_special_mode (&MODE (ERROR), mode_count++); make_special_mode (&MODE (VACUUM), mode_count++); make_special_mode (&MODE (C_STRING), mode_count++); make_special_mode (&MODE (COLLITEM), mode_count++); make_special_mode (&MODE (SOUND_DATA), mode_count++); } /* Refinement preprocessor */ if (ERROR_COUNT (&program) == 0) { announce_phase ("preprocessor"); get_refinements (); if (ERROR_COUNT (&program) == 0) { put_refinements (); } num = 0; renumber_nodes (TOP_NODE (&program), &num); verbosity (); } /* Top-down parser */ if (ERROR_COUNT (&program) == 0) { announce_phase ("parser phase 1"); check_parenthesis (TOP_NODE (&program)); if (ERROR_COUNT (&program) == 0) { if (OPTION_BRACKETS (&program)) { substitute_brackets (TOP_NODE (&program)); } symbol_table_count = 0; a68g_standenv = new_symbol_table (NO_TABLE); LEVEL (a68g_standenv) = 0; top_down_parser (TOP_NODE (&program)); } num = 0; renumber_nodes (TOP_NODE (&program), &num); verbosity (); } /* Standard environment builder */ if (ERROR_COUNT (&program) == 0) { announce_phase ("standard environ builder"); TABLE (TOP_NODE (&program)) = new_symbol_table (a68g_standenv); make_standard_environ (); STANDENV_MOID (&program) = TOP_MOID (&program); verbosity (); } /* Bottom-up parser */ if (ERROR_COUNT (&program) == 0) { announce_phase ("parser phase 2"); preliminary_symbol_table_setup (TOP_NODE (&program)); bottom_up_parser (TOP_NODE (&program)); num = 0; renumber_nodes (TOP_NODE (&program), &num); verbosity (); } if (ERROR_COUNT (&program) == 0) { announce_phase ("parser phase 3"); bottom_up_error_check (TOP_NODE (&program)); victal_checker (TOP_NODE (&program)); if (ERROR_COUNT (&program) == 0) { finalise_symbol_table_setup (TOP_NODE (&program), 2); NEST (TABLE (TOP_NODE (&program))) = symbol_table_count = 3; reset_symbol_table_nest_count (TOP_NODE (&program)); fill_symbol_table_outer (TOP_NODE (&program), TABLE (TOP_NODE (&program))); #if defined HAVE_PARALLEL_CLAUSE set_par_level (TOP_NODE (&program), 0); #endif set_nest (TOP_NODE (&program), NO_NODE); set_proc_level (TOP_NODE (&program), 1); } num = 0; renumber_nodes (TOP_NODE (&program), &num); verbosity (); } /* Mode table builder */ if (ERROR_COUNT (&program) == 0) { announce_phase ("mode table builder"); make_moid_list (&program); verbosity (); } CROSS_REFERENCE_SAFE (&program) = A68_TRUE; /* Symbol table builder */ if (ERROR_COUNT (&program) == 0) { announce_phase ("symbol table builder"); collect_taxes (TOP_NODE (&program)); verbosity (); } /* Post parser */ if (ERROR_COUNT (&program) == 0) { announce_phase ("parser phase 4"); rearrange_goto_less_jumps (TOP_NODE (&program)); num = 0; /* renumber_nodes (TOP_NODE (&program), &num); */ verbosity (); } /* Mode checker */ if (ERROR_COUNT (&program) == 0) { announce_phase ("mode checker"); mode_checker (TOP_NODE (&program)); /* renumber_moids (TOP_MOID (&program), 0); */ verbosity (); } /* Coercion inserter */ if (ERROR_COUNT (&program) == 0) { announce_phase ("coercion enforcer"); coercion_inserter (TOP_NODE (&program)); widen_denotation (TOP_NODE (&program)); get_max_simplout_size (TOP_NODE (&program)); set_moid_sizes (TOP_MOID (&program)); assign_offsets_table (a68g_standenv); assign_offsets (TOP_NODE (&program)); assign_offsets_packs (TOP_MOID (&program)); num = 0; renumber_nodes (TOP_NODE (&program), &num); verbosity (); } /* Application checker */ if (ERROR_COUNT (&program) == 0) { announce_phase ("application checker"); mark_moids (TOP_NODE (&program)); mark_auxilliary (TOP_NODE (&program)); jumps_from_procs (TOP_NODE (&program)); warn_for_unused_tags (TOP_NODE (&program)); verbosity (); } /* Scope checker */ if (ERROR_COUNT (&program) == 0) { announce_phase ("static scope checker"); tie_label_to_serial (TOP_NODE (&program)); tie_label_to_unit (TOP_NODE (&program)); bind_routine_tags_to_tree (TOP_NODE (&program)); bind_format_tags_to_tree (TOP_NODE (&program)); scope_checker (TOP_NODE (&program)); verbosity (); } /* Portability checker */ if (ERROR_COUNT (&program) == 0) { announce_phase ("portability checker"); portcheck (TOP_NODE (&program)); verbosity (); } /* Finalise syntax tree */ if (ERROR_COUNT (&program) == 0) { num = 0; renumber_nodes (TOP_NODE (&program), &num); NEST (TABLE (TOP_NODE (&program))) = symbol_table_count = 3; reset_symbol_table_nest_count (TOP_NODE (&program)); verbosity (); } /* Compiler */ if (ERROR_COUNT (&program) == 0 && OPTION_OPTIMISE (&program)) { announce_phase ("optimiser (code generator)"); num = 0; renumber_nodes (TOP_NODE (&program), &num); node_register = (NODE_T **) get_heap_space ((size_t) num * sizeof (NODE_T)); ABEND (node_register == NO_VAR, "compiler cannot register nodes", NO_TEXT); register_nodes (TOP_NODE (&program)); FILE_OBJECT_FD (&program) = open (FILE_OBJECT_NAME (&program), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (FILE_OBJECT_FD (&program) == -1, "cannot open object file", NO_TEXT); FILE_OBJECT_OPENED (&program) = A68_TRUE; compiler (FILE_OBJECT_FD (&program)); ASSERT (close (FILE_OBJECT_FD (&program)) == 0); FILE_OBJECT_OPENED (&program) = A68_FALSE; emitted = A68_TRUE; } #if defined HAVE_COMPILER /* Only compile C if the A68 compiler found no errors (constant folder for instance) */ if (ERROR_COUNT (&program) == 0 && OPTION_OPTIMISE (&program) && !OPTION_RUN_SCRIPT (&program)) { char cmd[BUFFER_SIZE], options[BUFFER_SIZE], *optimisation, extra_inc[BUFFER_SIZE]; #if defined HAVE_USR_LOCAL_PGSQL_INCLUDE ASSERT (snprintf (extra_inc, SNPRINTF_SIZE, "-I. -I%s -I/usr/local/pgsql/include", INCLUDEDIR) >= 0); #elif defined HAVE_USR_PKG_PGSQL_INCLUDE ASSERT (snprintf (extra_inc, SNPRINTF_SIZE, "-I. -I%s -I/usr/pkg/pgsql/include", INCLUDEDIR) >= 0); #elif defined HAVE_OPT_LOCAL_PGSQL_INCLUDE ASSERT (snprintf (extra_inc, SNPRINTF_SIZE, "-I. -I%s -I/opt/local/pgsql/include", INCLUDEDIR) >= 0); #else ASSERT (snprintf (extra_inc, SNPRINTF_SIZE, "-I. -I%s", INCLUDEDIR) >= 0); #endif switch (OPTION_OPT_LEVEL (&program)) { case 0: { optimisation = "-O0"; break; } case 1: { optimisation = "-O1"; break; } case 2: { optimisation = "-O2"; break; } case 3: { optimisation = "-O3"; break; } default: { optimisation = "-O2"; break; } } if (OPTION_RERUN (&program) == A68_FALSE) { announce_phase ("optimiser (code compiler)"); /*-------------------------------------------------------------+ | Build shared library using gcc. | | TODO: One day this should be all portable between platforms. | +-------------------------------------------------------------*/ /* Compilation on Linux, FreeBSD or NetBSD using gcc */ #if (defined HAVE_LINUX || defined HAVE_FREEBSD || defined HAVE_NETBSD) #if defined HAVE_TUNING ASSERT (snprintf (options, SNPRINTF_SIZE, "%s %s %s -g", extra_inc, optimisation, HAVE_TUNING) >= 0); #else ASSERT (snprintf (options, SNPRINTF_SIZE, "%s %s -g", extra_inc, optimisation) >= 0); #endif #if defined HAVE_PIC bufcat (options, " ", BUFFER_SIZE); bufcat (options, HAVE_PIC, BUFFER_SIZE); #endif ASSERT (snprintf (cmd, SNPRINTF_SIZE, "gcc %s -c -o \"%s\" \"%s\"", options, FILE_BINARY_NAME (&program), FILE_OBJECT_NAME (&program)) >= 0); if (OPTION_VERBOSE (&program)) { WRITELN (STDOUT_FILENO, cmd); } ABEND (system (cmd) != 0, "cannot compile", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "ld -export-dynamic -shared -o \"%s\" \"%s\"", FILE_LIBRARY_NAME (&program), FILE_BINARY_NAME (&program)) >= 0); if (OPTION_VERBOSE (&program)) { WRITELN (STDOUT_FILENO, cmd); } ABEND (system (cmd) != 0, "cannot link", cmd); ABEND (remove (FILE_BINARY_NAME (&program)) != 0, "cannot remove", cmd); /* Compilation on Mac OS X using gcc */ #elif defined HAVE_MAC_OS_X #if defined HAVE_TUNING ASSERT (snprintf (options, SNPRINTF_SIZE, "%s %s %s -g -fno-common -dynamic", extra_inc, optimisation, HAVE_TUNING) >= 0); #else ASSERT (snprintf (options, SNPRINTF_SIZE, "%s %s -g -fno-common -dynamic", extra_inc, optimisation) >= 0); #endif #if defined HAVE_PIC bufcat (options, " ", BUFFER_SIZE); bufcat (options, HAVE_PIC, BUFFER_SIZE); #endif ASSERT (snprintf (cmd, SNPRINTF_SIZE, "gcc %s -c -o \"%s\" \"%s\"", options, FILE_BINARY_NAME (&program), FILE_OBJECT_NAME (&program)) >= 0); if (OPTION_VERBOSE (&program)) { WRITELN (STDOUT_FILENO, cmd); } ABEND (system (cmd) != 0, "cannot compile", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "libtool -dynamic -flat_namespace -undefined suppress -o %s %s", FILE_LIBRARY_NAME (&program), FILE_BINARY_NAME (&program)) >= 0); if (OPTION_VERBOSE (&program)) { WRITELN (STDOUT_FILENO, cmd); } ABEND (system (cmd) != 0, "cannot link", cmd); ABEND (remove (FILE_BINARY_NAME (&program)) != 0, "cannot remove", cmd); #endif } verbosity (); } #else if (OPTION_OPTIMISE (&program)) { diagnostic_node (A68_WARNING | A68_FORCE_DIAGNOSTICS, TOP_NODE (&program), WARNING_OPTIMISATION); } #endif /* Indenter */ if (ERROR_COUNT (&program) == 0 && OPTION_PRETTY (&program)) { announce_phase ("indenter"); indenter (&program); verbosity (); } /* Interpreter */ diagnostics_to_terminal (TOP_LINE (&program), A68_ALL_DIAGNOSTICS); if (ERROR_COUNT (&program) == 0 && OPTION_COMPILE (&program) == A68_FALSE && (OPTION_CHECK_ONLY (&program) ? OPTION_RUN (&program) : A68_TRUE)) { #if defined HAVE_COMPILER void * compile_lib; #endif #if defined HAVE_COMPILER if (OPTION_RUN_SCRIPT (&program)) { rewrite_script_source (); } #endif if (OPTION_DEBUG (&program)) { state_license (STDOUT_FILENO); } #if defined HAVE_COMPILER if (OPTION_OPTIMISE (&program)) { char libname[BUFFER_SIZE]; void * a68g_lib; struct stat srcstat, objstat; int ret; announce_phase ("dynamic linker"); ASSERT (snprintf (libname, SNPRINTF_SIZE, "./%s", FILE_LIBRARY_NAME (&program)) >= 0); /* Check whether we are doing something rash */ ret = stat (FILE_SOURCE_NAME (&program), &srcstat); ABEND (ret != 0, "cannot stat", FILE_SOURCE_NAME (&program)); ret = stat (libname, &objstat); ABEND (ret != 0, "cannot stat", libname); if (OPTION_RERUN (&program)) { ABEND (ST_MTIME (&srcstat) > ST_MTIME (&objstat), "source file is younger than library", "do not specify RERUN"); } /* First load a68g itself so compiler code can resolve a68g symbols */ a68g_lib = dlopen (NULL, RTLD_NOW | RTLD_GLOBAL); ABEND (a68g_lib == NULL, "compiler cannot resolve a68g symbols", dlerror ()); /* Then load compiler code */ compile_lib = dlopen (libname, RTLD_NOW | RTLD_GLOBAL); ABEND (compile_lib == NULL, "compiler cannot resolve symbols", dlerror ()); } else { compile_lib = NULL; } announce_phase ("genie"); genie (compile_lib); /* Unload compiler library */ if (OPTION_OPTIMISE (&program)) { int ret = dlclose (compile_lib); ABEND (ret != 0, "cannot close shared library", dlerror ()); } #else genie (NO_NODE); #endif /* Free heap allocated by genie */ free_genie_heap (TOP_NODE (&program)); /* Normal end of program */ diagnostics_to_terminal (TOP_LINE (&program), A68_RUNTIME_ERROR); if (OPTION_DEBUG (&program) || OPTION_TRACE (&program) || OPTION_CLOCK (&program)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\nGenie finished in %.2f seconds\n", seconds () - cputime_0) >= 0); WRITE (STDOUT_FILENO, output_line); } verbosity (); } /* Setting up listing file */ if (OPTION_MOID_LISTING (&program) || OPTION_TREE_LISTING (&program) || OPTION_SOURCE_LISTING (&program) || OPTION_OBJECT_LISTING (&program) || OPTION_STATISTICS_LISTING (&program)) { FILE_LISTING_FD (&program) = open (FILE_LISTING_NAME (&program), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (FILE_LISTING_FD (&program) == -1, "cannot open listing file", NO_TEXT); FILE_LISTING_OPENED (&program) = A68_TRUE; } else { FILE_LISTING_OPENED (&program) = A68_FALSE; } /* Write listing */ if (FILE_LISTING_OPENED (&program)) { heap_is_fluid = A68_TRUE; write_listing_header (); write_source_listing (); write_tree_listing (); if (ERROR_COUNT (&program) == 0 && OPTION_OPTIMISE (&program)) { write_object_listing (); } write_listing (); ASSERT (close (FILE_LISTING_FD (&program)) == 0); FILE_LISTING_OPENED (&program) = A68_FALSE; verbosity (); } /* Cleaning up the intermediate files */ #if defined HAVE_COMPILER if (OPTION_RUN_SCRIPT (&program) && !OPTION_KEEP (&program)) { if (emitted) { ABEND (remove (FILE_OBJECT_NAME (&program)) != 0, "cannot remove", FILE_OBJECT_NAME (&program)); } ABEND (remove (FILE_SOURCE_NAME (&program)) != 0, "cannot remove", FILE_SOURCE_NAME (&program)); ABEND (remove (FILE_LIBRARY_NAME (&program)) != 0, "cannot remove", FILE_LIBRARY_NAME (&program)); } else if (OPTION_COMPILE (&program) && !OPTION_KEEP (&program)) { build_script (); if (emitted) { ABEND (remove (FILE_OBJECT_NAME (&program)) != 0, "cannot remove", FILE_OBJECT_NAME (&program)); } ABEND (remove (FILE_LIBRARY_NAME (&program)) != 0, "cannot remove", FILE_LIBRARY_NAME (&program)); } else if (OPTION_OPTIMISE (&program) && !OPTION_KEEP (&program)) { if (emitted) { ABEND (remove (FILE_OBJECT_NAME (&program)) != 0, "cannot remove", FILE_OBJECT_NAME (&program)); } } else if (OPTION_RERUN (&program) && !OPTION_KEEP (&program)) { if (emitted) { ABEND (remove (FILE_OBJECT_NAME (&program)) != 0, "cannot remove", FILE_OBJECT_NAME (&program)); } } #endif } /** @brief Exit a68g in an orderly manner. @param code Exit code. **/ void a68g_exit (int code) { /* char name[BUFFER_SIZE]; bufcpy (name, ".", BUFFER_SIZE); bufcat (name, a68g_cmd_name, BUFFER_SIZE); bufcat (name, ".x", BUFFER_SIZE); (void) (remove (name)); */ /* Close unclosed files, remove temp files */ free_file_entries (); /* Close the terminal */ io_close_tty_line (); #if defined HAVE_CURSES /* "curses" might still be open if it was not closed from A68, or the program was interrupted, or a runtime error occured. That wreaks havoc on your terminal */ genie_curses_end (NO_NODE); #endif exit (code); } /** @brief Start book keeping for a phase. @param t Name of phase. **/ static void announce_phase (char *t) { if (OPTION_VERBOSE (&program)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s: %s", a68g_cmd_name, t) >= 0); io_close_tty_line (); WRITE (STDOUT_FILENO, output_line); } } #if defined HAVE_COMPILER /** @brief Build shell script from program. **/ static void build_script (void) { int ret; FILE_T script, source; LINE_T *sl; char cmd[BUFFER_SIZE], *strop; #if ! defined HAVE_COMPILER return; #endif announce_phase ("script builder"); /* Flatten the source file */ ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SOURCE_NAME (&program)) >= 0); source = open (cmd, O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (source == -1, "cannot flatten source file", cmd); for (sl = TOP_LINE (&program); sl != NO_LINE; FORWARD (sl)) { if (strlen (STRING (sl)) == 0 || (STRING (sl))[strlen (STRING (sl)) - 1] != NEWLINE_CHAR) { ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s\n%d\n%s\n", FILENAME (sl), NUMBER (sl), STRING (sl)) >= 0); } else { ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s\n%d\n%s", FILENAME (sl), NUMBER (sl), STRING (sl)) >= 0); } WRITE (source, cmd); } ASSERT (close (source) == 0); /* Compress source and library */ ASSERT (snprintf (cmd, SNPRINTF_SIZE, "cp %s %s.%s", FILE_LIBRARY_NAME (&program), HIDDEN_TEMP_FILE_NAME, FILE_LIBRARY_NAME (&program)) >= 0); ret = system (cmd); ABEND (ret != 0, "cannot copy", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "tar czf %s.%s.tgz %s.%s %s.%s", HIDDEN_TEMP_FILE_NAME, FILE_GENERIC_NAME (&program), HIDDEN_TEMP_FILE_NAME, FILE_SOURCE_NAME (&program), HIDDEN_TEMP_FILE_NAME, FILE_LIBRARY_NAME (&program)) >= 0); ret = system (cmd); ABEND (ret != 0, "cannot compress", cmd); /* Compose script */ ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SCRIPT_NAME (&program)) >= 0); script = open (cmd, O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (script == -1, "cannot compose script file", cmd); strop = ""; if (OPTION_STROPPING (&program) == QUOTE_STROPPING) { strop = "--run-quote-script"; } else { strop = "--run-script"; } if (OPTION_LOCAL (&program)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "#! ./a68g %s\n", strop) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "#! %s/a68g %s\n", BINDIR, strop) >= 0); } WRITE (script, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s\n--verify \"%s\"\n", FILE_GENERIC_NAME (&program), PACKAGE_STRING) >= 0); WRITE (script, output_line); ASSERT (close (script) == 0); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "cat %s.%s %s.%s.tgz > %s", HIDDEN_TEMP_FILE_NAME, FILE_SCRIPT_NAME (&program), HIDDEN_TEMP_FILE_NAME, FILE_GENERIC_NAME (&program), FILE_SCRIPT_NAME (&program)) >= 0); ret = system (cmd); ABEND (ret != 0, "cannot compose script file", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s", FILE_SCRIPT_NAME (&program)) >= 0); ret = chmod (cmd, (__mode_t) (S_IRUSR | S_IWUSR | S_IXUSR | S_IRGRP | S_IROTH)); /* -rwx-r--r-- */ ABEND (ret != 0, "cannot compose script file", cmd); ABEND (ret != 0, "cannot remove", cmd); /* Clean up */ ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s.tgz", HIDDEN_TEMP_FILE_NAME, FILE_GENERIC_NAME (&program)) >= 0); ret = remove (cmd); ABEND (ret != 0, "cannot remove", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SOURCE_NAME (&program)) >= 0); ret = remove (cmd); ABEND (ret != 0, "cannot remove", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_LIBRARY_NAME (&program)) >= 0); ret = remove (cmd); ABEND (ret != 0, "cannot remove", cmd); ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, FILE_SCRIPT_NAME (&program)) >= 0); ret = remove (cmd); ABEND (ret != 0, "cannot remove", cmd); } #endif #if defined HAVE_COMPILER /** @brief Load program from shell script . **/ static void load_script (void) { int k; FILE_T script; char cmd[BUFFER_SIZE], ch; #if ! defined HAVE_COMPILER return; #endif announce_phase ("script loader"); /* Decompress the archive */ ASSERT (snprintf (cmd, SNPRINTF_SIZE, "sed '1,3d' < %s | tar xzf -", FILE_INITIAL_NAME (&program)) >= 0); ABEND (system (cmd) != 0, "cannot decompress", cmd); /* Reread the header */ script = open (FILE_INITIAL_NAME (&program), O_RDONLY); ABEND (script == -1, "cannot open script file", cmd); /* Skip the #! a68g line */ ASSERT (io_read (script, &ch, 1) == 1); while (ch != NEWLINE_CHAR) { ASSERT (io_read (script, &ch, 1) == 1); } /* Read the generic filename */ input_line[0] = NULL_CHAR; k = 0; ASSERT (io_read (script, &ch, 1) == 1); while (ch != NEWLINE_CHAR) { input_line[k++] = ch; ASSERT (io_read (script, &ch, 1) == 1); } input_line[k] = NULL_CHAR; ASSERT (snprintf (cmd, SNPRINTF_SIZE, "%s.%s", HIDDEN_TEMP_FILE_NAME, input_line) >= 0); FILE_INITIAL_NAME (&program) = new_string (cmd, NO_TEXT); /* Read options */ input_line[0] = NULL_CHAR; k = 0; ASSERT (io_read (script, &ch, 1) == 1); while (ch != NEWLINE_CHAR) { input_line[k++] = ch; ASSERT (io_read (script, &ch, 1) == 1); } isolate_options (input_line, NO_LINE); (void) set_options (OPTION_LIST (&program), A68_FALSE); ASSERT (close (script) == 0); } #endif #if defined HAVE_COMPILER /** @brief Rewrite source for shell script . **/ static void rewrite_script_source (void) { LINE_T * ref_l = NO_LINE; FILE_T source; /* Rebuild the source file */ ASSERT (remove (FILE_SOURCE_NAME (&program)) == 0); source = open (FILE_SOURCE_NAME (&program), O_WRONLY | O_CREAT | O_TRUNC, A68_PROTECTION); ABEND (source == -1, "cannot rewrite source file", FILE_SOURCE_NAME (&program)); for (ref_l = TOP_LINE (&program); ref_l != NO_LINE; FORWARD (ref_l)) { WRITE (source, STRING (ref_l)); if (strlen (STRING (ref_l)) == 0 || (STRING (ref_l))[strlen (STRING (ref_l) - 1)] != NEWLINE_CHAR) { WRITE (source, NEWLINE_STRING); } } /* Wrap it up */ ASSERT (close (source) == 0); } #endif /* This code handles options to Algol68G. Option syntax does not follow GNU standards. Options come from: [1] A rc file (normally .a68grc). [2] The A68G_OPTIONS environment variable overrules [1]. [3] Command line options overrule [2]. [4] Pragmat items overrule [3]. */ OPTIONS_T *options; /** @brief Set default values for options. **/ void default_options (MODULE_T *p) { OPTION_NO_WARNINGS (p) = A68_TRUE; OPTION_BACKTRACE (p) = A68_FALSE; OPTION_BRACKETS (p) = A68_FALSE; OPTION_CHECK_ONLY (p) = A68_FALSE; OPTION_CLOCK (p) = A68_FALSE; OPTION_COMPILE (p) = A68_FALSE; OPTION_CROSS_REFERENCE (p) = A68_FALSE; OPTION_DEBUG (p) = A68_FALSE; OPTION_INDENT (p) = 2; OPTION_FOLD (p) = A68_FALSE; OPTION_KEEP (p) = A68_FALSE; OPTION_LOCAL (p) = A68_FALSE; OPTION_MOID_LISTING (p) = A68_FALSE; OPTION_NODEMASK (p) = (STATUS_MASK) (ASSERT_MASK | SOURCE_MASK); OPTION_OPT_LEVEL (p) = 0; OPTION_OPTIMISE (p) = A68_FALSE; OPTION_PORTCHECK (p) = A68_FALSE; OPTION_PRAGMAT_SEMA (p) = A68_TRUE; OPTION_PRETTY (p) = A68_FALSE; OPTION_QUIET (p) = A68_FALSE; OPTION_REDUCTIONS (p) = A68_FALSE; OPTION_REGRESSION_TEST (p) = A68_FALSE; OPTION_RERUN (p) = A68_FALSE; OPTION_RUN (p) = A68_FALSE; OPTION_RUN_SCRIPT (p) = A68_FALSE; OPTION_SOURCE_LISTING (p) = A68_FALSE; OPTION_STANDARD_PRELUDE_LISTING (p) = A68_FALSE; OPTION_STATISTICS_LISTING (p) = A68_FALSE; OPTION_STRICT (p) = A68_FALSE; OPTION_STROPPING (p) = UPPER_STROPPING; OPTION_TIME_LIMIT (p) = 0; OPTION_TRACE (p) = A68_FALSE; OPTION_TREE_LISTING (p) = A68_FALSE; OPTION_UNUSED (p) = A68_FALSE; OPTION_VERBOSE (p) = A68_FALSE; OPTION_VERSION (p) = A68_FALSE; OPTION_TARGET (p) = NO_TEXT; } /** @brief Error handler for options. @param l Source line. @param option Option text. @param info Info text. **/ static void option_error (LINE_T * l, char *option, char *info) { /* int k; */ ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", option) >= 0); /* for (k = 0; output_line[k] != NULL_CHAR; k++) { output_line[k] = (char) TO_LOWER (output_line[k]); } */ if (info != NO_TEXT) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "*error: %s option \"%s\"", info, output_line) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "*error: in option \"%s\"", output_line) >= 0); } scan_error (l, NO_TEXT, edit_line); } /** @brief Strip minus preceeding a string. @param p Text to strip. @return Stripped string. **/ static char *strip_sign (char *p) { while (p[0] == '-' || p[0] == '+') { p++; } return (new_string (p, NO_TEXT)); } /** @brief Add an option to the list, to be processed later. @param l Option chain to link into. @param str Option text. @param line Source line. **/ void add_option_list (OPTION_LIST_T ** l, char *str, LINE_T * line) { if (*l == NO_OPTION_LIST) { *l = (OPTION_LIST_T *) get_heap_space ((size_t) SIZE_AL (OPTION_LIST_T)); SCAN (*l) = SOURCE_SCAN (&program); STR (*l) = new_string (str, NO_TEXT); PROCESSED (*l) = A68_FALSE; LINE (*l) = line; NEXT (*l) = NO_OPTION_LIST; } else { add_option_list (&(NEXT (*l)), str, line); } } /** @brief Initialise option handler. **/ void init_options (void) { options = (OPTIONS_T *) malloc ((size_t) SIZE_AL (OPTIONS_T)); OPTION_LIST (&program) = NO_OPTION_LIST; } /** @brief Test equality of p and q, upper case letters in q are mandatory. @param p String to match. @param q Pattern. @return Whether equal. **/ static BOOL_T eq (char *p, char *q) { /* Upper case letters in 'q' are mandatory, lower case must match */ if (OPTION_PRAGMAT_SEMA (&program)) { return (match_string (p, q, '=')); } else { return (A68_FALSE); } } /** @brief Process echoes gathered in the option list. @param i Option chain. **/ void prune_echoes (OPTION_LIST_T * i) { while (i != NO_OPTION_LIST) { if (SCAN (i) == SOURCE_SCAN (&program)) { char *p = strip_sign (STR (i)); /* ECHO echoes a string */ if (eq (p, "ECHO")) { { char *car = a68g_strchr (p, '='); if (car != NO_TEXT) { io_close_tty_line (); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", &car[1]) >= 0); WRITE (STDOUT_FILENO, output_line); } else { FORWARD (i); if (i != NO_OPTION_LIST) { if (strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i != NO_OPTION_LIST) { io_close_tty_line (); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", STR (i)) >= 0); WRITE (STDOUT_FILENO, output_line); } } } } } } FORWARD (i); } } /** @brief Translate integral option argument. @param p Text. @param i Option chain. @param error Whether error. @return Argument value. **/ static int fetch_integral (char *p, OPTION_LIST_T ** i, BOOL_T * error) { LINE_T *start_l = LINE (*i); char *start_c = STR (*i); char *car = NO_TEXT, *num = NO_TEXT; int k, mult = 1; *error = A68_FALSE; /* Fetch argument */ car = a68g_strchr (p, '='); if (car == NO_TEXT) { FORWARD (*i); *error = (BOOL_T) (*i == NO_OPTION_LIST); if (!error && strcmp (STR (*i), "=") == 0) { FORWARD (*i); *error = (BOOL_T) (*i == NO_OPTION_LIST); } if (!*error) { num = STR (*i); } } else { num = &car[1]; *error = (BOOL_T) (num[0] == NULL_CHAR); } /* Translate argument into integer */ if (*error) { option_error (start_l, start_c, "integer value required by"); return (0); } else { char *suffix; RESET_ERRNO; k = (int) strtol (num, &suffix, 0); /* Accept also octal and hex */ *error = (BOOL_T) (suffix == num); if (errno != 0 || *error) { option_error (start_l, start_c, "conversion error in"); *error = A68_TRUE; } else if (k < 0) { option_error (start_l, start_c, "negative value in"); *error = A68_TRUE; } else { /* Accept suffix multipliers: 32k, 64M, 1G */ if (suffix != NO_TEXT) { switch (suffix[0]) { case NULL_CHAR: { mult = 1; break; } case 'k': case 'K': { mult = KILOBYTE; break; } case 'm': case 'M': { mult = MEGABYTE; break; } case 'g': case 'G': { mult = GIGABYTE; break; } default: { option_error (start_l, start_c, "unknown suffix in"); *error = A68_TRUE; break; } } if (suffix[0] != NULL_CHAR && suffix[1] != NULL_CHAR) { option_error (start_l, start_c, "unknown suffix in"); *error = A68_TRUE; } } } if ((double) k * (double) mult > (double) A68_MAX_INT) { errno = ERANGE; option_error (start_l, start_c, "conversion overflow in"); } return (k * mult); } } /** @brief Process options gathered in the option list. @param i Option chain. @param cmd_line Whether command line argument. @return Whether processing was successful. **/ BOOL_T set_options (OPTION_LIST_T * i, BOOL_T cmd_line) { BOOL_T go_on = A68_TRUE, name_set = A68_FALSE, skip = A68_FALSE; OPTION_LIST_T *j = i; RESET_ERRNO; while (i != NO_OPTION_LIST && go_on) { /* Once SCRIPT is processed we skip options on the command line */ if (cmd_line && skip) { FORWARD (i); } else { LINE_T *start_l = LINE (i); char *start_c = STR (i); int n = (int) strlen (STR (i)); /* Allow for spaces ending in # to have A68 comment syntax with '#!' */ while (n > 0 && (IS_SPACE((STR (i))[n - 1]) || (STR (i))[n - 1] == '#')) { (STR (i))[--n] = NULL_CHAR; } if (!(PROCESSED (i))) { /* Accept UNIX '-option [=] value' */ BOOL_T minus_sign = (BOOL_T) ((STR (i))[0] == '-'); char *p = strip_sign (STR (i)); if (!minus_sign && eq (p, "#")) { ; } else if (!minus_sign && cmd_line) { /* Item without '-'s is a filename */ if (!name_set) { FILE_INITIAL_NAME (&program) = new_string (p, NO_TEXT); name_set = A68_TRUE; } else { option_error (NO_LINE, start_c, "multiple source file names at"); } } /* Preprocessor items stop option processing */ else if (eq (p, "INCLUDE")) { go_on = A68_FALSE; } else if (eq (p, "READ")) { go_on = A68_FALSE; } else if (eq (p, "PREPROCESSOR")) { go_on = A68_FALSE; } else if (eq (p, "NOPREPROCESSOR")) { go_on = A68_FALSE; } /* EXIT stops option processing */ else if (eq (p, "EXIT")) { go_on = A68_FALSE; } /* Empty item (from specifying '-' or '--') stops option processing */ else if (eq (p, "")) { go_on = A68_FALSE; } /* FILE accepts its argument as filename */ else if (eq (p, "File") && cmd_line) { FORWARD (i); if (i != NO_OPTION_LIST && strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i != NO_OPTION_LIST) { if (!name_set) { FILE_INITIAL_NAME (&program) = new_string (STR (i), NO_TEXT); name_set = A68_TRUE; } else { option_error (start_l, start_c, "multiple source file names at"); } } else { option_error (start_l, start_c, "missing argument in"); } } /* TARGET accepts its argument as editor target */ else if (eq (p, "TArget") && cmd_line) { FORWARD (i); if (i != NO_OPTION_LIST && strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i != NO_OPTION_LIST) { OPTION_TARGET (&program) = new_string (STR (i), NO_TEXT); } else { option_error (start_l, start_c, "missing argument in"); } } /* SCRIPT takes next argument as filename. Further options on the command line are not processed, but stored */ else if (eq (p, "Script") && cmd_line) { FORWARD (i); if (i != NO_OPTION_LIST) { if (!name_set) { FILE_INITIAL_NAME (&program) = new_string (STR (i), NO_TEXT); name_set = A68_TRUE; } else { option_error (start_l, start_c, "multiple source file names at"); } } else { option_error (start_l, start_c, "missing argument in"); } skip = A68_TRUE; } /* VERIFY checks that argument is current a68g version number */ else if (eq (p, "VERIFY")) { FORWARD (i); if (i != NO_OPTION_LIST && strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i != NO_OPTION_LIST) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s verification \"%s\" does not match script verification \"%s\"", a68g_cmd_name, PACKAGE_STRING, STR (i)) >= 0); ABEND (strcmp (PACKAGE_STRING, STR (i)) != 0, new_string (output_line, NO_TEXT), "rebuild the script"); } else { option_error (start_l, start_c, "missing argument in"); } } /* HELP gives online help */ else if ((eq (p, "APropos") || eq (p, "Help") || eq (p, "INfo")) && cmd_line) { FORWARD (i); if (i != NO_OPTION_LIST && strcmp (STR (i), "=") == 0) { FORWARD (i); } if (i != NO_OPTION_LIST) { apropos (STDOUT_FILENO, NO_TEXT, STR (i)); } else { apropos (STDOUT_FILENO, NO_TEXT, "options"); } a68g_exit (EXIT_SUCCESS); } /* ECHO is treated later */ else if (eq (p, "ECHO")) { if (a68g_strchr (p, '=') == NO_TEXT) { FORWARD (i); if (i != NO_OPTION_LIST) { if (strcmp (STR (i), "=") == 0) { FORWARD (i); } } } } /* EXECUTE and PRINT execute their argument as Algol 68 text */ else if (eq (p, "Execute") || eq (p, "X") || eq (p, "Print")) { if (cmd_line == A68_FALSE) { option_error (start_l, start_c, "command-line-only"); } else if ((FORWARD (i)) != NO_OPTION_LIST) { BOOL_T error = A68_FALSE; if (strcmp (STR (i), "=") == 0) { error = (BOOL_T) ((FORWARD (i)) == NO_OPTION_LIST); } if (!error) { char name[BUFFER_SIZE], new_name[BUFFER_SIZE]; FILE *f; int s_errno = errno; bufcpy (name, HIDDEN_TEMP_FILE_NAME, BUFFER_SIZE); bufcat (name, ".cmd.a68", BUFFER_SIZE); f = a68g_fopen (name, "w", new_name); ABEND (f == NO_FILE, "cannot open temp file", NO_TEXT); errno = s_errno; if (eq (p, "Execute") || eq (p, "X")) { fprintf (f, "(%s)\n", STR (i)); } else { fprintf (f, "(print ((%s)))\n", STR (i)); } ASSERT (fclose (f) == 0); FILE_INITIAL_NAME (&program) = new_string (new_name, NO_TEXT); } else { option_error (start_l, start_c, "unit required by"); } } else { option_error (start_l, start_c, "missing argument in"); } } /* STORAGE, HEAP, HANDLES, STACK, FRAME and OVERHEAD set core allocation */ else if (eq (p, "STOrage")) { BOOL_T error = A68_FALSE; int k = fetch_integral (p, &i, &error); /* Adjust size */ if (error || errno > 0) { option_error (start_l, start_c, "conversion error in"); } else if (k > 0) { default_mem_sizes (k); } } else if (eq (p, "HEAP") || eq (p, "HANDLES") || eq (p, "STACK") || eq (p, "FRAME") || eq (p, "OVERHEAD")) { BOOL_T error = A68_FALSE; int k = fetch_integral (p, &i, &error); /* Adjust size */ if (error || errno > 0) { option_error (start_l, start_c, "conversion error in"); } else if (k > 0) { if (k < MIN_MEM_SIZE) { option_error (start_l, start_c, "value less than minimum in"); k = MIN_MEM_SIZE; } if (eq (p, "HEAP")) { heap_size = k; } else if (eq (p, "HANDLES")) { handle_pool_size = k; } else if (eq (p, "STACK")) { expr_stack_size = k; } else if (eq (p, "FRAME")) { frame_stack_size = k; } else if (eq (p, "OVERHEAD")) { storage_overhead = k; } } } /* COMPILE and NOCOMPILE switch on/off compilation */ else if (eq (p, "Compile")) { #if defined HAVE_LINUX OPTION_COMPILE (&program) = A68_TRUE; OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; OPTION_RUN_SCRIPT (&program) = A68_FALSE; #else option_error (start_l, start_c, "linux-only"); #endif } else if (eq (p, "NOCompile")) { OPTION_COMPILE (&program) = A68_FALSE; OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; OPTION_RUN_SCRIPT (&program) = A68_FALSE; } else if (eq (p, "NO-Compile")) { OPTION_COMPILE (&program) = A68_FALSE; OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; OPTION_RUN_SCRIPT (&program) = A68_FALSE; } /* OPTIMISE and NOOPTIMISE switch on/off optimisation */ else if (eq (p, "OPTimise")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; } else if (eq (p, "O0")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 0; } else if (eq (p, "O")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 1; } else if (eq (p, "O1")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 1; } else if (eq (p, "O2")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; } else if (eq (p, "O3")) { OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 3; } else if (eq (p, "NOOptimise")) { OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; } else if (eq (p, "NO-Optimise")) { OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; } else if (eq (p, "NOOptimize")) { OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; } else if (eq (p, "NO-Optimize")) { OPTION_OPTIMISE (&program) = A68_FALSE; OPTION_OPT_LEVEL (&program) = 0; } /* RUN-SCRIPT runs a comiled .sh script */ else if (eq (p, "RUN-SCRIPT")) { #if defined HAVE_LINUX FORWARD (i); if (i != NO_OPTION_LIST) { if (!name_set) { FILE_INITIAL_NAME (&program) = new_string (STR (i), NO_TEXT); name_set = A68_TRUE; } else { option_error (start_l, start_c, "multiple source file names at"); } } else { option_error (start_l, start_c, "missing argument in"); } skip = A68_TRUE; OPTION_RUN_SCRIPT (&program) = A68_TRUE; OPTION_COMPILE (&program) = A68_FALSE; OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; #else option_error (start_l, start_c, "linux-only"); #endif } /* RUN-QUOTE-SCRIPT runs a comiled .sh script */ else if (eq (p, "RUN-QUOTE-SCRIPT")) { #if defined HAVE_LINUX FORWARD (i); if (i != NO_OPTION_LIST) { if (!name_set) { FILE_INITIAL_NAME (&program) = new_string (STR (i), NO_TEXT); name_set = A68_TRUE; } else { option_error (start_l, start_c, "multiple source file names at"); } } else { option_error (start_l, start_c, "missing argument in"); } skip = A68_TRUE; OPTION_RUN_SCRIPT (&program) = A68_TRUE; OPTION_STROPPING (&program) = QUOTE_STROPPING; OPTION_COMPILE (&program) = A68_FALSE; OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; #else option_error (start_l, start_c, "linux-only"); #endif } /* RERUN re-uses an existing .so file */ else if (eq (p, "RERUN")) { OPTION_COMPILE (&program) = A68_FALSE; OPTION_RERUN (&program) = A68_TRUE; OPTION_OPTIMISE (&program) = A68_TRUE; OPTION_OPT_LEVEL (&program) = 2; } /* KEEP and NOKEEP switch off/on object file deletion */ else if (eq (p, "KEEP")) { OPTION_KEEP (&program) = A68_TRUE; } else if (eq (p, "NOKEEP")) { OPTION_KEEP (&program) = A68_FALSE; } else if (eq (p, "NO-KEEP")) { OPTION_KEEP (&program) = A68_FALSE; } /* BRACKETS extends Algol 68 syntax for brackets */ else if (eq (p, "BRackets")) { OPTION_BRACKETS (&program) = A68_TRUE; } /* PRETTY and INDENT perform basic pretty printing. This is meant for synthetic code. */ else if (eq (p, "PRETty-print")) { OPTION_PRETTY (&program) = A68_TRUE; OPTION_CHECK_ONLY (&program) = A68_TRUE; } else if (eq (p, "INDENT")) { OPTION_PRETTY (&program) = A68_TRUE; OPTION_CHECK_ONLY (&program) = A68_TRUE; } /* FOLD performs constant folding in basic lay-out formatting. */ else if (eq (p, "FOLD")) { OPTION_INDENT (&program) = A68_TRUE; OPTION_FOLD (&program) = A68_TRUE; OPTION_CHECK_ONLY (&program) = A68_TRUE; } /* REDUCTIONS gives parser reductions.*/ else if (eq (p, "REDuctions")) { OPTION_REDUCTIONS (&program) = A68_TRUE; } /* QUOTESTROPPING sets stropping to quote stropping */ else if (eq (p, "QUOTEstropping")) { OPTION_STROPPING (&program) = QUOTE_STROPPING; } else if (eq (p, "QUOTE-stropping")) { OPTION_STROPPING (&program) = QUOTE_STROPPING; } /* UPPERSTROPPING sets stropping to upper stropping, which is nowadays the expected default */ else if (eq (p, "UPPERstropping")) { OPTION_STROPPING (&program) = UPPER_STROPPING; } else if (eq (p, "UPPER-stropping")) { OPTION_STROPPING (&program) = UPPER_STROPPING; } /* CHECK and NORUN just check for syntax */ else if (eq (p, "Check") || eq (p, "NORun") || eq (p, "NO-Run")) { OPTION_CHECK_ONLY (&program) = A68_TRUE; } /* CLOCK times program execution */ else if (eq (p, "CLock")) { OPTION_CLOCK (&program) = A68_TRUE; } /* RUN overrides NORUN */ else if (eq (p, "RUN")) { OPTION_RUN (&program) = A68_TRUE; } /* MONITOR or DEBUG invokes the debugger at runtime errors */ else if (eq (p, "MONitor") || eq (p, "DEBUG")) { OPTION_DEBUG (&program) = A68_TRUE; } /* REGRESSION is an option that sets preferences when running the test suite - undocumented option */ else if (eq (p, "REGRESSION")) { OPTION_NO_WARNINGS (&program) = A68_FALSE; OPTION_PORTCHECK (&program) = A68_TRUE; OPTION_REGRESSION_TEST (&program) = A68_TRUE; OPTION_TIME_LIMIT (&program) = 120; OPTION_KEEP (&program) = A68_TRUE; term_width = MAX_TERM_WIDTH; } /* LOCAL assumes include files in the current directory - undocumented option */ else if (eq (p, "LOCal")) { OPTION_LOCAL (&program) = A68_TRUE; } /* NOWARNINGS switches unsuppressible warnings off */ else if (eq (p, "NOWarnings")) { OPTION_NO_WARNINGS (&program) = A68_TRUE; } else if (eq (p, "NO-Warnings")) { OPTION_NO_WARNINGS (&program) = A68_TRUE; } /* QUIET switches all warnings off */ else if (eq (p, "Quiet")) { OPTION_QUIET (&program) = A68_TRUE; } /* WARNINGS switches warnings on */ else if (eq (p, "Warnings")) { OPTION_NO_WARNINGS (&program) = A68_FALSE; } /* NOPORTCHECK switches portcheck off */ else if (eq (p, "NOPORTcheck")) { OPTION_PORTCHECK (&program) = A68_FALSE; } else if (eq (p, "NO-PORTcheck")) { OPTION_PORTCHECK (&program) = A68_FALSE; } /* PORTCHECK switches portcheck on */ else if (eq (p, "PORTcheck")) { OPTION_PORTCHECK (&program) = A68_TRUE; } /* PEDANTIC switches portcheck and warnings on */ else if (eq (p, "PEDANTIC")) { OPTION_PORTCHECK (&program) = A68_TRUE; OPTION_NO_WARNINGS (&program) = A68_FALSE; } /* PRAGMATS and NOPRAGMATS switch on/off pragmat processing */ else if (eq (p, "PRagmats")) { OPTION_PRAGMAT_SEMA (&program) = A68_TRUE; } else if (eq (p, "NOPRagmats")) { OPTION_PRAGMAT_SEMA (&program) = A68_FALSE; } else if (eq (p, "NO-PRagmats")) { OPTION_PRAGMAT_SEMA (&program) = A68_FALSE; } /* STRICT ignores A68G extensions to A68 syntax */ else if (eq (p, "STRict")) { OPTION_STRICT (&program) = A68_TRUE; OPTION_PORTCHECK (&program) = A68_TRUE; } /* VERBOSE in case you want to know what Algol68G is doing */ else if (eq (p, "VERBose")) { OPTION_VERBOSE (&program) = A68_TRUE; } /* VERSION lists the current version at an appropriate time in the future */ else if (eq (p, "Version")) { OPTION_VERSION (&program) = A68_TRUE; } /* XREF and NOXREF switch on/off a cross reference */ else if (eq (p, "XREF")) { OPTION_SOURCE_LISTING (&program) = A68_TRUE; OPTION_CROSS_REFERENCE (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= (CROSS_REFERENCE_MASK | SOURCE_MASK); } else if (eq (p, "NOXREF")) { OPTION_NODEMASK (&program) &= ~(CROSS_REFERENCE_MASK | SOURCE_MASK); } else if (eq (p, "NO-Xref")) { OPTION_NODEMASK (&program) &= ~(CROSS_REFERENCE_MASK | SOURCE_MASK); } /* PRELUDELISTING cross references preludes, if they ever get implemented .. */ else if (eq (p, "PRELUDElisting")) { OPTION_STANDARD_PRELUDE_LISTING (&program) = A68_TRUE; } /* STATISTICS prints process statistics */ else if (eq (p, "STatistics")) { OPTION_STATISTICS_LISTING (&program) = A68_TRUE; } /* TREE and NOTREE switch on/off printing of the syntax tree. This gets bulky! */ else if (eq (p, "TREE")) { OPTION_SOURCE_LISTING (&program) = A68_TRUE; OPTION_TREE_LISTING (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= (TREE_MASK | SOURCE_MASK); } else if (eq (p, "NOTREE")) { OPTION_NODEMASK (&program) ^= (TREE_MASK | SOURCE_MASK); } else if (eq (p, "NO-TREE")) { OPTION_NODEMASK (&program) ^= (TREE_MASK | SOURCE_MASK); } /* UNUSED indicates unused tags */ else if (eq (p, "UNUSED")) { OPTION_UNUSED (&program) = A68_TRUE; } /* EXTENSIVE set of options for an extensive listing */ else if (eq (p, "EXTensive")) { OPTION_SOURCE_LISTING (&program) = A68_TRUE; OPTION_OBJECT_LISTING (&program) = A68_TRUE; OPTION_TREE_LISTING (&program) = A68_TRUE; OPTION_CROSS_REFERENCE (&program) = A68_TRUE; OPTION_MOID_LISTING (&program) = A68_TRUE; OPTION_STANDARD_PRELUDE_LISTING (&program) = A68_TRUE; OPTION_STATISTICS_LISTING (&program) = A68_TRUE; OPTION_UNUSED (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= (CROSS_REFERENCE_MASK | TREE_MASK | CODE_MASK | SOURCE_MASK); } /* LISTING set of options for a default listing */ else if (eq (p, "Listing")) { OPTION_SOURCE_LISTING (&program) = A68_TRUE; OPTION_CROSS_REFERENCE (&program) = A68_TRUE; OPTION_STATISTICS_LISTING (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= (SOURCE_MASK | CROSS_REFERENCE_MASK); } /* TTY send listing to standout. Remnant from my mainframe past */ else if (eq (p, "TTY")) { OPTION_CROSS_REFERENCE (&program) = A68_TRUE; OPTION_STATISTICS_LISTING (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= (SOURCE_MASK | CROSS_REFERENCE_MASK); } /* SOURCE and NOSOURCE print source lines */ else if (eq (p, "SOURCE")) { OPTION_SOURCE_LISTING (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= SOURCE_MASK; } else if (eq (p, "NOSOURCE")) { OPTION_NODEMASK (&program) &= ~SOURCE_MASK; } else if (eq (p, "NO-SOURCE")) { OPTION_NODEMASK (&program) &= ~SOURCE_MASK; } /* OBJECT and NOOBJECT print object lines */ else if (eq (p, "OBJECT")) { OPTION_OBJECT_LISTING (&program) = A68_TRUE; } else if (eq (p, "NOOBJECT")) { OPTION_OBJECT_LISTING (&program) = A68_FALSE; } else if (eq (p, "NO-OBJECT")) { OPTION_OBJECT_LISTING (&program) = A68_FALSE; } /* MOIDS prints an overview of moids used in the program */ else if (eq (p, "MOIDS")) { OPTION_MOID_LISTING (&program) = A68_TRUE; } /* ASSERTIONS and NOASSERTIONS switch on/off the processing of assertions */ else if (eq (p, "Assertions")) { OPTION_NODEMASK (&program) |= ASSERT_MASK; } else if (eq (p, "NOAssertions")) { OPTION_NODEMASK (&program) &= ~ASSERT_MASK; } else if (eq (p, "NO-Assertions")) { OPTION_NODEMASK (&program) &= ~ASSERT_MASK; } /* PRECISION sets the precision */ else if (eq (p, "PRECision")) { BOOL_T error = A68_FALSE; int k = fetch_integral (p, &i, &error); if (error || errno > 0) { option_error (start_l, start_c, "conversion error in"); } else if (k > 1) { if (int_to_mp_digits (k) > long_mp_digits ()) { set_longlong_mp_digits (int_to_mp_digits (k)); } else { k = 1; while (int_to_mp_digits (k) <= long_mp_digits ()) { k++; } option_error (start_l, start_c, "value less than minimum in"); } } else { option_error (start_l, start_c, "invalid value in"); } } /* BACKTRACE and NOBACKTRACE switch on/off stack backtracing */ else if (eq (p, "BACKtrace")) { OPTION_BACKTRACE (&program) = A68_TRUE; } else if (eq (p, "NOBACKtrace")) { OPTION_BACKTRACE (&program) = A68_FALSE; } else if (eq (p, "NO-BACKtrace")) { OPTION_BACKTRACE (&program) = A68_FALSE; } /* BREAK and NOBREAK switch on/off tracing of the running program */ else if (eq (p, "BReakpoint")) { OPTION_NODEMASK (&program) |= BREAKPOINT_MASK; } else if (eq (p, "NOBReakpoint")) { OPTION_NODEMASK (&program) &= ~BREAKPOINT_MASK; } else if (eq (p, "NO-BReakpoint")) { OPTION_NODEMASK (&program) &= ~BREAKPOINT_MASK; } /* TRACE and NOTRACE switch on/off tracing of the running program */ else if (eq (p, "TRace")) { OPTION_TRACE (&program) = A68_TRUE; OPTION_NODEMASK (&program) |= BREAKPOINT_TRACE_MASK; } else if (eq (p, "NOTRace")) { OPTION_NODEMASK (&program) &= ~BREAKPOINT_TRACE_MASK; } else if (eq (p, "NO-TRace")) { OPTION_NODEMASK (&program) &= ~BREAKPOINT_TRACE_MASK; } /* TIMELIMIT lets the interpreter stop after so-many seconds */ else if (eq (p, "TImelimit") || eq (p, "TIME-Limit")) { BOOL_T error = A68_FALSE; int k = fetch_integral (p, &i, &error); if (error || errno > 0) { option_error (start_l, start_c, "conversion error in"); } else if (k < 1) { option_error (start_l, start_c, "invalid time span in"); } else { OPTION_TIME_LIMIT (&program) = k; } } else { /* Unrecognised */ option_error (start_l, start_c, "unrecognised"); } } /* Go processing next item, if present */ if (i != NO_OPTION_LIST) { FORWARD (i); } } } /* Mark options as processed */ for (; j != NO_OPTION_LIST; FORWARD (j)) { PROCESSED (j) = A68_TRUE; } return ((BOOL_T) (errno == 0)); } /** @brief Set default core size. **/ static void default_mem_sizes (int n) { if (n < 0 || n > 20) { n = 1; } frame_stack_size = 6 * n * MEGABYTE; expr_stack_size = 2 * n * MEGABYTE; heap_size = 48 * n * MEGABYTE; handle_pool_size = 8 * n * MEGABYTE; storage_overhead = MIN_MEM_SIZE; } /** @brief Read options from the .rc file. **/ void read_rc_options (void) { FILE *f; char name[BUFFER_SIZE], new_name[BUFFER_SIZE]; ASSERT (snprintf (name, SNPRINTF_SIZE, ".%src", a68g_cmd_name) >= 0); f = a68g_fopen (name, "r", new_name); if (f != NO_FILE) { while (!feof (f)) { if (fgets (input_line, BUFFER_SIZE, f) != NO_TEXT) { if (input_line[strlen (input_line) - 1] == NEWLINE_CHAR) { input_line[strlen (input_line) - 1] = NULL_CHAR; } isolate_options (input_line, NO_LINE); } } ASSERT (fclose (f) == 0); (void) set_options (OPTION_LIST (&program), A68_FALSE); } else { errno = 0; } } /** @brief Read options from A68G_OPTIONS. **/ void read_env_options (void) { if (getenv ("A68G_OPTIONS") != NULL) { isolate_options (getenv ("A68G_OPTIONS"), NO_LINE); (void) set_options (OPTION_LIST (&program), A68_FALSE); errno = 0; } } /** @brief Tokenise string 'p' that holds options. @param p Text. @param line Source line. **/ void isolate_options (char *p, LINE_T * line) { char *q; /* 'q' points at first significant char in item .*/ while (p[0] != NULL_CHAR) { /* Skip white space etc */ while ((p[0] == BLANK_CHAR || p[0] == TAB_CHAR || p[0] == ',' || p[0] == NEWLINE_CHAR) && p[0] != NULL_CHAR) { p++; } /* ... then tokenise an item */ if (p[0] != NULL_CHAR) { /* Item can be "string". Note that these are not A68 strings */ if (p[0] == QUOTE_CHAR || p[0] == '\'' || p[0] == '`') { char delim = p[0]; p++; q = p; while (p[0] != delim && p[0] != NULL_CHAR) { p++; } if (p[0] != NULL_CHAR) { p[0] = NULL_CHAR; /* p[0] was delimiter */ p++; } else { scan_error (line, NO_TEXT, ERROR_UNTERMINATED_STRING); } } else { /* Item is not a delimited string */ q = p; /* Tokenise symbol and gather it in the option list for later processing. Skip '='s, we accept if someone writes -prec=60 -heap=8192 */ if (*q == '=') { p++; } else { /* Skip item */ while (p[0] != BLANK_CHAR && p[0] != NULL_CHAR && p[0] != '=' && p[0] != ',' && p[0] != NEWLINE_CHAR) { p++; } } if (p[0] != NULL_CHAR) { p[0] = NULL_CHAR; p++; } } /* 'q' points to first significant char in item, and 'p' points after item */ add_option_list (&(OPTION_LIST (&program)), q, line); } } } /* Routines for making a listing file */ #define SHOW_EQ A68_FALSE char *bar[BUFFER_SIZE]; /** @brief a68g_print_short_mode. @param f File number. @param z Moid to print. **/ static void a68g_print_short_mode (FILE_T f, MOID_T * z) { if (IS (z, STANDARD)) { int i = DIM (z); if (i > 0) { while (i--) { WRITE (f, "LONG "); } } else if (i < 0) { while (i++) { WRITE (f, "SHORT "); } } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", NSYMBOL (NODE (z))) >= 0); WRITE (f, output_line); } else if (IS (z, REF_SYMBOL) && IS (SUB (z), STANDARD)) { WRITE (f, "REF "); a68g_print_short_mode (f, SUB (z)); } else if (IS (z, PROC_SYMBOL) && PACK (z) == NO_PACK && IS (SUB (z), STANDARD)) { WRITE (f, "PROC "); a68g_print_short_mode (f, SUB (z)); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "#%d", NUMBER (z)) >= 0); WRITE (f, output_line); } } /** @brief A68g_print_flat_mode. @param f File number. @param z Moid to print. **/ void a68g_print_flat_mode (FILE_T f, MOID_T * z) { if (IS (z, STANDARD)) { int i = DIM (z); if (i > 0) { while (i--) { WRITE (f, "LONG "); } } else if (i < 0) { while (i++) { WRITE (f, "SHORT "); } } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", NSYMBOL (NODE (z))) >= 0); WRITE (f, output_line); } else if (IS (z, REF_SYMBOL)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "REF ") >= 0); WRITE (f, output_line); a68g_print_short_mode (f, SUB (z)); } else if (IS (z, PROC_SYMBOL) && DIM (z) == 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "PROC ") >= 0); WRITE (f, output_line); a68g_print_short_mode (f, SUB (z)); } else if (IS (z, ROW_SYMBOL)) { int i = DIM (z); WRITE (f, "["); while (--i) { WRITE (f, ", "); } WRITE (f, "] "); a68g_print_short_mode (f, SUB (z)); } else { a68g_print_short_mode (f, z); } } /** @brief Brief_fields_flat. @param f File number. @param pack Pack to print. **/ static void a68g_print_short_pack (FILE_T f, PACK_T * pack) { if (pack != NO_PACK) { a68g_print_short_mode (f, MOID (pack)); if (NEXT (pack) != NO_PACK) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", ") >= 0); WRITE (f, output_line); a68g_print_short_pack (f, NEXT (pack)); } } } /** @brief A68g_print_mode. @param f File number. @param z Moid to print. **/ void a68g_print_mode (FILE_T f, MOID_T * z) { if (z != NO_MOID) { if (IS (z, STANDARD)) { a68g_print_flat_mode (f, z); } else if (IS (z, INDICANT)) { WRITE (f, NSYMBOL (NODE (z))); } else if (z == MODE (COLLITEM)) { WRITE (f, "\"COLLITEM\""); } else if (IS (z, REF_SYMBOL)) { WRITE (f, "REF "); a68g_print_flat_mode (f, SUB (z)); } else if (IS (z, FLEX_SYMBOL)) { WRITE (f, "FLEX "); a68g_print_flat_mode (f, SUB (z)); } else if (IS (z, ROW_SYMBOL)) { int i = DIM (z); WRITE (f, "["); while (--i) { WRITE (f, ", "); } WRITE (f, "] "); a68g_print_flat_mode (f, SUB (z)); } else if (IS (z, STRUCT_SYMBOL)) { WRITE (f, "STRUCT ("); a68g_print_short_pack (f, PACK (z)); WRITE (f, ")"); } else if (IS (z, UNION_SYMBOL)) { WRITE (f, "UNION ("); a68g_print_short_pack (f, PACK (z)); WRITE (f, ")"); } else if (IS (z, PROC_SYMBOL)) { WRITE (f, "PROC "); if (PACK (z) != NO_PACK) { WRITE (f, "("); a68g_print_short_pack (f, PACK (z)); WRITE (f, ") "); } a68g_print_flat_mode (f, SUB (z)); } else if (IS (z, IN_TYPE_MODE)) { WRITE (f, "\"SIMPLIN\""); } else if (IS (z, OUT_TYPE_MODE)) { WRITE (f, "\"SIMPLOUT\""); } else if (IS (z, ROWS_SYMBOL)) { WRITE (f, "\"ROWS\""); } else if (IS (z, SERIES_MODE)) { WRITE (f, "\"SERIES\" ("); a68g_print_short_pack (f, PACK (z)); WRITE (f, ")"); } else if (IS (z, STOWED_MODE)) { WRITE (f, "\"STOWED\" ("); a68g_print_short_pack (f, PACK (z)); WRITE (f, ")"); } } } /** @brief Print_mode_flat. @param f File number. @param m Moid to print. **/ void print_mode_flat (FILE_T f, MOID_T * m) { if (m != NO_MOID) { a68g_print_mode (f, m); if (NODE (m) != NO_NODE && NUMBER (NODE (m)) > 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " node %d", NUMBER (NODE (m))) >= 0); WRITE (f, output_line); } if (EQUIVALENT_MODE (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " equi #%d", NUMBER (EQUIVALENT (m))) >= 0); WRITE (f, output_line); } if (SLICE (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " slice #%d", NUMBER (SLICE (m))) >= 0); WRITE (f, output_line); } if (TRIM (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " trim #%d", NUMBER (TRIM (m))) >= 0); WRITE (f, output_line); } if (ROWED (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " rowed #%d", NUMBER (ROWED (m))) >= 0); WRITE (f, output_line); } if (DEFLEXED (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " deflex #%d", NUMBER (DEFLEXED (m))) >= 0); WRITE (f, output_line); } if (MULTIPLE (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " multiple #%d", NUMBER (MULTIPLE (m))) >= 0); WRITE (f, output_line); } if (NAME (m) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " name #%d", NUMBER (NAME (m))) >= 0); WRITE (f, output_line); } if (USE (m)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " used") >= 0); WRITE (f, output_line); } if (DERIVATE (m)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " derivate") >= 0); WRITE (f, output_line); } if (SIZE (m) > 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " size %d", SIZE (m)) >= 0); WRITE (f, output_line); } if (HAS_ROWS (m)) { WRITE (f, " []"); } } } /** @brief Xref_tags. @param f File number. @param s Tag to print. @param a Attribute. **/ static void xref_tags (FILE_T f, TAG_T * s, int a) { for (; s != NO_TAG; FORWARD (s)) { NODE_T *where_tag = NODE (s); if ((where_tag != NO_NODE) && ((STATUS_TEST (where_tag, CROSS_REFERENCE_MASK)) || TAG_TABLE (s) == a68g_standenv)) { WRITE (f, "\n "); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "tag %d ", NUMBER (s)) >= 0); WRITE (f, output_line); switch (a) { case IDENTIFIER: { a68g_print_mode (f, MOID (s)); ASSERT (snprintf (output_line, SNPRINTF_SIZE, " %s", NSYMBOL (NODE (s))) >= 0); WRITE (f, output_line); break; } case INDICANT: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "indicant %s ", NSYMBOL (NODE (s))) >= 0); WRITE (f, output_line); a68g_print_mode (f, MOID (s)); break; } case PRIO_SYMBOL: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "priority %s %d", NSYMBOL (NODE (s)), PRIO (s)) >= 0); WRITE (f, output_line); break; } case OP_SYMBOL: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "operator %s ", NSYMBOL (NODE (s))) >= 0); WRITE (f, output_line); a68g_print_mode (f, MOID (s)); break; } case LABEL: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "label %s", NSYMBOL (NODE (s))) >= 0); WRITE (f, output_line); break; } case ANONYMOUS: { switch (PRIO (s)) { case ROUTINE_TEXT: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "routine text ") >= 0); break; } case FORMAT_TEXT: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "format text ") >= 0); break; } case FORMAT_IDENTIFIER: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "format item ") >= 0); break; } case COLLATERAL_CLAUSE: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "display ") >= 0); break; } case GENERATOR: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "generator ") >= 0); break; } } WRITE (f, output_line); a68g_print_mode (f, MOID (s)); break; } default: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "internal %d ", a) >= 0); WRITE (f, output_line); a68g_print_mode (f, MOID (s)); break; } } if (NODE (s) != NO_NODE && NUMBER (NODE (s)) > 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", node %d", NUMBER (NODE (s))) >= 0); WRITE (f, output_line); } if (where_tag != NO_NODE && INFO (where_tag) != NO_NINFO && LINE (INFO (where_tag)) != NO_LINE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", line %d", LINE_NUMBER (where_tag)) >= 0); WRITE (f, output_line); } } } } /** @brief Xref_decs. @param f File number. @param t Symbol table. **/ static void xref_decs (FILE_T f, TABLE_T * t) { if (INDICANTS (t) != NO_TAG) { xref_tags (f, INDICANTS (t), INDICANT); } if (OPERATORS (t) != NO_TAG) { xref_tags (f, OPERATORS (t), OP_SYMBOL); } if (PRIO (t) != NO_TAG) { xref_tags (f, PRIO (t), PRIO_SYMBOL); } if (IDENTIFIERS (t) != NO_TAG) { xref_tags (f, IDENTIFIERS (t), IDENTIFIER); } if (LABELS (t) != NO_TAG) { xref_tags (f, LABELS (t), LABEL); } if (ANONYMOUS (t) != NO_TAG) { xref_tags (f, ANONYMOUS (t), ANONYMOUS); } } /** @brief Xref1_moid. @param f File number. @param p Moid to xref. **/ static void xref1_moid (FILE_T f, MOID_T * p) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n #%d ", NUMBER (p)) >= 0); WRITE (f, output_line); print_mode_flat (f, p); } /** @brief Moid_listing. @param f File number. @param m Moid list to xref. **/ void moid_listing (FILE_T f, MOID_T * m) { for (; m != NO_MOID; FORWARD (m)) { xref1_moid (f, m); } WRITE (f, "\n"); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n MODE STRING #%d ", NUMBER (MODE (STRING))) >= 0); WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n MODE COMPLEX #%d ", NUMBER (MODE (COMPLEX))) >= 0); WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n MODE SEMA #%d ", NUMBER (MODE (SEMA))) >= 0); WRITE (f, output_line); } /** @brief Cross_reference. @param f File Number. @param p Top node. @param l Source line. **/ static void cross_reference (FILE_T f, NODE_T * p, LINE_T * l) { if (p != NO_NODE && CROSS_REFERENCE_SAFE (&program)) { for (; p != NO_NODE; FORWARD (p)) { if (is_new_lexical_level (p) && l == LINE (INFO (p))) { TABLE_T *c = TABLE (SUB (p)); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n\n[level %d", LEVEL (c)) >= 0); WRITE (f, output_line); if (PREVIOUS (c) == a68g_standenv) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", in standard environ") >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", in level %d", LEVEL (PREVIOUS (c))) >= 0); } WRITE (f, output_line); ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", %d increment]", AP_INCREMENT (c)) >= 0); WRITE (f, output_line); if (c != NO_TABLE) { xref_decs (f, c); } WRITE (f, "\n"); } cross_reference (f, SUB (p), l); } } } /** @brief Tree listing for source line. @param f File number. @param q Top node. @param x Current level. @param l Source line. @param ld Index for indenting and drawing bars connecting nodes. **/ void tree_listing (FILE_T f, NODE_T * q, int x, LINE_T * l, int *ld) { for (; q != NO_NODE; FORWARD (q)) { NODE_T *p = q; int k, dist; if (((STATUS_TEST (p, TREE_MASK))) && l == LINE (INFO (p))) { if (*ld < 0) { *ld = x; } /* Indent */ WRITE (f, "\n "); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%02d %06d p%02d ", x, NUMBER (p), PROCEDURE_LEVEL (INFO (p))) >= 0); WRITE (f, output_line); if (PREVIOUS (TABLE (p)) != NO_TABLE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%02d-%02d-%02d ", (TABLE (p) != NO_TABLE ? LEX_LEVEL (p) : 0), (TABLE (p) != NO_TABLE ? LEVEL (PREVIOUS (TABLE (p))) : 0), (NON_LOCAL (p) != NO_TABLE ? LEVEL (NON_LOCAL (p)) : 0) ) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%02d- -%02d", (TABLE (p) != NO_TABLE ? LEX_LEVEL (p) : 0), (NON_LOCAL (p) != NO_TABLE ? LEVEL (NON_LOCAL (p)) : 0) ) >= 0); } WRITE (f, output_line); if (MOID (q) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "#%04d ", NUMBER (MOID (p))) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " ") >= 0); } WRITE (f, output_line); for (k = 0; k < (x - *ld); k++) { WRITE (f, bar[k]); } if (MOID (p) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s ", moid_to_string (MOID (p), MOID_WIDTH, NO_NODE)) >= 0); WRITE (f, output_line); } ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s", non_terminal_string (edit_line, ATTRIBUTE (p))) >= 0); WRITE (f, output_line); if (SUB (p) == NO_NODE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) >= 0); WRITE (f, output_line); } if (TAX (p) != NO_TAG) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", tag %06u", (unsigned) NUMBER (TAX (p))) >= 0); WRITE (f, output_line); if (MOID (TAX (p)) != NO_MOID) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", mode %06u", (unsigned) NUMBER (MOID (TAX (p)))) >= 0); WRITE (f, output_line); } } if (GINFO (p) != NO_GINFO && propagator_name (UNIT (&GPROP (p))) != NO_TEXT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", %s", propagator_name (UNIT (&GPROP (p)))) >= 0); WRITE (f, output_line); } if (GINFO (p) != NO_GINFO && COMPILE_NAME (GINFO (p)) != NO_TEXT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", %s", COMPILE_NAME (GINFO (p))) >= 0); WRITE (f, output_line); } if (GINFO (p) != NO_GINFO && COMPILE_NODE (GINFO (p)) > 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", %6d", COMPILE_NODE (GINFO (p))) >= 0); WRITE (f, output_line); } } dist = x - (*ld); if (dist >= 0 && dist < BUFFER_SIZE) { bar[dist] = (NEXT (p) != NO_NODE && l == LINE (INFO (NEXT (p))) ? "|" : " "); } tree_listing (f, SUB (p), x + 1, l, ld); dist = x - (*ld); if (dist >= 0 && dist < BUFFER_SIZE) { bar[dist] = " "; } } } /** @brief Leaves_to_print. @param p Top node. @param l Source line. @return Number of nodes to be printed in tree listing. **/ static int leaves_to_print (NODE_T * p, LINE_T * l) { int z = 0; for (; p != NO_NODE && z == 0; FORWARD (p)) { if (l == LINE (INFO (p)) && ((STATUS_TEST (p, TREE_MASK)))) { z++; } else { z += leaves_to_print (SUB (p), l); } } return (z); } /** @brief List_source_line. @param f File number. @param line Source line. @param tree List syntax tree, or not. **/ void list_source_line (FILE_T f, LINE_T * line, BOOL_T tree) { int k = (int) strlen (STRING (line)) - 1; if (NUMBER (line) <= 0) { /* Mask the prelude and postlude */ return; } if ((STRING (line))[k] == NEWLINE_CHAR) { (STRING (line))[k] = NULL_CHAR; } /* Print source line */ write_source_line (f, line, NO_NODE, A68_ALL_DIAGNOSTICS); /* Cross reference for lexical levels starting at this line */ if (OPTION_CROSS_REFERENCE (&program)) { cross_reference (f, TOP_NODE (&program), line); } /* Syntax tree listing connected with this line */ if (tree && OPTION_TREE_LISTING (&program)) { if (TREE_LISTING_SAFE (&program) && leaves_to_print (TOP_NODE (&program), line)) { int ld = -1, k2; WRITE (f, "\n\nSyntax tree"); for (k2 = 0; k2 < BUFFER_SIZE; k2++) { bar[k2] = " "; } tree_listing (f, TOP_NODE (&program), 1, line, &ld); WRITE (f, "\n"); } } } /** @brief Source_listing. **/ void write_source_listing (void) { LINE_T *line = TOP_LINE (&program); FILE_T f = FILE_LISTING_FD (&program); int listed = 0; WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nSource listing"); WRITE (FILE_LISTING_FD (&program), "\n------ -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); if (FILE_LISTING_OPENED (&program) == 0) { diagnostic_node (A68_ERROR, NO_NODE, ERROR_CANNOT_WRITE_LISTING); return; } for (; line != NO_LINE; FORWARD (line)) { if (NUMBER (line) > 0 && LIST (line)) { listed++; } list_source_line (f, line, A68_FALSE); } /* Warn if there was no source at all */ if (listed == 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n No lines to list") >= 0); WRITE (f, output_line); } } /** @brief Write_source_listing. **/ void write_tree_listing (void) { LINE_T *line = TOP_LINE (&program); FILE_T f = FILE_LISTING_FD (&program); int listed = 0; WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nSyntax tree listing"); WRITE (FILE_LISTING_FD (&program), "\n------ ---- -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); if (FILE_LISTING_OPENED (&program) == 0) { diagnostic_node (A68_ERROR, NO_NODE, ERROR_CANNOT_WRITE_LISTING); return; } for (; line != NO_LINE; FORWARD (line)) { if (NUMBER (line) > 0 && LIST (line)) { listed++; } list_source_line (f, line, A68_TRUE); } /* Warn if there was no source at all */ if (listed == 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n No lines to list") >= 0); WRITE (f, output_line); } } /** @brief Write_object_listing. **/ void write_object_listing (void) { if (OPTION_OBJECT_LISTING (&program)) { WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nObject listing"); WRITE (FILE_LISTING_FD (&program), "\n------ -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); compiler (FILE_LISTING_FD (&program)); } } /** @brief Write_listing. **/ void write_listing (void) { FILE_T f = FILE_LISTING_FD (&program); if (OPTION_MOID_LISTING (&program)) { WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nMode listing"); WRITE (FILE_LISTING_FD (&program), "\n---- -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); moid_listing (f, TOP_MOID (&program)); } if (OPTION_STANDARD_PRELUDE_LISTING (&program) && a68g_standenv != NO_TABLE) { WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nStandard prelude listing"); WRITE (FILE_LISTING_FD (&program), "\n-------- ------- -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); xref_decs (f, a68g_standenv); } if (TOP_REFINEMENT (&program) != NO_REFINEMENT) { REFINEMENT_T *x = TOP_REFINEMENT (&program); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nRefinement listing"); WRITE (FILE_LISTING_FD (&program), "\n---------- -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); while (x != NO_REFINEMENT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n \"%s\"", NAME (x)) >= 0); WRITE (f, output_line); if (LINE_DEFINED (x) != NO_LINE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", defined in line %d", NUMBER (LINE_DEFINED (x))) >= 0); WRITE (f, output_line); } if (LINE_APPLIED (x) != NO_LINE) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", applied in line %d", NUMBER (LINE_APPLIED (x))) >= 0); WRITE (f, output_line); } switch (APPLICATIONS (x)) { case 0: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", not applied") >= 0); WRITE (f, output_line); break; } case 1: { break; } default: { ASSERT (snprintf (output_line, SNPRINTF_SIZE, ", applied more than once") >= 0); WRITE (f, output_line); break; } } FORWARD (x); } } if (OPTION_LIST (&program) != NO_OPTION_LIST) { OPTION_LIST_T *i; int k = 1; WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); WRITE (FILE_LISTING_FD (&program), "\nPragmat listing"); WRITE (FILE_LISTING_FD (&program), "\n------- -------"); WRITE (FILE_LISTING_FD (&program), NEWLINE_STRING); for (i = OPTION_LIST (&program); i != NO_OPTION_LIST; FORWARD (i)) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n%d: %s", k++, STR (i)) >= 0); WRITE (f, output_line); } } } /** @brief Write_listing_header. **/ void write_listing_header (void) { FILE_T f = FILE_LISTING_FD (&program); LINE_T * z; state_version (FILE_LISTING_FD (&program)); WRITE (FILE_LISTING_FD (&program), "\nFile \""); WRITE (FILE_LISTING_FD (&program), FILE_SOURCE_NAME (&program)); if (OPTION_STATISTICS_LISTING (&program)) { if (ERROR_COUNT (&program) + WARNING_COUNT (&program) > 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\nDiagnostics: %d error(s), %d warning(s)", ERROR_COUNT (&program), WARNING_COUNT (&program)) >= 0); WRITE (f, output_line); for (z = TOP_LINE (&program); z != NO_LINE; FORWARD (z)) { if (DIAGNOSTICS (z) != NO_DIAGNOSTIC) { write_source_line (f, z, NO_NODE, A68_TRUE); } } } } } /* Small utility routines */ /** @brief Get terminal size. @param h Heigth in lines. @param c Width in columns. **/ void a68g_getty (int * h, int * c) { /* Default action first */ (* h) = MAX_TERM_HEIGTH; (* c) = MAX_TERM_WIDTH; #if (defined HAVE_SYS_IOCTL_H && defined TIOCGWINSZ) { struct winsize w; if (ioctl (0, TIOCGWINSZ, &w) == 0) { (* h) = w.ws_row; (* c) = w.ws_col; } } #elif (defined HAVE_SYS_IOCTL_H && defined TIOCGSIZE) { struct ttysize w; (void) ioctl (0, TIOCGSIZE, &w); if (w.ts_lines > 0) { (* h) = w.ts_lines; } if (w.ts_cols > 0) { (* c) = w.ts_cols; } } #elif (defined HAVE_SYS_IOCTL_H && defined WIOCGETD) { struct uwdata w; (void) ioctl (0, WIOCGETD, &w); if (w.uw_heigth > 0 && w.uw_vs != 0) { (* h) = w.uw_heigth / w.uw_vs; } if (w.uw_width > 0 && w.uw_hs != 0) { (* c) = w.uw_width / w.uw_hs; } } #endif } /* Signal handlers */ /** @brief Signal for window resize. @param i Dummy. **/ #if defined SIGWINCH static void sigwinch_handler (int i) { (void) i; ABEND (signal (SIGWINCH, sigwinch_handler) == SIG_ERR, "cannot install SIGWINCH handler", NO_TEXT); a68g_getty (&term_heigth, &term_width); return; } #endif /** @brief Signal reading for segment violation. @param i Dummy. **/ static void sigsegv_handler (int i) { (void) i; exit (EXIT_FAILURE); return; } /** @brief Raise SYSREQUEST so you get to a monitor. @param i Dummy. **/ static void sigint_handler (int i) { (void) i; ABEND (signal (SIGINT, sigint_handler) == SIG_ERR, "cannot install SIGINT handler", NO_TEXT); if (!(STATUS_TEST (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK) || in_monitor)) { STATUS_SET (TOP_NODE (&program), BREAKPOINT_INTERRUPT_MASK); genie_break (TOP_NODE (&program)); } } #if ! defined HAVE_WIN32 /** @brief Signal reading from disconnected terminal. @param i Dummy. **/ static void sigttin_handler (int i) { (void) i; ABEND (A68_TRUE, "background process attempts reading from disconnected terminal", NO_TEXT); } /** @brief Signal broken pipe. @param i Dummy. **/ static void sigpipe_handler (int i) { (void) i; ABEND (A68_TRUE, "forked process has broken the pipe", NO_TEXT); } /** @brief Signal alarm - time limit check. @param i Dummy. **/ static void sigalrm_handler (int i) { (void) i; if (in_execution && !in_monitor) { double _m_t = (double) OPTION_TIME_LIMIT (&program); if (_m_t > 0 && (seconds () - cputime_0) > _m_t) { diagnostic_node (A68_RUNTIME_ERROR, (NODE_T *) last_unit, ERROR_TIME_LIMIT_EXCEEDED); exit_genie ((NODE_T *) last_unit, A68_RUNTIME_ERROR); } } (void) alarm (1); } #endif /* ! defined HAVE_WIN32 */ /** @brief Install_signal_handlers. **/ void install_signal_handlers (void) { ABEND (signal (SIGINT, sigint_handler) == SIG_ERR, "cannot install SIGINT handler", NO_TEXT); ABEND (signal (SIGSEGV, sigsegv_handler) == SIG_ERR, "cannot install SIGSEGV handler", NO_TEXT); #if defined SIGWINCH ABEND (signal (SIGWINCH, sigwinch_handler) == SIG_ERR, "cannot install SIGWINCH handler", NO_TEXT); #endif #if ! defined HAVE_WIN32 ABEND (signal (SIGALRM, sigalrm_handler) == SIG_ERR, "cannot install SIGALRM handler", NO_TEXT); ABEND (signal (SIGPIPE, sigpipe_handler) == SIG_ERR, "cannot install SIGPIPE handler", NO_TEXT); ABEND (signal (SIGTTIN, sigttin_handler) == SIG_ERR, "cannot install SIGTTIN handler", NO_TEXT); #endif /* ! defined HAVE_WIN32 */ } ADDR_T fixed_heap_pointer, temp_heap_pointer; POSTULATE_T *top_postulate, *top_postulate_list; KEYWORD_T *top_keyword; TOKEN_T *top_token; BOOL_T heap_is_fluid; static int tag_number = 0; /** @brief Give pointer to block of "s" bytes. @param s Block length in bytes. @return See brief description. **/ BYTE_T *get_heap_space (size_t s) { BYTE_T *z = (BYTE_T *) (A68_ALIGN_T *) malloc (A68_ALIGN (s)); ABEND (z == NO_BYTE, ERROR_OUT_OF_CORE, NO_TEXT); return (z); } /** @brief Make a new copy of concatenated strings. @param t Text. @return Pointer. **/ char *new_string (char *t, ...) { va_list vl; char *q, *z; int len = 0; va_start (vl, t); q = t; while (q != NO_TEXT) { len += (int) strlen (q); q = va_arg (vl, char *); } va_end (vl); len ++; z = (char *) get_heap_space ((size_t) len); z[0] = NULL_CHAR; q = t; va_start (vl, t); while (q != NO_TEXT) { bufcat (z, q, len); q = va_arg (vl, char *); } va_end (vl); return (z); } /** @brief Make a new copy of "t". @param t Text. @return Pointer. **/ char *new_fixed_string (char *t) { int n = (int) (strlen (t) + 1); char *z = (char *) get_fixed_heap_space ((size_t) n); bufcpy (z, t, n); return (z); } /** @brief Make a new copy of "t". @param t Text. @return Pointer. **/ char *new_temp_string (char *t) { int n = (int) (strlen (t) + 1); char *z = (char *) get_temp_heap_space ((size_t) n); bufcpy (z, t, n); return (z); } /** @brief Get (preferably fixed) heap space. @param s Size in bytes. @return Pointer to block. **/ BYTE_T *get_fixed_heap_space (size_t s) { BYTE_T *z; if (heap_is_fluid) { z = HEAP_ADDRESS (fixed_heap_pointer); fixed_heap_pointer += A68_ALIGN ((int) s); /* Allow for extra storage for diagnostics etcetera */ ABEND (fixed_heap_pointer >= (heap_size - MIN_MEM_SIZE), ERROR_OUT_OF_CORE, NO_TEXT); ABEND (((int) temp_heap_pointer - (int) fixed_heap_pointer) <= MIN_MEM_SIZE, ERROR_OUT_OF_CORE, NO_TEXT); return (z); } else { return (get_heap_space (s)); } } /** @brief Get (preferably temporary) heap space. @param s Size in bytes. @return Pointer to block. **/ BYTE_T *get_temp_heap_space (size_t s) { BYTE_T *z; /* ABEND (!heap_is_fluid, ERROR_INTERNAL_CONSISTENCY, NO_TEXT); */ if (heap_is_fluid) { temp_heap_pointer -= A68_ALIGN ((int) s); /* Allow for extra storage for diagnostics etcetera */ ABEND (((int) temp_heap_pointer - (int) fixed_heap_pointer) <= MIN_MEM_SIZE, ERROR_OUT_OF_CORE, NO_TEXT); z = HEAP_ADDRESS (temp_heap_pointer); return (z); } else { return (get_heap_space (s)); } } /** @brief Get size of stack segment. **/ void get_stack_size (void) { #if defined HAVE_WIN32 stack_size = MEGABYTE; /* guess */ #else struct rlimit limits; RESET_ERRNO; /* Some systems do not implement RLIMIT_STACK so if getrlimit fails, we do not abend */ if (!(getrlimit (RLIMIT_STACK, &limits) == 0 && errno == 0)) { stack_size = MEGABYTE; } stack_size = (int) (RLIM_CUR (&limits) < RLIM_MAX (&limits) ? RLIM_CUR (&limits) : RLIM_MAX (&limits)); /* A heuristic in case getrlimit yields extreme numbers: the frame stack is assumed to fill at a rate comparable to the C stack, so the C stack needs not be larger than the frame stack. This may not be true */ if (stack_size < KILOBYTE || (stack_size > 96 * MEGABYTE && stack_size > frame_stack_size)) { stack_size = frame_stack_size; } #endif stack_limit = (stack_size > (4 * storage_overhead) ? (stack_size - storage_overhead) : stack_size / 2); } /** @brief Convert integer to character. @param i Integer. @return Character. **/ char digit_to_char (int i) { char *z = "0123456789abcdefghijklmnopqrstuvwxyz"; if (i >= 0 && i < (int) strlen (z)) { return (z[i]); } else { return ('*'); } } /** @brief Renumber nodes. @param p Node in syntax tree. @param n Node number counter. **/ void renumber_nodes (NODE_T * p, int *n) { for (; p != NO_NODE; FORWARD (p)) { NUMBER (p) = (*n)++; renumber_nodes (SUB (p), n); } } /** @brief Register nodes. @param p Node in syntax tree. **/ void register_nodes (NODE_T * p) { for (; p != NO_NODE; FORWARD (p)) { node_register[NUMBER (p)] = p; register_nodes (SUB (p)); } } /** @brief New_node_info. @return See brief description. **/ NODE_INFO_T *new_node_info (void) { NODE_INFO_T *z = (NODE_INFO_T *) get_fixed_heap_space ((size_t) SIZE_AL (NODE_INFO_T)); new_node_infos++; PROCEDURE_LEVEL (z) = 0; CHAR_IN_LINE (z) = NO_TEXT; SYMBOL (z) = NO_TEXT; PRAGMENT (z) = NO_TEXT; PRAGMENT_TYPE (z) = 0; LINE (z) = NO_LINE; return (z); } /** @brief New_genie_info. @return See brief description. **/ GINFO_T *new_genie_info (void) { GINFO_T *z = (GINFO_T *) get_fixed_heap_space ((size_t) SIZE_AL (GINFO_T)); new_genie_infos++; UNIT (&PROP (z)) = NO_PPROC; SOURCE (&PROP (z)) = NO_NODE; PARTIAL_PROC (z) = NO_MOID; PARTIAL_LOCALE (z) = NO_MOID; IS_COERCION (z) = A68_FALSE; IS_NEW_LEXICAL_LEVEL (z) = A68_FALSE; NEED_DNS (z) = A68_FALSE; PARENT (z) = NO_NODE; OFFSET (z) = NO_BYTE; CONSTANT (z) = NO_CONSTANT; LEVEL (z) = 0; ARGSIZE (z) = 0; SIZE (z) = 0; COMPILE_NAME (z) = NO_TEXT; COMPILE_NODE (z) = 0; return (z); } /** @brief New_node. @return See brief description. **/ NODE_T *new_node (void) { NODE_T *z = (NODE_T *) get_fixed_heap_space ((size_t) SIZE_AL (NODE_T)); new_nodes++; STATUS (z) = NULL_MASK; CODEX (z) = NULL_MASK; TABLE (z) = NO_TABLE; INFO (z) = NO_NINFO; GINFO (z) = NO_GINFO; ATTRIBUTE (z) = 0; ANNOTATION (z) = 0; 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; return (z); } /** @brief New_symbol_table. @param p Parent symbol table. @return See brief description. **/ TABLE_T *new_symbol_table (TABLE_T * p) { TABLE_T *z = (TABLE_T *) get_fixed_heap_space ((size_t) SIZE_AL (TABLE_T)); LEVEL (z) = symbol_table_count++; NEST (z) = symbol_table_count; ATTRIBUTE (z) = 0; AP_INCREMENT (z) = 0; INITIALISE_FRAME (z) = A68_TRUE; PROC_OPS (z) = A68_TRUE; INITIALISE_ANON (z) = A68_TRUE; PREVIOUS (z) = p; OUTER (z) = NO_TABLE; IDENTIFIERS (z) = NO_TAG; OPERATORS (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; return (z); } /** @brief New_moid. @return See brief description. **/ MOID_T *new_moid (void) { MOID_T *z = (MOID_T *) get_fixed_heap_space ((size_t) SIZE_AL (MOID_T)); new_modes++; ATTRIBUTE (z) = 0; NUMBER (z) = 0; DIM (z) = 0; USE (z) = A68_FALSE; HAS_ROWS (z) = A68_FALSE; SIZE (z) = 0; DIGITS (z) = 0; SIZEC (z) = 0; DIGITSC (z) = 0; PORTABLE (z) = A68_TRUE; DERIVATE (z) = A68_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; return (z); } /** @brief New_pack. @return See brief description. **/ PACK_T *new_pack (void) { PACK_T *z = (PACK_T *) get_fixed_heap_space ((size_t) SIZE_AL (PACK_T)); MOID (z) = NO_MOID; TEXT (z) = NO_TEXT; NODE (z) = NO_NODE; NEXT (z) = NO_PACK; PREVIOUS (z) = NO_PACK; SIZE (z) = 0; OFFSET (z) = 0; return (z); } /** @brief New_tag. @return See brief description. **/ TAG_T *new_tag (void) { TAG_T *z = (TAG_T *) get_fixed_heap_space ((size_t) SIZE_AL (TAG_T)); STATUS (z) = NULL_MASK; CODEX (z) = NULL_MASK; TAG_TABLE (z) = NO_TABLE; MOID (z) = NO_MOID; NODE (z) = NO_NODE; UNIT (z) = NO_NODE; VALUE (z) = NO_TEXT; A68G_STANDENV_PROC (z) = 0; PROCEDURE (z) = NO_GPROC; SCOPE (z) = PRIMAL_SCOPE; SCOPE_ASSIGNED (z) = A68_FALSE; PRIO (z) = 0; USE (z) = A68_FALSE; IN_PROC (z) = A68_FALSE; HEAP (z) = A68_FALSE; SIZE (z) = 0; OFFSET (z) = 0; YOUNGEST_ENVIRON (z) = PRIMAL_SCOPE; LOC_ASSIGNED (z) = A68_FALSE; NEXT (z) = NO_TAG; BODY (z) = NO_TAG; PORTABLE (z) = A68_TRUE; NUMBER (z) = ++tag_number; return (z); } /** @brief New_source_line. @return See brief description. **/ LINE_T *new_source_line (void) { LINE_T *z = (LINE_T *) get_fixed_heap_space ((size_t) SIZE_AL (LINE_T)); MARKER (z)[0] = NULL_CHAR; STRING (z) = NO_TEXT; FILENAME (z) = NO_TEXT; DIAGNOSTICS (z) = NO_DIAGNOSTIC; NUMBER (z) = 0; PRINT_STATUS (z) = 0; LIST (z) = A68_TRUE; NEXT (z) = NO_LINE; PREVIOUS (z) = NO_LINE; return (z); } /** @brief Make special, internal mode. @param n Chain to insert into. @param m Moid number. **/ void make_special_mode (MOID_T ** n, int m) { (*n) = 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; } /** @brief Whether x matches c; case insensitive. @param x String to test. @param c To match, leading '-' or caps are mandatory. @param alt String terminator other than NULL_CHAR. @return Whether match. **/ BOOL_T match_string (char *x, char *c, char alt) { BOOL_T match = A68_TRUE; while ((IS_UPPER (c[0]) || IS_DIGIT (c[0]) || c[0] == '-') && match) { match = (BOOL_T) (match & (TO_LOWER (x[0]) == TO_LOWER ((c++)[0]))); if (!(x[0] == NULL_CHAR || x[0] == alt)) { x++; } } while (x[0] != NULL_CHAR && x[0] != alt && c[0] != NULL_CHAR && match) { match = (BOOL_T) (match & (TO_LOWER ((x++)[0]) == TO_LOWER ((c++)[0]))); } return ((BOOL_T) (match ? (x[0] == NULL_CHAR || x[0] == alt) : A68_FALSE)); } /** @brief Whether attributes match in subsequent nodes. @param p Node in syntax tree. @return Whether match. **/ BOOL_T whether (NODE_T * p, ...) { va_list vl; int a; va_start (vl, p); while ((a = va_arg (vl, int)) != STOP) { if (p != NO_NODE && a == WILDCARD) { FORWARD (p); } else if (p != NO_NODE && (a == KEYWORD)) { if (find_keyword_from_attribute (top_keyword, ATTRIBUTE (p)) != NO_KEYWORD) { FORWARD (p); } else { va_end (vl); return (A68_FALSE); } } else if (p != NO_NODE && (a >= 0 ? a == ATTRIBUTE (p) : (-a) != ATTRIBUTE (p))) { FORWARD (p); } else { va_end (vl); return (A68_FALSE); } } va_end (vl); return (A68_TRUE); } /** @brief Whether one of a series of attributes matches a node. @param p Node in syntax tree. @return Whether match. **/ BOOL_T is_one_of (NODE_T * p, ...) { if (p != NO_NODE) { va_list vl; int a; BOOL_T match = A68_FALSE; va_start (vl, p); while ((a = va_arg (vl, int)) != STOP) { match = (BOOL_T) (match | (BOOL_T) (IS (p, a))); } va_end (vl); return (match); } else { return (A68_FALSE); } } /** @brief Isolate nodes p-q making p a branch to p-q. @param p First node to branch. @param q Last node to branch. @param t Attribute for branch. **/ void make_sub (NODE_T * p, NODE_T * q, int t) { NODE_T *z = new_node (); ABEND (p == NO_NODE || q == NO_NODE, ERROR_INTERNAL_CONSISTENCY, "make_sub"); *z = *p; if (GINFO (p) != NO_GINFO) { GINFO (z) = 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; } /** @brief Find symbol table at level 'i'. @param n Node in syntax tree. @param i Level. @return See brief description. **/ 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); } } } /** @brief Time versus arbitrary origin. @return See brief description. **/ double seconds (void) { return ((double) clock () / (double) CLOCKS_PER_SEC); } /** @brief Whether 'p' is top of lexical level. @param p Node in syntax tree. @return See brief description. **/ BOOL_T 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 FORMAT_TEXT: 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 UNTIL_PART: case CONFORMITY_CLAUSE: case CONFORMITY_CHOICE: case CONFORMITY_IN_PART: case CONFORMITY_OUSE_PART: case WHILE_PART: { return (A68_TRUE); } default: { return (A68_FALSE); } } } /** @brief Some_node. @param t Token text. @return See brief description. **/ NODE_T *some_node (char *t) { NODE_T *z = new_node (); INFO (z) = new_node_info (); GINFO (z) = new_genie_info (); NSYMBOL (z) = t; return (z); } /** @brief Initialise use of elem-lists. **/ void init_postulates (void) { top_postulate = NO_POSTULATE; top_postulate_list = NO_POSTULATE; } /** @brief Make old postulates available for new use. @param start Start of list to save. @param stop First element to not save. **/ void free_postulate_list (POSTULATE_T *start, POSTULATE_T *stop) { POSTULATE_T *last; if (start == stop) { return; } for (last = start; NEXT (last) != stop; FORWARD (last)) { /* skip */; } NEXT (last) = top_postulate_list; top_postulate_list = start; } /** @brief Add elements to elem-list. @param p Postulate chain. @param a Moid 1. @param b Moid 2. **/ void make_postulate (POSTULATE_T ** p, MOID_T * a, MOID_T * b) { POSTULATE_T *new_one; if (top_postulate_list != NO_POSTULATE) { new_one = top_postulate_list; FORWARD (top_postulate_list); } else { new_one = (POSTULATE_T *) get_temp_heap_space ((size_t) SIZE_AL (POSTULATE_T)); new_postulates++; } A (new_one) = a; B (new_one) = b; NEXT (new_one) = *p; *p = new_one; } /** @brief Where elements are in the list. @param p Postulate chain. @param a Moid 1. @param b Moid 2. @return Containing postulate. **/ POSTULATE_T *is_postulated_pair (POSTULATE_T * p, MOID_T * a, MOID_T * b) { for (; p != NO_POSTULATE; FORWARD (p)) { if (A (p) == a && B (p) == b) { return (p); } } return (NO_POSTULATE); } /** @brief Where element is in the list. @param p Postulate chain. @param a Moid 1. @return Containing postulate. **/ POSTULATE_T *is_postulated (POSTULATE_T * p, MOID_T * a) { for (; p != NO_POSTULATE; FORWARD (p)) { if (A (p) == a) { return (p); } } return (NO_POSTULATE); } /*------------------+ | Control of C heap | +------------------*/ /** @brief Discard_heap. **/ void discard_heap (void) { if (heap_segment != NO_BYTE) { free (heap_segment); } fixed_heap_pointer = 0; temp_heap_pointer = 0; } /** @brief Initialise C and A68 heap management. **/ void init_heap (void) { int heap_a_size = A68_ALIGN (heap_size); int handle_a_size = A68_ALIGN (handle_pool_size); int frame_a_size = A68_ALIGN (frame_stack_size); int expr_a_size = A68_ALIGN (expr_stack_size); int total_size = A68_ALIGN (heap_a_size + handle_a_size + frame_a_size + 2 * expr_a_size); BYTE_T *core = (BYTE_T *) (A68_ALIGN_T *) malloc ((size_t) total_size); ABEND (core == NO_BYTE, ERROR_OUT_OF_CORE, NO_TEXT); heap_segment = &core[0]; handle_segment = &heap_segment[heap_a_size]; stack_segment = &handle_segment[handle_a_size]; fixed_heap_pointer = A68_ALIGNMENT; temp_heap_pointer = total_size; frame_start = 0; /* actually, heap_a_size + handle_a_size */ frame_end = stack_start = frame_start + frame_a_size; stack_end = stack_start + expr_a_size; } /** @brief Add token to the token tree. @param p Top token. @param t Token text. @return New entry. **/ TOKEN_T *add_token (TOKEN_T ** p, char *t) { char *z = new_fixed_string (t); while (*p != NO_TOKEN) { int k = strcmp (z, TEXT (*p)); if (k < 0) { p = &LESS (*p); } else if (k > 0) { p = &MORE (*p); } else { return (*p); } } *p = (TOKEN_T *) get_fixed_heap_space ((size_t) SIZE_AL (TOKEN_T)); TEXT (*p) = z; LESS (*p) = MORE (*p) = NO_TOKEN; return (*p); } /** @brief Find keyword, from token name. @param p Top keyword. @param t Token text to find. @return Entry. **/ KEYWORD_T *find_keyword (KEYWORD_T * p, char *t) { while (p != NO_KEYWORD) { int k = strcmp (t, TEXT (p)); if (k < 0) { p = LESS (p); } else if (k > 0) { p = MORE (p); } else { return (p); } } return (NO_KEYWORD); } /** @brief Find keyword, from attribute. @param p Top keyword. @param a Token attribute. @return Entry. **/ KEYWORD_T *find_keyword_from_attribute (KEYWORD_T * p, int a) { if (p == NO_KEYWORD) { return (NO_KEYWORD); } else if (a == ATTRIBUTE (p)) { return (p); } else { KEYWORD_T *z; if ((z = find_keyword_from_attribute (LESS (p), a)) != NO_KEYWORD) { return (z); } else if ((z = find_keyword_from_attribute (MORE (p), a)) != NO_KEYWORD) { return (z); } else { return (NO_KEYWORD); } } } /* A list of 10 ^ 2 ^ n for conversion purposes on IEEE 754 platforms */ #define MAX_DOUBLE_EXPO 511 static double pow_10[] = { 10.0, 100.0, 1.0e4, 1.0e8, 1.0e16, 1.0e32, 1.0e64, 1.0e128, 1.0e256 }; /** @brief 10 ** expo @param expo Exponent. @return See brief description. **/ double ten_up (int expo) { /* This way appears sufficiently accurate */ double dbl_expo = 1.0, *dep; BOOL_T neg_expo = (BOOL_T) (expo < 0); if (neg_expo) { expo = -expo; } ABEND (expo > MAX_DOUBLE_EXPO, "exponent too large", NO_TEXT); for (dep = pow_10; expo != 0; expo >>= 1, dep++) { if (expo & 0x1) { dbl_expo *= *dep; } } return (neg_expo ? 1 / dbl_expo : dbl_expo); } /** @brief Search first char in string. @param str String to search. @param c Character to find. @return Pointer to first "c" in "str". **/ char *a68g_strchr (char *str, int c) { return (strchr (str, c)); } /** @brief Safely append to buffer. @param dst Text buffer. @param src Text to append. @param len Size of dst. **/ void bufcat (char *dst, char *src, int len) { if (src != NO_TEXT) { char *d = dst, *s = src; int n = len, dlen; /* Find end of dst and left-adjust; do not go past end */ for (; n-- != 0 && d[0] != NULL_CHAR; d++) { ; } dlen = (int) (d - dst); n = len - dlen; if (n > 0) { while (s[0] != NULL_CHAR) { if (n != 1) { (d++)[0] = s[0]; n--; } s++; } d[0] = NULL_CHAR; } /* Better sure than sorry */ dst[len - 1] = NULL_CHAR; } } /** @brief Safely copy to buffer. @param dst Text buffer. @param src Text to append. @param len Size of dst. **/ void bufcpy (char *dst, char *src, int len) { if (src != NO_TEXT) { char *d = dst, *s = src; int n = len; /* Copy as many as fit */ if (n > 0 && --n > 0) { do { if (((d++)[0] = (s++)[0]) == NULL_CHAR) { break; } } while (--n > 0); } if (n == 0 && len > 0) { /* Not enough room in dst, so terminate */ d[0] = NULL_CHAR; } /* Better sure than sorry */ dst[len - 1] = NULL_CHAR; } } /** @brief grep in string (STRING, STRING, REF INT, REF INT) INT. @param pat Search string or regular expression if supported. @param str String to match. @param start Index of first character in first matching substring. @param end Index of last character in first matching substring. @return 0: match, 1: no match, 2: no core, 3: other error **/ int grep_in_string (char *pat, char *str, int *start, int *end) { #if defined HAVE_REGEX_H int rc, nmatch, k, max_k, widest; regex_t compiled; regmatch_t *matches; rc = regcomp (&compiled, pat, REG_NEWLINE | REG_EXTENDED); if (rc != 0) { regfree (&compiled); return (rc); } nmatch = (int) (RE_NSUB (&compiled)); if (nmatch == 0) { nmatch = 1; } matches = malloc ((size_t) (nmatch * SIZE_AL (regmatch_t))); if (nmatch > 0 && matches == NO_REGMATCH) { regfree (&compiled); return (2); } rc = regexec (&compiled, str, (size_t) nmatch, matches, 0); if (rc != 0) { regfree (&compiled); return (rc); } /* Find widest match. Do not assume it is the first one */ widest = 0; max_k = 0; for (k = 0; k < nmatch; k++) { int dif = (int) RM_EO (&matches[k]) - (int) RM_SO (&matches[k]); if (dif > widest) { widest = dif; max_k = k; } } if (start != NO_INT) { (*start) = (int) RM_SO (&matches[max_k]); } if (end != NO_INT) { (*end) = (int) RM_EO (&matches[max_k]); } free (matches); return (0); #else (void) start; (void) end; if (strstr (str, pat) != NO_TEXT) { return (0); } else { return (1); } #endif /* HAVE_REGEX_H */ } /* VMS style acronyms */ /* This code was contributed by Theo Vosse. */ static BOOL_T is_vowel (char); static BOOL_T is_consonant (char); static int qsort_strcmp (const void *, const void *); static BOOL_T is_coda (char *, int); static void get_init_sylls (char *, char *); static void reduce_vowels (char *); static int error_length (char *); static BOOL_T remove_extra_coda (char *); static void make_acronym (char *, char *); /** @brief Whether ch is a vowel. @param ch Character under test. @return See brief description. **/ static BOOL_T is_vowel (char ch) { return ((BOOL_T) (a68g_strchr ("aeiouAEIOU", ch) != NO_TEXT)); } /** @brief Whether ch is consonant. @param ch Character under test. @return See brief description. **/ static BOOL_T is_consonant (char ch) { return ((BOOL_T) (a68g_strchr ("qwrtypsdfghjklzxcvbnmQWRTYPSDFGHJKLZXCVBNM", ch) != NO_TEXT)); } static char *codas[] = { "BT", "CH", "CHS", "CHT", "CHTS", "CT", "CTS", "D", "DS", "DST", "DT", "F", "FD", "FDS", "FDST", "FDT", "FS", "FST", "FT", "FTS", "FTST", "G", "GD", "GDS", "GDST", "GDT", "GS", "GST", "GT", "H", "K", "KS", "KST", "KT", "KTS", "KTST", "L", "LD", "LDS", "LDST", "LDT", "LF", "LFD", "LFS", "LFT", "LG", "LGD", "LGT", "LK", "LKS", "LKT", "LM", "LMD", "LMS", "LMT", "LP", "LPS", "LPT", "LS", "LSD", "LST", "LT", "LTS", "LTST", "M", "MBT", "MBTS", "MD", "MDS", "MDST", "MDT", "MF", "MP", "MPT", "MPTS", "MPTST", "MS", "MST", "MT", "N", "ND", "NDR", "NDS", "NDST", "NDT", "NG", "NGD", "NGS", "NGST", "NGT", "NK", "NKS", "NKST", "NKT", "NS", "NSD", "NST", "NT", "NTS", "NTST", "NTZ", "NX", "P", "PS", "PST", "PT", "PTS", "PTST", "R", "RCH", "RCHT", "RD", "RDS", "RDST", "RDT", "RG", "RGD", "RGS", "RGT", "RK", "RKS", "RKT", "RLS", "RM", "RMD", "RMS", "RMT", "RN", "RND", "RNS", "RNST", "RNT", "RP", "RPS", "RPT", "RS", "RSD", "RST", "RT", "RTS", "S", "SC", "SCH", "SCHT", "SCS", "SD", "SK", "SKS", "SKST", "SKT", "SP", "SPT", "ST", "STS", "T", "TS", "TST", "W", "WD", "WDS", "WDST", "WS", "WST", "WT", "X", "XT" }; /** @brief Compare function to pass to bsearch. @param key Key to search. @param data Data to search in. @return Difference between key and data. **/ static int qsort_strcmp (const void *key, const void *data) { return (strcmp ((char *) key, *(char **) data)); } /** @brief Whether first characters of string are a coda. @param str String under test. @param len Number of characters. @return See brief description. **/ static BOOL_T is_coda (char *str, int len) { char str2[BUFFER_SIZE]; bufcpy (str2, str, BUFFER_SIZE); str2[len] = NULL_CHAR; return ((BOOL_T) (bsearch (str2, codas, sizeof (codas) / sizeof (char *), sizeof (char *), qsort_strcmp) != NULL)); } /** @brief Get_init_sylls. @param in Input string. @param out Output string. **/ static void get_init_sylls (char *in, char *out) { char *coda; while (*in != NULL_CHAR) { if (IS_ALPHA (*in)) { while (*in != NULL_CHAR && IS_ALPHA (*in) && !is_vowel (*in)) { *out++ = (char) TO_UPPER (*in++); } while (*in != NULL_CHAR && is_vowel (*in)) { *out++ = (char) TO_UPPER (*in++); } coda = out; while (*in != NULL_CHAR && is_consonant (*in)) { *out++ = (char) TO_UPPER (*in++); *out = NULL_CHAR; if (!is_coda (coda, (int) (out - coda))) { out--; break; } } while (*in != NULL_CHAR && IS_ALPHA (*in)) { in++; } *out++ = '+'; } else { in++; } } out[-1] = NULL_CHAR; } /** @brief Reduce vowels in string. @param str String. **/ static void reduce_vowels (char *str) { char *next; while (*str != NULL_CHAR) { next = a68g_strchr (str + 1, '+'); if (next == NO_TEXT) { break; } if (!is_vowel (*str) && is_vowel (next[1])) { while (str != next && !is_vowel (*str)) { str++; } if (str != next) { memmove (str, next, strlen (next) + 1); } } else { while (*str != NULL_CHAR && *str != '+') str++; } if (*str == '+') { str++; } } } /** @brief Remove boundaries in string. @param str String. @param max_len Maximym length. **/ static void remove_boundaries (char *str, int max_len) { int len = 0; while (*str != NULL_CHAR) { if (len >= max_len) { *str = NULL_CHAR; return; } if (*str == '+') { memmove (str, str + 1, strlen (str + 1) + 1); } else { str++; len++; } } } /** @brief Error_length. @param str String. @return See brief description. **/ static int error_length (char *str) { int len = 0; while (*str != NULL_CHAR) { if (*str != '+') { len++; } str++; } return (len); } /** @brief Remove extra coda. @param str String. @return Whether operation succeeded. **/ static BOOL_T remove_extra_coda (char *str) { int len; while (*str != NULL_CHAR) { if (is_vowel (*str) && str[1] != '+' && !is_vowel (str[1]) && str[2] != '+' && str[2] != NULL_CHAR) { for (len = 2; str[len] != NULL_CHAR && str[len] != '+'; len++); memmove (str + 1, str + len, strlen (str + len) + 1); return (A68_TRUE); } str++; } return (A68_FALSE); } /** @brief Make acronym. @param in Input string. @param out Output string. **/ static void make_acronym (char *in, char *out) { get_init_sylls (in, out); reduce_vowels (out); while (error_length (out) > 8 && remove_extra_coda (out)); remove_boundaries (out, 8); } /** @brief Push acronym of string on stack. @param p Node in syntax tree. **/ void genie_acronym (NODE_T * p) { A68_REF z; int len; char *u, *v; POP_REF (p, &z); len = a68_string_size (p, z); u = (char *) malloc ((size_t) (len + 1)); v = (char *) malloc ((size_t) (len + 1 + 8)); (void) a_to_c_string (p, u, z); if (u != NO_TEXT && u[0] != NULL_CHAR && v != NO_TEXT) { make_acronym (u, v); PUSH_REF (p, c_to_a_string (p, v, DEFAULT_WIDTH)); } else { PUSH_REF (p, empty_string (p)); } if (u != NO_TEXT) { free (u); } if (v != NO_TEXT) { free (v); } } /* Translate int attributes to string names */ static char *attribute_names[WILDCARD + 1] = { NO_TEXT, "A68_PATTERN", "ACCO_SYMBOL", "ACTUAL_DECLARER_MARK", "ALT_DO_PART", "ALT_DO_SYMBOL", "ALT_EQUALS_SYMBOL", "ALT_FORMAL_BOUNDS_LIST", "ANDF_SYMBOL", "AND_FUNCTION", "ANONYMOUS", "ARGUMENT", "ARGUMENT_LIST", "ASSERTION", "ASSERT_SYMBOL", "ASSIGNATION", "ASSIGN_SYMBOL", "ASSIGN_TO_SYMBOL", "AT_SYMBOL", "BEGIN_SYMBOL", "BITS_C_PATTERN", "BITS_DENOTATION", "BITS_PATTERN", "BITS_SYMBOL", "BOLD_COMMENT_SYMBOL", "BOLD_PRAGMAT_SYMBOL", "BOLD_TAG", "BOOLEAN_PATTERN", "BOOL_SYMBOL", "BOUND", "BOUNDS", "BOUNDS_LIST", "BRIEF_OUSE_PART", "BRIEF_CONFORMITY_OUSE_PART", "BRIEF_ELIF_PART", "BRIEF_OPERATOR_DECLARATION", "BUS_SYMBOL", "BYTES_SYMBOL", "BY_PART", "BY_SYMBOL", "CALL", "CASE_CHOICE_CLAUSE", "CASE_CLAUSE", "CASE_IN_PART", "CASE_OUSE_PART", "CASE_PART", "CASE_SYMBOL", "CAST", "CHANNEL_SYMBOL", "CHAR_C_PATTERN", "CHAR_SYMBOL", "CHOICE", "CHOICE_PATTERN", "CLASS_SYMBOL", "CLOSED_CLAUSE", "CLOSE_SYMBOL", "CODE_CLAUSE", "CODE_LIST", "CODE_SYMBOL", "COLLATERAL_CLAUSE", "COLLECTION", "COLON_SYMBOL", "COLUMN_FUNCTION", "COLUMN_SYMBOL", "COMMA_SYMBOL", "COMPLEX_PATTERN", "COMPLEX_SYMBOL", "COMPL_SYMBOL", "CONDITIONAL_CLAUSE", "CONFORMITY_CHOICE", "CONFORMITY_CLAUSE", "CONFORMITY_IN_PART", "CONFORMITY_OUSE_PART", "CONSTRUCT", "DECLARATION_LIST", "DECLARER", "DEFINING_IDENTIFIER", "DEFINING_INDICANT", "DEFINING_OPERATOR", "DENOTATION", "DEPROCEDURING", "DEREFERENCING", "DIAGONAL_FUNCTION", "DIAGONAL_SYMBOL", "DOTDOT_SYMBOL", "DOWNTO_SYMBOL", "DO_PART", "DO_SYMBOL", "DYNAMIC_REPLICATOR", "EDOC_SYMBOL", "ELIF_IF_PART", "ELIF_PART", "ELIF_SYMBOL", "ELSE_BAR_SYMBOL", "ELSE_OPEN_PART", "ELSE_PART", "ELSE_SYMBOL", "EMPTY_SYMBOL", "ENCLOSED_CLAUSE", "END_SYMBOL", "ENQUIRY_CLAUSE", "ENVIRON_NAME", "ENVIRON_SYMBOL", "EQUALS_SYMBOL", "ERROR", "ERROR_IDENTIFIER", "ESAC_SYMBOL", "EXIT_SYMBOL", "EXPONENT_FRAME", "FALSE_SYMBOL", "FIELD", "FIELD_IDENTIFIER", "FILE_SYMBOL", "FIRM", "FIXED_C_PATTERN", "FI_SYMBOL", "FLEX_SYMBOL", "FLOAT_C_PATTERN", "FORMAL_BOUNDS", "FORMAL_BOUNDS_LIST", "FORMAL_DECLARERS", "FORMAL_DECLARERS_LIST", "FORMAL_DECLARER_MARK", "FORMAT_A_FRAME", "FORMAT_CLOSE_SYMBOL", "FORMAT_DELIMITER_SYMBOL", "FORMAT_D_FRAME", "FORMAT_E_FRAME", "FORMAT_IDENTIFIER", "FORMAT_ITEM_A", "FORMAT_ITEM_B", "FORMAT_ITEM_C", "FORMAT_ITEM_D", "FORMAT_ITEM_E", "FORMAT_ITEM_ESCAPE", "FORMAT_ITEM_F", "FORMAT_ITEM_G", "FORMAT_ITEM_H", "FORMAT_ITEM_I", "FORMAT_ITEM_J", "FORMAT_ITEM_K", "FORMAT_ITEM_L", "FORMAT_ITEM_M", "FORMAT_ITEM_MINUS", "FORMAT_ITEM_N", "FORMAT_ITEM_O", "FORMAT_ITEM_P", "FORMAT_ITEM_PLUS", "FORMAT_ITEM_POINT", "FORMAT_ITEM_Q", "FORMAT_ITEM_R", "FORMAT_ITEM_S", "FORMAT_ITEM_T", "FORMAT_ITEM_U", "FORMAT_ITEM_V", "FORMAT_ITEM_W", "FORMAT_ITEM_X", "FORMAT_ITEM_Y", "FORMAT_ITEM_Z", "FORMAT_I_FRAME", "FORMAT_OPEN_SYMBOL", "FORMAT_PATTERN", "FORMAT_POINT_FRAME", "FORMAT_SYMBOL", "FORMAT_TEXT", "FORMAT_Z_FRAME", "FORMULA", "FOR_PART", "FOR_SYMBOL", "FROM_PART", "FROM_SYMBOL", "GENERAL_C_PATTERN", "GENERAL_PATTERN", "GENERATOR", "GENERIC_ARGUMENT", "GENERIC_ARGUMENT_LIST", "GOTO_SYMBOL", "GO_SYMBOL", "HEAP_SYMBOL", "IDENTIFIER", "IDENTITY_DECLARATION", "IDENTITY_RELATION", "IF_PART", "IF_SYMBOL", "INDICANT", "INITIALISER_SERIES", "INSERTION", "INTEGRAL_C_PATTERN", "INTEGRAL_MOULD", "INTEGRAL_PATTERN", "INT_DENOTATION", "INT_SYMBOL", "IN_SYMBOL", "IN_TYPE_MODE", "ISNT_SYMBOL", "IS_SYMBOL", "JUMP", "KEYWORD", "LABEL", "LABELED_UNIT", "LABEL_IDENTIFIER", "LABEL_SEQUENCE", "LITERAL", "LOCAL_LABEL", "LOC_SYMBOL", "LONGETY", "LONG_SYMBOL", "LOOP_CLAUSE", "LOOP_IDENTIFIER", "MAIN_SYMBOL", "MEEK", "MODE_BITS", "MODE_BOOL", "MODE_BYTES", "MODE_CHAR", "MODE_COMPLEX", "MODE_DECLARATION", "MODE_FILE", "MODE_FORMAT", "MODE_INT", "MODE_LONGLONG_BITS", "MODE_LONGLONG_COMPLEX", "MODE_LONGLONG_INT", "MODE_LONGLONG_REAL", "MODE_LONG_BITS", "MODE_LONG_BYTES", "MODE_LONG_COMPLEX", "MODE_LONG_INT", "MODE_LONG_REAL", "MODE_NO_CHECK", "MODE_PIPE", "MODE_REAL", "MODE_SOUND", "MODE_SYMBOL", "MONADIC_FORMULA", "MONAD_SEQUENCE", "NEW_SYMBOL", "NIHIL", "NIL_SYMBOL", "NORMAL_IDENTIFIER", "NO_SORT", "OCCA_SYMBOL", "OD_SYMBOL", "OF_SYMBOL", "OPEN_PART", "OPEN_SYMBOL", "OPERATOR", "OPERATOR_DECLARATION", "OPERATOR_PLAN", "OP_SYMBOL", "ORF_SYMBOL", "OR_FUNCTION", "OUSE_PART", "OUSE_SYMBOL", "OUT_PART", "OUT_SYMBOL", "OUT_TYPE_MODE", "PARALLEL_CLAUSE", "PARAMETER", "PARAMETER_IDENTIFIER", "PARAMETER_LIST", "PARAMETER_PACK", "PARTICULAR_PROGRAM", "PAR_SYMBOL", "PICTURE", "PICTURE_LIST", "PIPE_SYMBOL", "POINT_SYMBOL", "PRIMARY", "PRIORITY", "PRIORITY_DECLARATION", "PRIO_SYMBOL", "PROCEDURE_DECLARATION", "PROCEDURE_VARIABLE_DECLARATION", "PROCEDURING", "PROC_SYMBOL", "QUALIFIER", "RADIX_FRAME", "REAL_DENOTATION", "REAL_PATTERN", "REAL_SYMBOL", "REF_SYMBOL", "REPLICATOR", "ROUTINE_TEXT", "ROUTINE_UNIT", "ROWING", "ROWS_SYMBOL", "ROW_CHAR_DENOTATION", "ROW_FUNCTION", "ROW_SYMBOL", "SECONDARY", "SELECTION", "SELECTOR", "SEMA_SYMBOL", "SEMI_SYMBOL", "SERIAL_CLAUSE", "SERIES_MODE", "SHORTETY", "SHORT_SYMBOL", "SIGN_MOULD", "SKIP", "SKIP_SYMBOL", "SLICE", "SOFT", "SOME_CLAUSE", "SOUND_SYMBOL", "SPECIFICATION", "SPECIFIED_UNIT", "SPECIFIED_UNIT_LIST", "SPECIFIED_UNIT_UNIT", "SPECIFIER", "SPECIFIER_IDENTIFIER", "STANDARD", "STATIC_REPLICATOR", "STOWED_MODE", "STRING_C_PATTERN", "STRING_PATTERN", "STRING_SYMBOL", "STRONG", "STRUCTURED_FIELD", "STRUCTURED_FIELD_LIST", "STRUCTURE_PACK", "STRUCT_SYMBOL", "STYLE_II_COMMENT_SYMBOL", "STYLE_I_COMMENT_SYMBOL", "STYLE_I_PRAGMAT_SYMBOL", "SUB_SYMBOL", "SUB_UNIT", "TERTIARY", "THEN_BAR_SYMBOL", "THEN_PART", "THEN_SYMBOL", "TO_PART", "TO_SYMBOL", "TRANSPOSE_FUNCTION", "TRANSPOSE_SYMBOL", "TRIMMER", "TRUE_SYMBOL", "UNION_DECLARER_LIST", "UNION_PACK", "UNION_SYMBOL", "UNIT", "UNITING", "UNIT_LIST", "UNIT_SERIES", "UNTIL_PART", "UNTIL_SYMBOL", "VARIABLE_DECLARATION", "VIRTUAL_DECLARER_MARK", "VOIDING", "VOID_SYMBOL", "WEAK", "WHILE_PART", "WHILE_SYMBOL", "WIDENING", "WILDCARD" }; /** @brief Non_terminal_string. @param buf Text buffer. @param att Attribute. @return Buf, containing name of non terminal string. **/ char *non_terminal_string (char *buf, int att) { if (att > 0 && att < WILDCARD) { if (attribute_names[att] != NO_TEXT) { char *q = buf; bufcpy (q, attribute_names[att], BUFFER_SIZE); while (q[0] != NULL_CHAR) { if (q[0] == '_') { q[0] = '-'; } else { q[0] = (char) TO_LOWER (q[0]); } q++; } return (buf); } else { return (NO_TEXT); } } else { return (NO_TEXT); } } /** @brief Standard_environ_proc_name. @param f Routine that implements a standard environ item. @return Name of that what "f" implements. **/ char *standard_environ_proc_name (GPROC f) { TAG_T *i = IDENTIFIERS (a68g_standenv); for (; i != NO_TAG; FORWARD (i)) { if (PROCEDURE (i) == f) { return (NSYMBOL (NODE (i))); } } return (NO_TEXT); } /* Interactive help */ typedef struct A68_INFO A68_INFO; struct A68_INFO { char *cat; char *term; char *def; }; static A68_INFO info_text[] = { {"monitor", "breakpoint clear [all]", "clear breakpoints and watchpoint expression"}, {"monitor", "breakpoint clear breakpoints", "clear breakpoints"}, {"monitor", "breakpoint clear watchpoint", "clear watchpoint expression"}, {"monitor", "breakpoint [list]", "list breakpoints"}, {"monitor", "breakpoint \"n\" clear", "clear breakpoints in line \"n\""}, {"monitor", "breakpoint \"n\" if \"expression\"", "break in line \"n\" when expression evaluates to true"}, {"monitor", "breakpoint \"n\"", "set breakpoints in line \"n\""}, {"monitor", "breakpoint watch \"expression\"", "break on watchpoint expression when it evaluates to true"}, {"monitor", "calls [n]", "print \"n\" frames in the call stack (default n=3)"}, {"monitor", "continue, resume", "continue execution"}, {"monitor", "do \"command\", exec \"command\"", "pass \"command\" to the shell and print return code"}, {"monitor", "elems [n]", "print first \"n\" elements of rows (default n=24)"}, {"monitor", "evaluate \"expression\", x \"expression\"", "print result of \"expression\""}, {"monitor", "examine \"n\"", "print value of symbols named \"n\" in the call stack"}, {"monitor", "exit, hx, quit", "terminates the program"}, {"monitor", "finish, out", "continue execution until current procedure incarnation is finished"}, {"monitor", "frame 0", "set current stack frame to top of frame stack"}, {"monitor", "frame \"n\"", "set current stack frame to \"n\""}, {"monitor", "frame", "print contents of the current stack frame"}, {"monitor", "heap \"n\"", "print contents of the heap with address not greater than \"n\""}, {"monitor", "help [expression]", "print brief help text"}, {"monitor", "ht", "halts typing to standard output"}, {"monitor", "list [n]", "show \"n\" lines around the interrupted line (default n=10)"}, {"monitor", "next", "continue execution to next interruptable unit (do not enter routine-texts)"}, {"monitor", "prompt \"s\"", "set prompt to \"s\""}, {"monitor", "rerun, restart", "restarts a program without resetting breakpoints"}, {"monitor", "reset", "restarts a program and resets breakpoints"}, {"monitor", "rt", "resumes typing to standard output"}, {"monitor", "sizes", "print size of memory segments"}, {"monitor", "stack [n]", "print \"n\" frames in the stack (default n=3)"}, {"monitor", "step", "continue execution to next interruptable unit"}, {"monitor", "until \"n\"", "continue execution until line number \"n\" is reached"}, {"monitor", "where", "print the interrupted line"}, {"monitor", "xref \"n\"", "give detailed information on source line \"n\""}, {"options", "--assertions, --noassertions", "switch elaboration of assertions on or off"}, {"options", "--backtrace, --nobacktrace", "switch stack backtracing in case of a runtime error"}, {"options", "--boldstropping", "set stropping mode to bold stropping"}, {"options", "--brackets", "consider [ .. ] and { .. } as equivalent to ( .. )"}, {"options", "--check, --norun", "check syntax only, interpreter does not start"}, {"options", "--clock", "report execution time excluding compilation time"}, {"options", "--debug, --monitor", "start execution in the debugger and debug in case of runtime error"}, {"options", "--echo string", "echo \"string\" to standard output"}, {"options", "--execute unit", "execute algol 68 unit \"unit\""}, {"options", "--exit, --", "ignore next options"}, {"options", "--extensive", "make extensive listing"}, {"options", "--file string", "accept string as generic filename"}, {"options", "--frame \"number\"", "set frame stack size to \"number\""}, {"options", "--handles \"number\"", "set handle space size to \"number\""}, {"options", "--heap \"number\"", "set heap size to \"number\""}, {"options", "--keep, --nokeep", "switch object file deletion off or on"}, {"options", "--listing", "make concise listing"}, {"options", "--moids", "make overview of moids in listing file"}, {"options", "-O0, -O1, -O2, -O3", "switch compilation on and pass option to back-end C compiler"}, {"options", "--optimise, --nooptimise", "switch compilation on or off"}, {"options", "--pedantic", "equivalent to --warnings --portcheck"}, {"options", "--portcheck, --noportcheck", "switch portability warnings on or off"}, {"options", "--pragmats, --nopragmats", "switch elaboration of pragmat items on or off"}, {"options", "--precision \"number\"", "set precision for long long modes to \"number\" significant digits"}, {"options", "--preludelisting", "make a listing of preludes"}, {"options", "--pretty-print", "pretty-print the source file"}, {"options", "--print unit", "print value yielded by algol 68 unit \"unit\""}, {"options", "--quiet", "suppresses all warning diagnostics"}, {"options", "--quotestropping", "set stropping mode to quote stropping"}, {"options", "--reductions", "print parser reductions"}, {"options", "--run", "override --check/--norun options"}, {"options", "--rerun", "run using already compiled code"}, {"options", "--script", "set next option as source file name; pass further options to algol 68 program"}, {"options", "--source, --nosource", "switch listing of source lines in listing file on or off"}, {"options", "--stack \"number\"", "set expression stack size to \"number\""}, {"options", "--statistics", "print statistics in listing file"}, {"options", "--strict", "disable most extensions to Algol 68 syntax"}, {"options", "--timelimit \"number\"", "interrupt the interpreter after \"number\" seconds"}, {"options", "--trace, --notrace", "switch tracing of a running program on or off"}, {"options", "--tree, --notree", "switch syntax tree listing in listing file on or off"}, {"options", "--unused", "make an overview of unused tags in the listing file"}, {"options", "--verbose", "inform on program actions"}, {"options", "--version", "state version of the running copy"}, {"options", "--warnings, --nowarnings", "switch warning diagnostics on or off"}, {"options", "--xref, --noxref", "switch cross reference in the listing file on or off"}, {NO_TEXT, NO_TEXT, NO_TEXT} }; /** @brief Print_info. @param f File number. @param prompt Prompt text. @param k Index of info item to print. **/ static void print_info (FILE_T f, char *prompt, int k) { if (prompt != NO_TEXT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s %s: %s.", prompt, TERM (&info_text[k]), DEF (&info_text[k])) >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s: %s.", TERM (&info_text[k]), DEF (&info_text[k])) >= 0); } WRITELN (f, output_line); } /** @brief Apropos. @param f File number. @param prompt Prompt text. @param item Item to print. **/ void apropos (FILE_T f, char *prompt, char *item) { int k, n = 0; if (item == NO_TEXT) { for (k = 0; CAT (&info_text[k]) != NO_TEXT; k++) { print_info (f, prompt, k); } return; } for (k = 0; CAT (&info_text[k]) != NO_TEXT; k++) { if (grep_in_string (item, CAT (&info_text[k]), NO_INT, NO_INT) == 0) { print_info (f, prompt, k); n++; } } if (n > 0) { return; } for (k = 0; CAT (&info_text[k]) != NO_TEXT; k++) { if (grep_in_string (item, TERM (&info_text[k]), NO_INT, NO_INT) == 0 || grep_in_string (item, DEF (&info_text[k]), NO_INT, NO_INT) == 0) { print_info (f, prompt, k); n++; } } } /* Error handling routines */ #define TABULATE(n) (8 * (n / 8 + 1) - n) /** @brief Whether unprintable control character. @param ch Character under test. @return See brief description. **/ BOOL_T unprintable (char ch) { return ((BOOL_T) (!IS_PRINT (ch) && ch != TAB_CHAR)); } /** @brief Format for printing control character. @param ch Control character. @return String containing formatted character. **/ char *ctrl_char (int ch) { static char loc_str[SMALL_BUFFER_SIZE]; ch = TO_UCHAR (ch); if (IS_CNTRL (ch) && IS_LOWER (ch + 96)) { ASSERT (snprintf (loc_str, (size_t) SMALL_BUFFER_SIZE, "\\^%c", ch + 96) >= 0); } else { ASSERT (snprintf (loc_str, (size_t) SMALL_BUFFER_SIZE, "\\%02x", (unsigned) ch) >= 0); } return (loc_str); } /** @brief Widen single char to string. @param ch Character. @return (short) string **/ static char *char_to_str (char ch) { static char loc_str[2]; loc_str[0] = ch; loc_str[1] = NULL_CHAR; return (loc_str); } /** @brief Pretty-print diagnostic . @param f File number. @param p Text. **/ static void pretty_diag (FILE_T f, char *p) { int pos = 1, line_width = (f == STDOUT_FILENO ? term_width : MAX_TERM_WIDTH); while (p[0] != NULL_CHAR) { char *q; int k; /* Count the number of characters in token to print */ if (IS_GRAPH (p[0])) { for (k = 0, q = p; q[0] != BLANK_CHAR && q[0] != NULL_CHAR && k <= line_width; q++, k++) { ; } } else { k = 1; } /* Now see if there is space for the token */ if (k > line_width) { k = 1; } if ((pos + k) >= line_width) { WRITE (f, NEWLINE_STRING); pos = 1; } for (; k > 0; k--, p++, pos++) { WRITE (f, char_to_str (p[0])); } } for (; p[0] == BLANK_CHAR; p++, pos++) { WRITE (f, char_to_str (p[0])); } } /** @brief Abnormal end. @param reason Why abend. @param info Additional info. @param file Name of source file where abend. @param line Line in source file where abend. **/ void abend (char *reason, char *info, char *file, int line) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s: exiting: %s: %d: %s", a68g_cmd_name, file, line, reason) >= 0); if (info != NO_TEXT) { bufcat (output_line, ", ", BUFFER_SIZE); bufcat (output_line, info, BUFFER_SIZE); } if (errno != 0) { bufcat (output_line, " (", BUFFER_SIZE); bufcat (output_line, error_specification (), BUFFER_SIZE); bufcat (output_line, ")", BUFFER_SIZE); } io_close_tty_line (); pretty_diag (STDOUT_FILENO, output_line); a68g_exit (EXIT_FAILURE); } /** @brief Position in line . @param p Source line . @param q Node pertaining to "p". **/ static char *where_pos (LINE_T * p, NODE_T * q) { char *pos; if (q != NO_NODE && p == LINE (INFO (q))) { pos = CHAR_IN_LINE (INFO (q)); } else { pos = STRING (p); } if (pos == NO_TEXT) { pos = STRING (p); } for (; IS_SPACE (pos[0]) && pos[0] != NULL_CHAR; pos++) { ; } if (pos[0] == NULL_CHAR) { pos = STRING (p); } return (pos); } /** @brief Position in line where diagnostic points at. @param p Source line. @param d Diagnostic. @return Pointer to character to mark. **/ static char *diag_pos (LINE_T * p, DIAGNOSTIC_T * d) { char *pos; if (WHERE (d) != NO_NODE && p == LINE (INFO (WHERE (d)))) { pos = CHAR_IN_LINE (INFO (WHERE (d))); } else { pos = STRING (p); } if (pos == NO_TEXT) { pos = STRING (p); } for (; IS_SPACE (pos[0]) && pos[0] != NULL_CHAR; pos++) { ; } if (pos[0] == NULL_CHAR) { pos = STRING (p); } return (pos); } /** @brief Write source line to file with diagnostics. @param f File number. @param p Source line. @param nwhere Node where to mark. @param diag Whether and how to print diagnostics. **/ void write_source_line (FILE_T f, LINE_T * p, NODE_T * nwhere, int diag) { char *c, *c0; int continuations = 0; int pos = 5, col; int line_width = (f == STDOUT_FILENO ? term_width : MAX_TERM_WIDTH); BOOL_T line_ended; /* Terminate properly */ if ((STRING (p))[strlen (STRING (p)) - 1] == NEWLINE_CHAR) { (STRING (p))[strlen (STRING (p)) - 1] = NULL_CHAR; if ((STRING (p))[strlen (STRING (p)) - 1] == CR_CHAR) { (STRING (p))[strlen (STRING (p)) - 1] = NULL_CHAR; } } /* Print line number */ if (f == STDOUT_FILENO) { io_close_tty_line (); } else { WRITE (f, NEWLINE_STRING); } if (NUMBER (p) == 0) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, " ") >= 0); } else { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%-5d ", NUMBER (p) % 100000) >= 0); } WRITE (f, output_line); /* Pretty print line */ c = c0 = STRING (p); col = 1; line_ended = A68_FALSE; while (!line_ended) { int len = 0; char *new_pos = NO_TEXT; if (c[0] == NULL_CHAR) { bufcpy (output_line, "", BUFFER_SIZE); line_ended = A68_TRUE; } else { if (IS_GRAPH (c[0])) { char *c1; bufcpy (output_line, "", BUFFER_SIZE); for (c1 = c; IS_GRAPH (c1[0]) && len <= line_width - 5; c1++, len++) { bufcat (output_line, char_to_str (c1[0]), BUFFER_SIZE); } if (len > line_width - 5) { bufcpy (output_line, char_to_str (c[0]), BUFFER_SIZE); len = 1; } new_pos = &c[len]; col += len; } else if (c[0] == TAB_CHAR) { int n = TABULATE (col); len = n; col += n; bufcpy (output_line, "", BUFFER_SIZE); while (n--) { bufcat (output_line, " ", BUFFER_SIZE); } new_pos = &c[1]; } else if (unprintable (c[0])) { bufcpy (output_line, ctrl_char ((int) c[0]), BUFFER_SIZE); len = (int) strlen (output_line); new_pos = &c[1]; col++; } else { bufcpy (output_line, char_to_str (c[0]), BUFFER_SIZE); len = 1; new_pos = &c[1]; col++; } } if (!line_ended && (pos + len) <= line_width) { /* Still room - print a character */ WRITE (f, output_line); pos += len; c = new_pos; } else { /* First see if there are diagnostics to be printed */ BOOL_T y = A68_FALSE, z = A68_FALSE; DIAGNOSTIC_T *d = DIAGNOSTICS (p); if (d != NO_DIAGNOSTIC || nwhere != NO_NODE) { char *c1; for (c1 = c0; c1 != c; c1++) { y |= (BOOL_T) (nwhere != NO_NODE && p == LINE (INFO (nwhere)) ? c1 == where_pos (p, nwhere) : A68_FALSE); if (diag != A68_NO_DIAGNOSTICS) { for (d = DIAGNOSTICS (p); d != NO_DIAGNOSTIC; FORWARD (d)) { z = (BOOL_T) (z | (c1 == diag_pos (p, d))); } } } } /* If diagnostics are to be printed then print marks */ if (y || z) { DIAGNOSTIC_T *d2; char *c1; int col_2 = 1; WRITE (f, "\n "); for (c1 = c0; c1 != c; c1++) { int k = 0, diags_at_this_pos = 0; for (d2 = DIAGNOSTICS (p); d2 != NO_DIAGNOSTIC; FORWARD (d2)) { if (c1 == diag_pos (p, d2)) { diags_at_this_pos++; k = NUMBER (d2); } } if (y == A68_TRUE && c1 == where_pos (p, nwhere)) { bufcpy (output_line, "-", BUFFER_SIZE); } else if (diags_at_this_pos != 0) { if (diag == A68_NO_DIAGNOSTICS) { bufcpy (output_line, " ", BUFFER_SIZE); } else if (diags_at_this_pos == 1) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%c", digit_to_char (k)) >= 0); } else { bufcpy (output_line, "*", BUFFER_SIZE); } } else { if (unprintable (c1[0])) { int n = (int) strlen (ctrl_char (c1[0])); col_2 += 1; bufcpy (output_line, "", BUFFER_SIZE); while (n--) { bufcat (output_line, " ", BUFFER_SIZE); } } else if (c1[0] == TAB_CHAR) { int n = TABULATE (col_2); col_2 += n; bufcpy (output_line, "", BUFFER_SIZE); while (n--) { bufcat (output_line, " ", BUFFER_SIZE); } } else { bufcpy (output_line, " ", BUFFER_SIZE); col_2++; } } WRITE (f, output_line); } } /* Resume pretty printing of line */ if (!line_ended) { continuations++; ASSERT (snprintf (output_line, SNPRINTF_SIZE, "\n.%1d ", continuations) >= 0); WRITE (f, output_line); if (continuations >= 9) { WRITE (f, "..."); line_ended = A68_TRUE; } else { c0 = c; pos = 5; col = 1; } } } } /* while */ /* Print the diagnostics */ if (diag) { if (DIAGNOSTICS (p) != NO_DIAGNOSTIC) { DIAGNOSTIC_T *d; for (d = DIAGNOSTICS (p); d != NO_DIAGNOSTIC; FORWARD (d)) { if (diag == A68_RUNTIME_ERROR) { if (IS (d, A68_RUNTIME_ERROR)) { WRITE (f, NEWLINE_STRING); pretty_diag (f, TEXT (d)); } } else { WRITE (f, NEWLINE_STRING); pretty_diag (f, TEXT (d)); } } } } } /** @brief Write diagnostics to STDOUT. @param p Source line. @param what Severity of diagnostics to print. **/ void diagnostics_to_terminal (LINE_T * p, int what) { for (; p != NO_LINE; FORWARD (p)) { if (DIAGNOSTICS (p) != NO_DIAGNOSTIC) { BOOL_T z = A68_FALSE; DIAGNOSTIC_T *d = DIAGNOSTICS (p); for (; d != NO_DIAGNOSTIC; FORWARD (d)) { if (what == A68_ALL_DIAGNOSTICS) { z = (BOOL_T) (z | (IS (d, A68_WARNING) || IS (d, A68_ERROR) || IS (d, A68_SYNTAX_ERROR) || IS (d, A68_MATH_ERROR) || IS (d, A68_RUNTIME_ERROR) || IS (d, A68_SUPPRESS_SEVERITY))); } else if (what == A68_RUNTIME_ERROR) { z = (BOOL_T) (z | (IS (d, A68_RUNTIME_ERROR))); } } if (z) { write_source_line (STDOUT_FILENO, p, NO_NODE, what); } } } } /** @brief Give an intelligible error and exit. @param u Source line. @param v Where to mark. @param txt Error text. **/ void scan_error (LINE_T * u, char *v, char *txt) { if (errno != 0) { diagnostic_line (A68_SUPPRESS_SEVERITY, u, v, txt, error_specification ()); } else { diagnostic_line (A68_SUPPRESS_SEVERITY, u, v, txt, ERROR_UNSPECIFIED); } longjmp (RENDEZ_VOUS (&program), 1); } /** @brief Get severity text. @param sev Severity. @return See brief description. **/ static char *get_severity (int sev) { switch (sev) { case A68_ERROR: { return ("error"); } case A68_SYNTAX_ERROR: { return ("syntax error"); } case A68_RUNTIME_ERROR: { return ("runtime error"); } case A68_MATH_ERROR: { return ("math error"); } case A68_WARNING: { return ("warning"); } case A68_SUPPRESS_SEVERITY: { return (NO_TEXT); } default: { return (NO_TEXT); } } } /** @brief Print diagnostic. @param sev Severity. @param b Diagnostic text. */ static void write_diagnostic (int sev, char *b) { char st[SMALL_BUFFER_SIZE]; char *severity = get_severity (sev); if (severity == NO_TEXT) { ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s: %s.", a68g_cmd_name, b) >= 0); } else { bufcpy (st, get_severity (sev), SMALL_BUFFER_SIZE); ASSERT (snprintf (output_line, SNPRINTF_SIZE, "%s: %s: %s.", a68g_cmd_name, st, b) >= 0); } io_close_tty_line (); pretty_diag (STDOUT_FILENO, output_line); } /** @brief Add diagnostic to source line. @param line Source line. @param pos Where to mark. @param p Node to mark. @param sev Severity. @param b Diagnostic text. */ static void add_diagnostic (LINE_T * line, char *pos, NODE_T * p, int sev, char *b) { /* Add diagnostic and choose GNU style or non-GNU style */ DIAGNOSTIC_T *msg = (DIAGNOSTIC_T *) get_heap_space ((size_t) SIZE_AL (DIAGNOSTIC_T)); DIAGNOSTIC_T **ref_msg; char a[BUFFER_SIZE], st[SMALL_BUFFER_SIZE], nst[BUFFER_SIZE]; char *severity = get_severity (sev); int k = 1; if (line == NO_LINE && p == NO_NODE) { return; } if (in_monitor) { monitor_error (b, NO_TEXT); return; } nst[0] = NULL_CHAR; if (line == NO_LINE && p != NO_NODE) { line = LINE (INFO (p)); } while (line != NO_LINE && NUMBER (line) == 0) { FORWARD (line); } if (line == NO_LINE) { return; } ref_msg = &(DIAGNOSTICS (line)); while (*ref_msg != NO_DIAGNOSTIC) { ref_msg = &(NEXT (*ref_msg)); k++; } if (p != NO_NODE) { NODE_T *n = NEST (p); if (n != NO_NODE && NSYMBOL (n) != NO_TEXT) { char *nt = non_terminal_string (edit_line, ATTRIBUTE (n)); if (nt != NO_TEXT) { if (LINE_NUMBER (n) == 0) { ASSERT (snprintf (nst, SNPRINTF_SIZE, "detected in %s", nt) >= 0); } else { if (MOID (n) != NO_MOID) { if (LINE_NUMBER (n) == NUMBER (line)) { ASSERT (snprintf (nst, SNPRINTF_SIZE, "detected in %s %s starting at \"%.64s\" in this line", moid_to_string (MOID (n), MOID_ERROR_WIDTH, p), nt, NSYMBOL (n)) >= 0); } else { ASSERT (snprintf (nst, SNPRINTF_SIZE, "detected in %s %s starting at \"%.64s\" in line %d", moid_to_string (MOID (n), MOID_ERROR_WIDTH, p), nt, NSYMBOL (n), LINE_NUMBER (n)) >= 0); } } else { if (LINE_NUMBER (n) == NUMBER (line)) { ASSERT (snprintf (nst, SNPRINTF_SIZE, "detected in %s starting at \"%.64s\" in this line", nt, NSYMBOL (n)) >= 0); } else { ASSERT (snprintf (nst, SNPRINTF_SIZE, "detected in %s starting at \"%.64s\" in line %d", nt, NSYMBOL (n), LINE_NUMBER (n)) >= 0); } } } } } } if (severity == NO_TEXT) { if (FILENAME (line) != NO_TEXT && strcmp (FILE_SOURCE_NAME (&program), FILENAME (line)) == 0) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %x: %s", a68g_cmd_name, (unsigned) k, b) >= 0); } else if (FILENAME (line) != NO_TEXT) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", a68g_cmd_name, FILENAME (line), (unsigned) k, b) >= 0); } else { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %x: %s", a68g_cmd_name, (unsigned) k, b) >= 0); } } else { bufcpy (st, get_severity (sev), SMALL_BUFFER_SIZE); if (FILENAME (line) != NO_TEXT && strcmp (FILE_SOURCE_NAME (&program), FILENAME (line)) == 0) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", a68g_cmd_name, st, (unsigned) k, b) >= 0); } else if (FILENAME (line) != NO_TEXT) { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %s: %x: %s", a68g_cmd_name, FILENAME (line), st, (unsigned) k, b) >= 0); } else { ASSERT (snprintf (a, SNPRINTF_SIZE, "%s: %s: %x: %s", a68g_cmd_name, st, (unsigned) k, b) >= 0); } } msg = (DIAGNOSTIC_T *) get_heap_space ((size_t) SIZE_AL (DIAGNOSTIC_T)); *ref_msg = msg; ATTRIBUTE (msg) = sev; if (nst[0] != NULL_CHAR) { bufcat (a, " (", BUFFER_SIZE); bufcat (a, nst, BUFFER_SIZE); bufcat (a, ")", BUFFER_SIZE); } bufcat (a, ".", BUFFER_SIZE); TEXT (msg) = new_string (a, NO_TEXT); WHERE (msg) = p; LINE (msg) = line; SYMBOL (msg) = pos; NUMBER (msg) = k; NEXT (msg) = NO_DIAGNOSTIC; } /* Legend for special symbols: * as first character, copy rest of string literally # skip extra syntactical information @ non terminal A non terminal B keyword C context D argument in decimal H char argument K int argument as 'k', 'M' or 'G' L line number M moid - if error mode return without giving a message N mode - MODE (NIL) O moid - operand S quoted symbol, when possible with typographical display features U unquoted string literal X expected attribute Z quoted string literal. */ #define COMPOSE_DIAGNOSTIC\ if (t[0] == '*') {\ bufcat (b, &t[1], BUFFER_SIZE);\ } else while (t[0] != NULL_CHAR) {\ if (t[0] == '#') {\ extra_syntax = A68_FALSE;\ } else if (t[0] == '@') {\ char *nt = non_terminal_string (edit_line, ATTRIBUTE (p));\ if (t != NO_TEXT) {\ bufcat (b, nt, BUFFER_SIZE);\ } else {\ bufcat (b, "construct", BUFFER_SIZE);\ }\ } else if (t[0] == 'A') {\ int att = va_arg (args, int);\ char *nt = non_terminal_string (edit_line, att);\ if (nt != NO_TEXT) {\ bufcat (b, nt, BUFFER_SIZE);\ } else {\ bufcat (b, "construct", BUFFER_SIZE);\ }\ } else if (t[0] == 'B') {\ int att = va_arg (args, int);\ KEYWORD_T *nt = find_keyword_from_attribute (top_keyword, att);\ if (nt != NO_KEYWORD) {\ bufcat (b, "\"", BUFFER_SIZE);\ bufcat (b, TEXT (nt), BUFFER_SIZE);\ bufcat (b, "\"", BUFFER_SIZE);\ } else {\ bufcat (b, "keyword", BUFFER_SIZE);\ }\ } else if (t[0] == 'C') {\ int att = va_arg (args, int);\ if (att == NO_SORT) {\ bufcat (b, "this", BUFFER_SIZE);\ }\ if (att == SOFT) {\ bufcat (b, "a soft", BUFFER_SIZE);\ } else if (att == WEAK) {\ bufcat (b, "a weak", BUFFER_SIZE);\ } else if (att == MEEK) {\ bufcat (b, "a meek", BUFFER_SIZE);\ } else if (att == FIRM) {\ bufcat (b, "a firm", BUFFER_SIZE);\ } else if (att == STRONG) {\ bufcat (b, "a strong", BUFFER_SIZE);\ }\ } else if (t[0] == 'D') {\ int a = va_arg (args, int);\ char d[BUFFER_SIZE];\ ASSERT (snprintf(d, SNPRINTF_SIZE, "%d", a) >= 0);\ bufcat (b, d, BUFFER_SIZE);\ } else if (t[0] == 'H') {\ char *a = va_arg (args, char *);\ char d[SMALL_BUFFER_SIZE];\ ASSERT (snprintf(d, (size_t) SMALL_BUFFER_SIZE, "\"%c\"", a[0]) >= 0);\ bufcat (b, d, BUFFER_SIZE);\ } else if (t[0] == 'L') {\ LINE_T *a = va_arg (args, LINE_T *);\ char d[SMALL_BUFFER_SIZE];\ ABEND (a == NO_LINE, "null source line in error", NO_TEXT);\ if (NUMBER (a) == 0) {\ bufcat (b, "in standard environment", BUFFER_SIZE);\ } else {\ if (p != NO_NODE && NUMBER (a) == LINE_NUMBER (p)) {\ ASSERT (snprintf(d, (size_t) SMALL_BUFFER_SIZE, "in this line") >= 0);\ } else {\ ASSERT (snprintf(d, (size_t) SMALL_BUFFER_SIZE, "in line %d", NUMBER (a)) >= 0);\ }\ bufcat (b, d, BUFFER_SIZE);\ }\ } else if (t[0] == 'M') {\ moid = va_arg (args, MOID_T *);\ if (moid == NO_MOID || moid == MODE (ERROR)) {\ moid = MODE (UNDEFINED);\ }\ if (IS (moid, SERIES_MODE)) {\ if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) {\ bufcat (b, moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ } else {\ bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ }\ } else {\ bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ }\ } else if (t[0] == 'N') {\ bufcat (b, "NIL name of mode ", BUFFER_SIZE);\ moid = va_arg (args, MOID_T *);\ if (moid != NO_MOID) {\ bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ }\ } else if (t[0] == 'O') {\ moid = va_arg (args, MOID_T *);\ if (moid == NO_MOID || moid == MODE (ERROR)) {\ moid = MODE (UNDEFINED);\ }\ if (moid == MODE (VOID)) {\ bufcat (b, "UNION (VOID, ..)", BUFFER_SIZE);\ } else if (IS (moid, SERIES_MODE)) {\ if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK) {\ bufcat (b, moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ } else {\ bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ }\ } else {\ bufcat (b, moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);\ }\ } else if (t[0] == 'S') {\ if (p != NO_NODE && NSYMBOL (p) != NO_TEXT) {\ char *txt = NSYMBOL (p);\ char *sym = NCHAR_IN_LINE (p);\ int n = 0, size = (int) strlen (txt);\ bufcat (b, "\"", BUFFER_SIZE);\ if (txt[0] != sym[0] || (int) strlen (sym) < size) {\ bufcat (b, txt, BUFFER_SIZE);\ } else {\ while (n < size) {\ if (IS_PRINT (sym[0])) {\ char str[2];\ str[0] = sym[0];\ str[1] = NULL_CHAR;\ bufcat (b, str, BUFFER_SIZE);\ }\ if (TO_LOWER (txt[0]) == TO_LOWER (sym[0])) {\ txt ++;\ n ++;\ }\ sym ++;\ }\ }\ bufcat (b, "\"", BUFFER_SIZE);\ } else {\ bufcat (b, "symbol", BUFFER_SIZE);\ }\ } else if (t[0] == 'U') {\ char *loc_string = va_arg (args, char *);\ bufcat (b, loc_string, BUFFER_SIZE);\ } else if (t[0] == 'X') {\ int att = va_arg (args, int);\ char z[BUFFER_SIZE];\ /* ASSERT (snprintf(z, SNPRINTF_SIZE, "\"%s\"", TEXT (find_keyword_from_attribute (top_keyword, att))) >= 0); */\ (void) non_terminal_string (z, att);\ bufcat (b, new_string (z, NO_TEXT), BUFFER_SIZE);\ } else if (t[0] == 'Y') {\ char *loc_string = va_arg (args, char *);\ bufcat (b, loc_string, BUFFER_SIZE);\ } else if (t[0] == 'Z') {\ char *loc_string = va_arg (args, char *);\ bufcat (b, "\"", BUFFER_SIZE);\ bufcat (b, loc_string, BUFFER_SIZE);\ bufcat (b, "\"", BUFFER_SIZE);\ } else {\ char q[2];\ q[0] = t[0];\ q[1] = NULL_CHAR;\ bufcat (b, q, BUFFER_SIZE);\ }\ t++;\ } /** @brief Give a diagnostic message. @param sev Severity. @param p Node in syntax tree. @param loc_str Message string. @param ... various arguments needed by special symbols in loc_str **/ void diagnostic_node (STATUS_MASK sev, NODE_T * p, char *loc_str, ...) { va_list args; MOID_T *moid = NO_MOID; char *t = loc_str, b[BUFFER_SIZE]; BOOL_T force, extra_syntax = A68_TRUE, shortcut = A68_FALSE; int err = errno; va_start (args, loc_str); b[0] = NULL_CHAR; force = (BOOL_T) ((sev & A68_FORCE_DIAGNOSTICS) != 0); sev &= ~A68_FORCE_DIAGNOSTICS; /* No warnings? */ if (!force && sev == A68_WARNING && OPTION_NO_WARNINGS (&program)) { return; } if (sev == A68_WARNING && OPTION_QUIET (&program)) { return; } /* Suppressed? */ if (sev == A68_ERROR || sev == A68_SYNTAX_ERROR) { if (ERROR_COUNT (&program) == MAX_ERRORS) { bufcpy (b, "further error diagnostics suppressed", BUFFER_SIZE); sev = A68_ERROR; shortcut = A68_TRUE; } else if (ERROR_COUNT (&program) > MAX_ERRORS) { ERROR_COUNT (&program)++; return; } } else if (sev == A68_WARNING) { if (WARNING_COUNT (&program) == MAX_ERRORS) { bufcpy (b, "further warning diagnostics suppressed", BUFFER_SIZE); shortcut = A68_TRUE; } else if (WARNING_COUNT (&program) > MAX_ERRORS) { WARNING_COUNT (&program)++; return; } } if (shortcut == A68_FALSE) { /* Synthesize diagnostic message */ if ((sev & A68_NO_SYNTHESIS) != NULL_MASK) { sev &= ~A68_NO_SYNTHESIS; bufcat (b, t, BUFFER_SIZE); } else { COMPOSE_DIAGNOSTIC; /* Add information from errno, if any */ if (err != 0) { char *loc_str2 = new_string (error_specification (), NO_TEXT); if (loc_str2 != NO_TEXT) { char *stu; bufcat (b, " (", BUFFER_SIZE); for (stu = loc_str2; stu[0] != NULL_CHAR; stu++) { stu[0] = (char) TO_LOWER (stu[0]); } bufcat (b, loc_str2, BUFFER_SIZE); bufcat (b, ")", BUFFER_SIZE); } } } } /* Construct a diagnostic message */ if (sev == A68_WARNING) { WARNING_COUNT (&program)++; } else { ERROR_COUNT (&program)++; } if (p == NO_NODE) { write_diagnostic (sev, b); } else { add_diagnostic (NO_LINE, NO_TEXT, p, sev, b); } va_end (args); } /** @brief Give a diagnostic message. @param sev Severity. @param line Source line. @param pos Position in source line. @param loc_str Message string. @param ... various arguments needed by special symbols in loc_str **/ void diagnostic_line (STATUS_MASK sev, LINE_T * line, char *pos, char *loc_str, ...) { va_list args; MOID_T *moid = NO_MOID; char *t = loc_str, b[BUFFER_SIZE]; BOOL_T force, extra_syntax = A68_TRUE, shortcut = A68_FALSE; int err = errno; NODE_T *p = NO_NODE; b[0] = NULL_CHAR; va_start (args, loc_str); force = (BOOL_T) ((sev & A68_FORCE_DIAGNOSTICS) != 0); sev &= ~A68_FORCE_DIAGNOSTICS; /* No warnings? */ if (!force && sev == A68_WARNING && OPTION_NO_WARNINGS (&program)) { return; } if (sev == A68_WARNING && OPTION_QUIET (&program)) { return; } /* Suppressed? */ if (sev == A68_ERROR || sev == A68_SYNTAX_ERROR) { if (ERROR_COUNT (&program) == MAX_ERRORS) { bufcpy (b, "further error diagnostics suppressed", BUFFER_SIZE); sev = A68_ERROR; shortcut = A68_TRUE; } else if (ERROR_COUNT (&program) > MAX_ERRORS) { ERROR_COUNT (&program)++; return; } } else if (sev == A68_WARNING) { if (WARNING_COUNT (&program) == MAX_ERRORS) { bufcpy (b, "further warning diagnostics suppressed", BUFFER_SIZE); shortcut = A68_TRUE; } else if (WARNING_COUNT (&program) > MAX_ERRORS) { WARNING_COUNT (&program)++; return; } } if (!shortcut) { /* Synthesize diagnostic message */ COMPOSE_DIAGNOSTIC; /* Add information from errno, if any */ if (err != 0) { char *loc_str2 = new_string (error_specification (), NO_TEXT); if (loc_str2 != NO_TEXT) { char *stu; bufcat (b, " (", BUFFER_SIZE); for (stu = loc_str2; stu[0] != NULL_CHAR; stu++) { stu[0] = (char) TO_LOWER (stu[0]); } bufcat (b, loc_str2, BUFFER_SIZE); bufcat (b, ")", BUFFER_SIZE); } } } /* Construct a diagnostic message */ if (pos != NO_TEXT && IS_PRINT (*pos)) { bufcat (b, " (detected at", BUFFER_SIZE); if (*pos == '\"') { bufcat (b, " quote-character", BUFFER_SIZE); } else { bufcat (b, " character \"", BUFFER_SIZE); bufcat (b, char_to_str (*pos), BUFFER_SIZE); bufcat (b, "\"", BUFFER_SIZE); } bufcat (b, ")", BUFFER_SIZE); } if (sev == A68_WARNING) { WARNING_COUNT (&program)++; } else { ERROR_COUNT (&program)++; } if (line == NO_LINE) { write_diagnostic (sev, b); } else { add_diagnostic (line, pos, NO_NODE, sev, b); } va_end (args); } /** @brief Add keyword to the tree. @param p Top keyword. @param a Attribute. @param t Keyword text. **/ static void add_keyword (KEYWORD_T ** p, int a, char *t) { while (*p != NO_KEYWORD) { int k = strcmp (t, TEXT (*p)); if (k < 0) { p = &LESS (*p); } else { p = &MORE (*p); } } *p = (KEYWORD_T *) get_fixed_heap_space ((size_t) SIZE_AL (KEYWORD_T)); ATTRIBUTE (*p) = a; TEXT (*p) = t; LESS (*p) = MORE (*p) = NO_KEYWORD; } /** @brief Make tables of keywords and non-terminals. **/ void set_up_tables (void) { /* Entries are randomised to balance the tree */ if (OPTION_STRICT (&program) == A68_FALSE) { add_keyword (&top_keyword, ENVIRON_SYMBOL, "ENVIRON"); add_keyword (&top_keyword, DOWNTO_SYMBOL, "DOWNTO"); add_keyword (&top_keyword, UNTIL_SYMBOL, "UNTIL"); add_keyword (&top_keyword, CLASS_SYMBOL, "CLASS"); add_keyword (&top_keyword, NEW_SYMBOL, "NEW"); add_keyword (&top_keyword, DIAGONAL_SYMBOL, "DIAG"); add_keyword (&top_keyword, TRANSPOSE_SYMBOL, "TRNSP"); add_keyword (&top_keyword, ROW_SYMBOL, "ROW"); add_keyword (&top_keyword, COLUMN_SYMBOL, "COL"); add_keyword (&top_keyword, CODE_SYMBOL, "CODE"); add_keyword (&top_keyword, EDOC_SYMBOL, "EDOC"); add_keyword (&top_keyword, ANDF_SYMBOL, "THEF"); add_keyword (&top_keyword, ORF_SYMBOL, "ELSF"); add_keyword (&top_keyword, ANDF_SYMBOL, "ANDTH"); add_keyword (&top_keyword, ORF_SYMBOL, "OREL"); add_keyword (&top_keyword, ANDF_SYMBOL, "ANDF"); add_keyword (&top_keyword, ORF_SYMBOL, "ORF"); } add_keyword (&top_keyword, POINT_SYMBOL, "."); add_keyword (&top_keyword, COMPLEX_SYMBOL, "COMPLEX"); add_keyword (&top_keyword, ACCO_SYMBOL, "{"); add_keyword (&top_keyword, OCCA_SYMBOL, "}"); add_keyword (&top_keyword, SOUND_SYMBOL, "SOUND"); add_keyword (&top_keyword, COLON_SYMBOL, ":"); add_keyword (&top_keyword, THEN_BAR_SYMBOL, "|"); add_keyword (&top_keyword, SUB_SYMBOL, "["); add_keyword (&top_keyword, BY_SYMBOL, "BY"); add_keyword (&top_keyword, OP_SYMBOL, "OP"); add_keyword (&top_keyword, COMMA_SYMBOL, ","); add_keyword (&top_keyword, AT_SYMBOL, "AT"); add_keyword (&top_keyword, PRIO_SYMBOL, "PRIO"); add_keyword (&top_keyword, STYLE_I_COMMENT_SYMBOL, "CO"); add_keyword (&top_keyword, END_SYMBOL, "END"); add_keyword (&top_keyword, GO_SYMBOL, "GO"); add_keyword (&top_keyword, TO_SYMBOL, "TO"); add_keyword (&top_keyword, ELSE_BAR_SYMBOL, "|:"); add_keyword (&top_keyword, THEN_SYMBOL, "THEN"); add_keyword (&top_keyword, TRUE_SYMBOL, "TRUE"); add_keyword (&top_keyword, PROC_SYMBOL, "PROC"); add_keyword (&top_keyword, FOR_SYMBOL, "FOR"); add_keyword (&top_keyword, GOTO_SYMBOL, "GOTO"); add_keyword (&top_keyword, WHILE_SYMBOL, "WHILE"); add_keyword (&top_keyword, IS_SYMBOL, ":=:"); add_keyword (&top_keyword, ASSIGN_TO_SYMBOL, "=:"); add_keyword (&top_keyword, COMPL_SYMBOL, "COMPL"); add_keyword (&top_keyword, FROM_SYMBOL, "FROM"); add_keyword (&top_keyword, BOLD_PRAGMAT_SYMBOL, "PRAGMAT"); add_keyword (&top_keyword, BOLD_COMMENT_SYMBOL, "COMMENT"); add_keyword (&top_keyword, DO_SYMBOL, "DO"); add_keyword (&top_keyword, STYLE_II_COMMENT_SYMBOL, "#"); add_keyword (&top_keyword, CASE_SYMBOL, "CASE"); add_keyword (&top_keyword, LOC_SYMBOL, "LOC"); add_keyword (&top_keyword, CHAR_SYMBOL, "CHAR"); add_keyword (&top_keyword, ISNT_SYMBOL, ":/=:"); add_keyword (&top_keyword, REF_SYMBOL, "REF"); add_keyword (&top_keyword, NIL_SYMBOL, "NIL"); add_keyword (&top_keyword, ASSIGN_SYMBOL, ":="); add_keyword (&top_keyword, FI_SYMBOL, "FI"); add_keyword (&top_keyword, FILE_SYMBOL, "FILE"); add_keyword (&top_keyword, PAR_SYMBOL, "PAR"); add_keyword (&top_keyword, ASSERT_SYMBOL, "ASSERT"); add_keyword (&top_keyword, OUSE_SYMBOL, "OUSE"); add_keyword (&top_keyword, IN_SYMBOL, "IN"); add_keyword (&top_keyword, LONG_SYMBOL, "LONG"); add_keyword (&top_keyword, SEMI_SYMBOL, ";"); add_keyword (&top_keyword, EMPTY_SYMBOL, "EMPTY"); add_keyword (&top_keyword, MODE_SYMBOL, "MODE"); add_keyword (&top_keyword, IF_SYMBOL, "IF"); add_keyword (&top_keyword, OD_SYMBOL, "OD"); add_keyword (&top_keyword, OF_SYMBOL, "OF"); add_keyword (&top_keyword, STRUCT_SYMBOL, "STRUCT"); add_keyword (&top_keyword, STYLE_I_PRAGMAT_SYMBOL, "PR"); add_keyword (&top_keyword, BUS_SYMBOL, "]"); add_keyword (&top_keyword, SKIP_SYMBOL, "SKIP"); add_keyword (&top_keyword, SHORT_SYMBOL, "SHORT"); add_keyword (&top_keyword, IS_SYMBOL, "IS"); add_keyword (&top_keyword, ESAC_SYMBOL, "ESAC"); add_keyword (&top_keyword, CHANNEL_SYMBOL, "CHANNEL"); add_keyword (&top_keyword, REAL_SYMBOL, "REAL"); add_keyword (&top_keyword, STRING_SYMBOL, "STRING"); add_keyword (&top_keyword, BOOL_SYMBOL, "BOOL"); add_keyword (&top_keyword, ISNT_SYMBOL, "ISNT"); add_keyword (&top_keyword, FALSE_SYMBOL, "FALSE"); add_keyword (&top_keyword, UNION_SYMBOL, "UNION"); add_keyword (&top_keyword, OUT_SYMBOL, "OUT"); add_keyword (&top_keyword, OPEN_SYMBOL, "("); add_keyword (&top_keyword, BEGIN_SYMBOL, "BEGIN"); add_keyword (&top_keyword, FLEX_SYMBOL, "FLEX"); add_keyword (&top_keyword, VOID_SYMBOL, "VOID"); add_keyword (&top_keyword, BITS_SYMBOL, "BITS"); add_keyword (&top_keyword, ELSE_SYMBOL, "ELSE"); add_keyword (&top_keyword, EXIT_SYMBOL, "EXIT"); add_keyword (&top_keyword, HEAP_SYMBOL, "HEAP"); add_keyword (&top_keyword, INT_SYMBOL, "INT"); add_keyword (&top_keyword, BYTES_SYMBOL, "BYTES"); add_keyword (&top_keyword, PIPE_SYMBOL, "PIPE"); add_keyword (&top_keyword, FORMAT_SYMBOL, "FORMAT"); add_keyword (&top_keyword, SEMA_SYMBOL, "SEMA"); add_keyword (&top_keyword, CLOSE_SYMBOL, ")"); add_keyword (&top_keyword, AT_SYMBOL, "@"); add_keyword (&top_keyword, ELIF_SYMBOL, "ELIF"); add_keyword (&top_keyword, FORMAT_DELIMITER_SYMBOL, "$"); } /* Next are routines to calculate the size of a mode */ /** @brief Max unitings to simplout. @param p Node in syntax tree. @param max Maximum calculated moid size. **/ static void max_unitings_to_simplout (NODE_T * p, int *max) { for (; p != NO_NODE; FORWARD (p)) { if (IS (p, UNITING) && MOID (p) == MODE (SIMPLOUT)) { MOID_T *q = MOID (SUB (p)); if (q != MODE (SIMPLOUT)) { int size = moid_size (q); if (size > *max) { *max = size; } } } max_unitings_to_simplout (SUB (p), max); } } /** @brief Get max simplout size. @param p Node in syntax tree. **/ void get_max_simplout_size (NODE_T * p) { max_simplout_size = A68_REF_SIZE; /* For anonymous SKIP */ max_unitings_to_simplout (p, &max_simplout_size); } /** @brief Set moid sizes. @param z Moid to start from. **/ void set_moid_sizes (MOID_T * z) { for (; z != NO_MOID; FORWARD (z)) { SIZE (z) = moid_size (z); DIGITS (z) = moid_digits (z); } /* Next is guaranteed */ SIZE (MODE (LONG_REAL)) = moid_size (MODE (LONG_REAL)); DIGITS (MODE (LONG_REAL)) = moid_digits (MODE (LONG_REAL)); SIZE (MODE (LONGLONG_REAL)) = moid_size (MODE (LONGLONG_REAL)); DIGITS (MODE (LONGLONG_REAL)) = moid_digits (MODE (LONGLONG_REAL)); SIZEC (MODE (LONG_COMPLEX)) = SIZE (MODE (LONG_REAL)); SIZEC (MODE (REF_LONG_COMPLEX)) = SIZE (MODE (LONG_REAL)); DIGITSC (MODE (LONG_COMPLEX)) = DIGITS (MODE (LONG_REAL)); DIGITSC (MODE (REF_LONG_COMPLEX)) = DIGITS (MODE (LONG_REAL)); SIZEC (MODE (LONGLONG_COMPLEX)) = SIZE (MODE (LONGLONG_REAL)); SIZEC (MODE (REF_LONGLONG_COMPLEX)) = SIZE (MODE (LONGLONG_REAL)); DIGITSC (MODE (LONGLONG_COMPLEX)) = DIGITS (MODE (LONGLONG_REAL)); DIGITSC (MODE (REF_LONGLONG_COMPLEX)) = DIGITS (MODE (LONGLONG_REAL)); } /** @brief Moid size 2. @param p Moid to calculate. @return Moid size. **/ static int moid_size_2 (MOID_T * p) { if (p == NO_MOID) { return (0); } else if (EQUIVALENT (p) != NO_MOID) { return (moid_size_2 (EQUIVALENT (p))); } else if (p == MODE (HIP)) { return (0); } else if (p == MODE (VOID)) { return (0); } else if (p == MODE (INT)) { return (SIZE_AL (A68_INT)); } else if (p == MODE (LONG_INT)) { return ((int) size_long_mp ()); } else if (p == MODE (LONGLONG_INT)) { return ((int) size_longlong_mp ()); } else if (p == MODE (REAL)) { return (SIZE_AL (A68_REAL)); } else if (p == MODE (LONG_REAL)) { return ((int) size_long_mp ()); } else if (p == MODE (LONGLONG_REAL)) { return ((int) size_longlong_mp ()); } else if (p == MODE (BOOL)) { return (SIZE_AL (A68_BOOL)); } else if (p == MODE (CHAR)) { return (SIZE_AL (A68_CHAR)); } else if (p == MODE (ROW_CHAR)) { return (A68_REF_SIZE); } else if (p == MODE (BITS)) { return (SIZE_AL (A68_BITS)); } else if (p == MODE (LONG_BITS)) { return ((int) size_long_mp ()); } else if (p == MODE (LONGLONG_BITS)) { return ((int) size_longlong_mp ()); } else if (p == MODE (BYTES)) { return (SIZE_AL (A68_BYTES)); } else if (p == MODE (LONG_BYTES)) { return (SIZE_AL (A68_LONG_BYTES)); } else if (p == MODE (FILE)) { return (SIZE_AL (A68_FILE)); } else if (p == MODE (CHANNEL)) { return (SIZE_AL (A68_CHANNEL)); } else if (p == MODE (FORMAT)) { return (SIZE_AL (A68_FORMAT)); } else if (p == MODE (SEMA)) { return (A68_REF_SIZE); } else if (p == MODE (SOUND)) { return (SIZE_AL (A68_SOUND)); } else if (p == MODE (COLLITEM)) { return (SIZE_AL (A68_COLLITEM)); } else if (p == MODE (NUMBER)) { int k = 0; if (SIZE_AL (A68_INT) > k) { k = SIZE_AL (A68_INT); } if ((int) size_long_mp () > k) { k = (int) size_long_mp (); } if ((int) size_longlong_mp () > k) { k = (int) size_longlong_mp (); } if (SIZE_AL (A68_REAL) > k) { k = SIZE_AL (A68_REAL); } if ((int) size_long_mp () > k) { k = (int) size_long_mp (); } if ((int) size_longlong_mp () > k) { k = (int) size_longlong_mp (); } if (A68_REF_SIZE > k) { k = A68_REF_SIZE; } return (SIZE_AL (A68_UNION) + k); } else if (p == MODE (SIMPLIN)) { int k = 0; if (A68_REF_SIZE > k) { k = A68_REF_SIZE; } if (SIZE_AL (A68_FORMAT) > k) { k = SIZE_AL (A68_FORMAT); } if (SIZE_AL (A68_PROCEDURE) > k) { k = SIZE_AL (A68_PROCEDURE); } if (SIZE_AL (A68_SOUND) > k) { k = SIZE_AL (A68_SOUND); } return (SIZE_AL (A68_UNION) + k); } else if (p == MODE (SIMPLOUT)) { return (SIZE_AL (A68_UNION) + max_simplout_size); } else if (IS (p, REF_SYMBOL)) { return (A68_REF_SIZE); } else if (IS (p, PROC_SYMBOL)) { return (SIZE_AL (A68_PROCEDURE)); } else if (IS (p, ROW_SYMBOL) && p != MODE (ROWS)) { return (A68_REF_SIZE); } else if (p == MODE (ROWS)) { return (SIZE_AL (A68_UNION) + A68_REF_SIZE); } else if (IS (p, FLEX_SYMBOL)) { return (moid_size (SUB (p))); } else if (IS (p, STRUCT_SYMBOL)) { PACK_T *z = PACK (p); int size = 0; for (; z != NO_PACK; FORWARD (z)) { size += moid_size (MOID (z)); } return (size); } else if (IS (p, UNION_SYMBOL)) { PACK_T *z = PACK (p); int size = 0; for (; z != NO_PACK; FORWARD (z)) { if (moid_size (MOID (z)) > size) { size = moid_size (MOID (z)); } } return (SIZE_AL (A68_UNION) + size); } else if (PACK (p) != NO_PACK) { PACK_T *z = PACK (p); int size = 0; for (; z != NO_PACK; FORWARD (z)) { size += moid_size (MOID (z)); } return (size); } else { /* ? */ return (0); } } /** @brief Moid digits 2. @param p Moid to calculate. @return Moid digits. **/ static int moid_digits_2 (MOID_T * p) { if (p == NO_MOID) { return (0); } else if (EQUIVALENT (p) != NO_MOID) { return (moid_digits_2 (EQUIVALENT (p))); } else if (p == MODE (LONG_INT)) { return ((int) long_mp_digits ()); } else if (p == MODE (LONGLONG_INT)) { return ((int) longlong_mp_digits ()); } else if (p == MODE (LONG_REAL)) { return ((int) long_mp_digits ()); } else if (p == MODE (LONGLONG_REAL)) { return ((int) longlong_mp_digits ()); } else if (p == MODE (LONG_BITS)) { return ((int) long_mp_digits ()); } else if (p == MODE (LONGLONG_BITS)) { return ((int) longlong_mp_digits ()); } else { return (0); } } /** @brief Moid size. @param p Moid to set size. @return Moid size. **/ int moid_size (MOID_T * p) { SIZE (p) = A68_ALIGN (moid_size_2 (p)); return (SIZE (p)); } /** @brief Moid digits. @param p Moid to set size. @return Moid size. **/ int moid_digits (MOID_T * p) { DIGITS (p) = moid_digits_2 (p); return (DIGITS (p)); } /******************************/ /* A pretty printer for moids */ /******************************/ /** @brief Add string to MOID text. @param dst Text buffer. @param str String to concatenate. @param w Estimated width. **/ static void add_to_moid_text (char *dst, char *str, int *w) { bufcat (dst, str, BUFFER_SIZE); (*w) -= (int) strlen (str); } /** @brief Find a tag, searching symbol tables towards the root. @param table Symbol table to search. @param mode Mode of the tag. @return Entry in symbol table. **/ TAG_T *find_indicant_global (TABLE_T * table, MOID_T * mode) { if (table != NO_TABLE) { TAG_T *s; for (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); } } /** @brief Pack to string. @param b Text buffer. @param p Pack. @param w Estimated width. @param text Include field names. @param idf Print indicants if one exists in this range. **/ static void pack_to_string (char *b, PACK_T * p, int *w, BOOL_T text, NODE_T * idf) { for (; p != NO_PACK; FORWARD (p)) { moid_to_string_2 (b, MOID (p), w, idf); 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); } } } /** @brief Moid to string 2. @param b Text buffer. @param n Moid. @param w Estimated width. @param idf Print indicants if one exists in this range. **/ static void moid_to_string_2 (char *b, MOID_T * n, int *w, NODE_T * idf) { /* Oops. Should not happen */ if (n == NO_MOID) { add_to_moid_text (b, "null", w);; return; } /* Reference to self through REF or PROC */ if (is_postulated (postulates, n)) { add_to_moid_text (b, "SELF", w); return; } /* If declared by a mode-declaration, present the indicant */ if (idf != NO_NODE && ISNT (n, STANDARD)) { TAG_T *indy = find_indicant_global (TABLE (idf), n); if (indy != NO_TAG) { add_to_moid_text (b, NSYMBOL (NODE (indy)), w); return; } } /* Write the standard modes */ if (n == MODE (HIP)) { add_to_moid_text (b, "HIP", w); } else if (n == MODE (ERROR)) { add_to_moid_text (b, "ERROR", w); } else if (n == MODE (UNDEFINED)) { add_to_moid_text (b, "unresolved", w); } else if (n == MODE (C_STRING)) { add_to_moid_text (b, "C-STRING", w); } else if (n == MODE (COMPLEX) || n == MODE (COMPL)) { add_to_moid_text (b, "COMPLEX", w); } else if (n == MODE (LONG_COMPLEX) || n == MODE (LONG_COMPL)) { add_to_moid_text (b, "LONG COMPLEX", w); } else if (n == MODE (LONGLONG_COMPLEX) || n == MODE (LONGLONG_COMPL)) { add_to_moid_text (b, "LONG LONG COMPLEX", w); } else if (n == MODE (STRING)) { add_to_moid_text (b, "STRING", w); } else if (n == MODE (PIPE)) { add_to_moid_text (b, "PIPE", w); } else if (n == MODE (SOUND)) { add_to_moid_text (b, "SOUND", w); } else if (n == MODE (COLLITEM)) { add_to_moid_text (b, "COLLITEM", w); } else if (IS (n, IN_TYPE_MODE)) { add_to_moid_text (b, "\"SIMPLIN\"", w); } else if (IS (n, OUT_TYPE_MODE)) { add_to_moid_text (b, "\"SIMPLOUT\"", w); } else if (IS (n, ROWS_SYMBOL)) { add_to_moid_text (b, "\"ROWS\"", w); } else if (n == MODE (VACUUM)) { add_to_moid_text (b, "\"VACUUM\"", w); } else if (IS (n, VOID_SYMBOL) || IS (n, STANDARD) || IS (n, INDICANT)) { if (DIM (n) > 0) { int k = DIM (n); if ((*w) >= k * (int) strlen ("LONG ") + (int) strlen (NSYMBOL (NODE (n)))) { while (k --) { add_to_moid_text (b, "LONG ", w); } add_to_moid_text (b, NSYMBOL (NODE (n)), w); } else { add_to_moid_text (b, "..", w); } } else if (DIM (n) < 0) { int k = -DIM (n); if ((*w) >= k * (int) strlen ("LONG ") + (int) strlen (NSYMBOL (NODE (n)))) { while (k --) { add_to_moid_text (b, "LONG ", w); } add_to_moid_text (b, NSYMBOL (NODE (n)), w); } else { add_to_moid_text (b, "..", w); } } else if (DIM (n) == 0) { add_to_moid_text (b, NSYMBOL (NODE (n)), w); } /* Write compounded modes */ } else if (IS (n, REF_SYMBOL)) { if ((*w) >= (int) strlen ("REF ..")) { add_to_moid_text (b, "REF ", w); moid_to_string_2 (b, SUB (n), w, idf); } else { add_to_moid_text (b, "REF ..", w); } } else if (IS (n, FLEX_SYMBOL)) { if ((*w) >= (int) strlen ("FLEX ..")) { add_to_moid_text (b, "FLEX ", w); moid_to_string_2 (b, SUB (n), w, idf); } else { add_to_moid_text (b, "FLEX ..", w); } } else if (IS (n, ROW_SYMBOL)) { int j = (int) strlen ("[] ..") + (DIM (n) - 1) * (int) strlen (","); if ((*w) >= j) { int 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); } else if (DIM (n) == 1) { add_to_moid_text (b, "[] ..", w); } else { int 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 (n, STRUCT_SYMBOL)) { int j = (int) strlen ("STRUCT ()") + (DIM (n) - 1) * (int) strlen (".., ") + (int) strlen (".."); if ((*w) >= j) { POSTULATE_T *save = postulates; make_postulate (&postulates, n, NO_MOID); add_to_moid_text (b, "STRUCT (", w); pack_to_string (b, PACK (n), w, A68_TRUE, idf); add_to_moid_text (b, ")", w); free_postulate_list (postulates, save); postulates = save; } else { int k = DIM (n); add_to_moid_text (b, "STRUCT (", w); while (k-- > 0) { add_to_moid_text (b, ",", w); } add_to_moid_text (b, ")", w); } } else if (IS (n, UNION_SYMBOL)) { int j = (int) strlen ("UNION ()") + (DIM (n) - 1) * (int) strlen (".., ") + (int) strlen (".."); if ((*w) >= j) { POSTULATE_T *save = postulates; make_postulate (&postulates, n, NO_MOID); add_to_moid_text (b, "UNION (", w); pack_to_string (b, PACK (n), w, A68_FALSE, idf); add_to_moid_text (b, ")", w); free_postulate_list (postulates, save); postulates = save; } else { int k = DIM (n); add_to_moid_text (b, "UNION (", 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) >= (int) strlen ("PROC ..")) { add_to_moid_text (b, "PROC ", w); moid_to_string_2 (b, SUB (n), w, idf); } else { add_to_moid_text (b, "PROC ..", w); } } else if (IS (n, PROC_SYMBOL) && DIM (n) > 0) { int j = (int) strlen ("PROC () ..") + (DIM (n) - 1) * (int) strlen (".., ") + (int) strlen (".."); if ((*w) >= j) { POSTULATE_T *save = postulates; make_postulate (&postulates, n, NO_MOID); add_to_moid_text (b, "PROC (", w); pack_to_string (b, PACK (n), w, A68_FALSE, idf); add_to_moid_text (b, ") ", w); moid_to_string_2 (b, SUB (n), w, idf); free_postulate_list (postulates, save); postulates = save; } else { int k = DIM (n); add_to_moid_text (b, "PROC (", 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)) { int j = (int) strlen ("()") + (DIM (n) - 1) * (int) strlen (".., ") + (int) strlen (".."); if ((*w) >= j) { add_to_moid_text (b, "(", w); pack_to_string (b, PACK (n), w, A68_FALSE, idf); add_to_moid_text (b, ")", w); } else { int 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]; ASSERT (snprintf (str, (size_t) SMALL_BUFFER_SIZE, "\\%d", ATTRIBUTE (n)) >= 0); add_to_moid_text (b, str, w); } } /** @brief Pretty-formatted mode "n"; "w" is a measure of width. @param n Moid. @param w Estimated width; if w is exceeded, modes are abbreviated. @param idf Print indicants if one exists in this range. @return Text buffer. **/ char *moid_to_string (MOID_T * n, int w, NODE_T * idf) { char a[BUFFER_SIZE]; a[0] = NULL_CHAR; if (w >= BUFFER_SIZE) { w = BUFFER_SIZE - 1; } postulates = NO_POSTULATE; if (n != NO_MOID) { moid_to_string_2 (a, n, &w, idf); } else { bufcat (a, "null", BUFFER_SIZE); } return (new_string (a, NO_TEXT)); } algol68g-2.8/source/a68g.h0000644000175000001440000044267112223637102012155 00000000000000/** @file a68g.h @author J. Marcel van der Veer @brief General definitions for Algol 68 Genie. @section Copyright This file is part of Algol 68 Genie - an Algol 68 compiler-interpreter. Copyright 2001-2013 J. Marcel van der Veer . @section License 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 . @section Description Top level include file. **/ /** @mainpage Introduction to Algol 68 Genie **/ #if ! defined A68G_ALGOL68G_H #define A68G_ALGOL68G_H /*****************/ /* Configuration */ /*****************/ #include "a68g-config.h" /*************************/ /* Derived configuration */ /*************************/ /* Do we have a compiler? */ #if (! defined HAVE_GCC || defined NO_MINUS_C_MINUS_O || ! defined HAVE_DL) #undef HAVE_COMPILER #elif (! HAVE_MAC_OS_X && ! defined HAVE_EXPORT_DYNAMIC) #undef HAVE_COMPILER #elif ((defined HAVE_LINUX || defined HAVE_MAC_OS_X) && defined HAVE_DL) #define HAVE_COMPILER 1 #elif (defined HAVE_FREEBSD || defined HAVE_NETBSD) #define HAVE_COMPILER 1 #else #undef HAVE_COMPILER #endif /* Can we access the internet? */ #if (defined HAVE_NETDB_H && defined HAVE_NETINET_IN_H && defined HAVE_SYS_SOCKET_H) #if (defined HAVE_LINUX || defined HAVE_MAC_OS_X || defined HAVE_FREEBSD || defined HAVE_NETBSD) #define HAVE_HTTP #endif #endif /************/ /* Includes */ /************/ #if defined HAVE_SYS_TYPES_H #include #endif #if defined HAVE_STDIO_H #include #endif #if defined HAVE_LIMITS_H #include #endif #if defined HAVE_ASSERT_H #include #endif #if defined HAVE_CONIO_H #include #endif #if defined HAVE_CTYPE_H #include #endif #if defined HAVE_CURSES_H #include #elif defined HAVE_NCURSES_CURSES_H #include #endif #if defined HAVE_READLINE_READLINE_H #include #endif #if defined HAVE_READLINE_HISTORY_H #include #endif #if defined HAVE_DIRENT_H #include #endif #if defined HAVE_DL #include #endif #if defined HAVE_ERRNO_H #include #endif #if defined HAVE_FCNTL_H #include #endif #if defined HAVE_FLOAT_H #include #endif #if defined HAVE_LIBPQ-FE_H #include #endif #if defined HAVE_MATH_H #include #endif #if defined HAVE_NETDB_H #include #endif #if defined HAVE_NETINET_IN_H #include #endif #if defined HAVE_GNU_PLOTUTILS #include #endif #if defined HAVE_PTHREAD_H #include #endif #if defined HAVE_REGEX_H #include #endif #if defined HAVE_SETJMP_H #include #endif #if defined HAVE_SIGNAL_H #include #endif #if defined HAVE_STDARG_H #include #endif #if defined HAVE_STDDEF_H #include #endif #if defined HAVE_STDLIB_H #include #endif #if defined HAVE_STRING_H #include #endif #if defined HAVE_STRINGS_H #include #endif #if (defined HAVE_TERMIOS_H && ! defined TIOCGWINSZ) #include #elif (defined HAVE_TERMIOS_H && ! defined GWINSZ_IN_SYS_IOCTL) #include #endif #if defined HAVE_TIME_H #include #endif #if defined HAVE_UNISTD_H #include #endif #if defined HAVE_SYS_IOCTL_H #include #endif #if defined HAVE_SYS_RESOURCE_H #include #endif #if defined HAVE_SYS_SOCKET_H #include #endif #if defined HAVE_SYS_STAT_H #include #endif #if defined HAVE_SYS_TIME_H #include #endif #if defined HAVE_SYS_WAIT_H #include #endif #if defined HAVE_GSL_GSL_BLAS_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_MATH_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_MATH_H #include #endif #if defined HAVE_GSL_GSL_COMPLEX_MATH_H #include #endif #if defined HAVE_GSL_GSL_ERRNO_H #include #endif #if defined HAVE_GSL_GSL_ERRNO_H #include #endif #if defined HAVE_GSL_GSL_ERRNO_H #include #endif #if defined HAVE_GSL_GSL_FFT_COMPLEX_H #include #endif #if defined HAVE_GSL_GSL_INTEGRATION_H #include #endif #if defined HAVE_GSL_GSL_LINALG_H #include #endif #if defined HAVE_GSL_GSL_MATH_H #include #endif #if defined HAVE_GSL_GSL_MATH_H #include #endif #if defined HAVE_GSL_GSL_MATH_H #include #endif #if defined HAVE_GSL_GSL_MATRIX_H #include #endif #if defined HAVE_GSL_GSL_PERMUTATION_H #include #endif #if defined HAVE_GSL_GSL_SF_H #include #endif #if defined HAVE_GSL_GSL_SF_H #include #endif #if defined HAVE_GSL_GSL_SF_H #include #endif #if defined HAVE_GSL_GSL_VECTOR_H #include #endif /*****************/ /* Compatibility */ /*****************/ #if ! defined HAVE_SNPRINTF #define snprintf a68g_snprintf extern int a68g_snprintf (char *, size_t, char *, ...); #endif #if ! defined O_BINARY #define O_BINARY 0x0000 #endif /*************/ /* Constants */ /*************/ #define A68_DIR ".a68g" #define A68_FALSE ((BOOL_T) 0) #define A68_HISTORY_FILE ".a68g.edit.hist" #define A68_MAX_BITS (UINT_MAX) #define A68_MAX_INT (INT_MAX) #define A68_MAX_UNT (UINT_MAX) #define A68_NO_FILENO ((FILE_T) -1) #define A68_PI 3.1415926535897932384626433832795029 #define A68_PROTECTION (S_IRUSR | S_IWUSR | S_IRGRP | S_IROTH) /* -rw-r--r-- */ #define A68_READ_ACCESS (O_RDONLY) #define A68_TRUE ((BOOL_T) 1) #define A68_WRITE_ACCESS (O_WRONLY | O_CREAT | O_TRUNC) #define BACKSLASH_CHAR '\\' #define BINARY_EXTENSION ".o" #define BLANK_CHAR ' ' #define BUFFER_SIZE (KILOBYTE) #define BYTES_WIDTH 32 #define CR_CHAR '\r' #define DEFAULT_DOUBLE_DIGITS 5 #define DEFAULT_MP_RADIX 10000000 #define DEFAULT_WIDTH (-1) #define DIGIT_BLANK ((unsigned) 0x2) #define DIGIT_NORMAL ((unsigned) 0x1) #define DOUBLE_ACCURACY (DBL_DIG - 1) #define EMBEDDED_FORMAT A68_TRUE #define EOF_CHAR (EOF) #define ERROR_CHAR '*' #define ESCAPE_CHAR '\033' #define EXPONENT_CHAR 'e' #define FLIP_CHAR 'T' #define FLOP_CHAR 'F' #define FORMFEED_CHAR '\f' #define GIGABYTE (KILOBYTE * MEGABYTE) #define HIDDEN_TEMP_FILE_NAME ".a68g.tmp" #define INSERTION_BLANK ((unsigned) 0x20) #define INSERTION_NORMAL ((unsigned) 0x10) #define ITEM_NOT_USED (-1) #define KILOBYTE ((int) 1024) #define LIBRARY_EXTENSION ".so" #define LISTING_EXTENSION ".l" #define LOG2_10 3.321928094887362347870319430 #define LOG_MP_BASE 7 #define LONGLONG_EXP_WIDTH (EXP_WIDTH) #define LONG_BYTES_WIDTH 256 #define LONG_EXP_WIDTH (EXP_WIDTH) #define LONG_MP_DIGITS DEFAULT_DOUBLE_DIGITS #define MAX_ERRORS 8 #define MAX_MP_EXPONENT 142857 /* Arbitrary. Let M = MAX_REPR_INT then the largest range is M / Log M / LOG_MP_BASE */ #define MAX_OPEN_FILES 64 /* Some OS's won't open more than this number */ #define MAX_PRIORITY 9 #define MAX_REPR_INT 9007199254740992.0 /* 2^53, max int in a double */ #define MAX_TERM_HEIGTH 24 #define MAX_TERM_WIDTH (BUFFER_SIZE / 2) #define MAX_TRANSPUT_BUFFER (MAX_OPEN_FILES) #define MEGABYTE (KILOBYTE * KILOBYTE) #define MIN_MEM_SIZE (128 * KILOBYTE) #define MOID_ERROR_WIDTH 80 #define MOID_WIDTH 80 #define MONADS "%^&+-~!?" #define MP_BITS_BITS 23 #define MP_BITS_RADIX 8388608 /* Max power of two smaller than MP_RADIX */ #define MP_RADIX DEFAULT_MP_RADIX #define NEWLINE_CHAR '\n' #define NEWLINE_STRING "\n" #define NOMADS "> A68_ARRAY ----+ ARRAY: Description of row, ref to elements A68_TUPLE 1 | TUPLE: Bounds, one for every dimension ... | A68_TUPLE dim | ... | ... | Element 1 <---+ Element: Sequential row elements, in the heap ... Not always contiguous - trims! @endverbatim **/ struct A68_ARRAY { MOID_T *type; int dim, elem_size; ADDR_T slice_offset, field_offset; A68_REF array; }; struct A68_BITS { STATUS_MASK status; unsigned value; }; struct A68_BYTES { STATUS_MASK status; char value[BYTES_WIDTH + 1]; }; struct A68_CHANNEL { STATUS_MASK status; BOOL_T reset, set, get, put, bin, draw, compress; }; struct A68_BOOL { STATUS_MASK status; int value; }; struct A68_CHAR { STATUS_MASK status; int value; }; struct A68_COLLITEM { STATUS_MASK status; int count; }; struct A68_INT { STATUS_MASK status; int value; }; /** @struct A68_FORMAT @brief A68 format descriptor. @details A format behaves very much like a procedure. **/ struct A68_FORMAT { STATUS_MASK status; NODE_T *body; /**< Entry point in syntax tree. **/ ADDR_T environ; /**< Frame pointer to environ. **/ }; struct A68_LONG_BYTES { STATUS_MASK status; char value[LONG_BYTES_WIDTH + 1]; }; /** @struct A68_PROCEDURE @brief A68 procedure descriptor. **/ struct A68_PROCEDURE { STATUS_MASK status; union {NODE_T *node; GPROC *procedure;} body; /**< Entry point in syntax tree or precompiled C procedure. **/ A68_HANDLE *locale; /**< Locale for partial parametrisation. **/ MOID_T *type; ADDR_T environ; /**< Frame pointer to environ. **/ }; struct A68_REAL { STATUS_MASK status; double value; }; typedef A68_REAL A68_COMPLEX[2]; /** @struct A68_TUPLE @brief A tuple containing bounds etcetera for one dimension. **/ struct A68_TUPLE { int upper_bound, lower_bound, shift, span, k; }; struct A68_UNION { STATUS_MASK status; void *value; }; struct A68_SOUND { STATUS_MASK status; unsigned num_channels, sample_rate, bits_per_sample, num_samples, data_size; A68_REF data; }; struct A68_FILE { STATUS_MASK status; A68_CHANNEL channel; A68_FORMAT format; A68_PROCEDURE file_end_mended, page_end_mended, line_end_mended, value_error_mended, open_error_mended, transput_error_mended, format_end_mended, format_error_mended; A68_REF identification, terminator, string; ADDR_T frame_pointer, stack_pointer; /* Since formats open frames*/ BOOL_T read_mood, write_mood, char_mood, draw_mood, opened, open_exclusive, end_of_file, tmp_file; FILE_T fd; int transput_buffer, strpos, file_entry; struct { FILE *stream; #if defined HAVE_GNU_PLOTUTILS plPlotter *plotter; plPlotterParams *plotter_params; #endif BOOL_T device_made, device_opened; A68_REF device, page_size; int device_handle /* deprecated*/ , window_x_size, window_y_size; double x_coord, y_coord, red, green, blue; } device; #if defined HAVE_POSTGRESQL PGconn *connection; PGresult *result; #endif }; /*****************************************************************************/ /* Macros */ /*****************************************************************************/ #define COPY(d, s, n) {\ int _m_k = (n); BYTE_T *_m_u = (BYTE_T *) (d), *_m_v = (BYTE_T *) (s);\ while (_m_k--) {*_m_u++ = *_m_v++;}} #define COPY_ALIGNED(d, s, n) {\ int _m_k = (n); A68_ALIGN_T *_m_u = (A68_ALIGN_T *) (d), *_m_v = (A68_ALIGN_T *) (s);\ while (_m_k > 0) {*_m_u++ = *_m_v++; _m_k -= A68_ALIGNMENT;}} #define MOVE(d, s, n) {\ int _m_k = (int) (n); BYTE_T *_m_d = (BYTE_T *) (d), *_m_s = (BYTE_T *) (s);\ if (_m_s < _m_d) {\ _m_d += _m_k; _m_s += _m_k;\ while (_m_k--) {*(--_m_d) = *(--_m_s);}\ } else {\ while (_m_k--) {*(_m_d++) = *(_m_s++);}\ }} #define FILL(d, s, n) {\ int _m_k = (n); BYTE_T *_m_u = (BYTE_T *) (d), _m_v = (BYTE_T) (s);\ while (_m_k--) {*_m_u++ = _m_v;}} #define FILL_ALIGNED(d, s, n) {\ int _m_k = (n); A68_ALIGN_T *_m_u = (A68_ALIGN_T *) (d), _m_v = (A68_ALIGN_T) (s);\ while (_m_k > 0) {*_m_u++ = _m_v; _m_k -= A68_ALIGNMENT;}} #define ABEND(p, reason, info) {\ if (p) {\ abend ((char *) reason, (char *) info, __FILE__, __LINE__);\ }} #if defined HAVE_CURSES #define ASSERT(f) {\ if (!(f)) {\ if (a68g_curses_mode == A68_TRUE) {\ (void) attrset (A_NORMAL);\ (void) endwin ();\ a68g_curses_mode = A68_FALSE;\ }\ ABEND(A68_TRUE, "Return value failure", error_specification ())\ }} #else #define ASSERT(f) {\ ABEND((!(f)), "Return value failure", error_specification ())\ } #endif /* Some macros to overcome the ambiguity in having signed or unsigned char on various systems. PDP-11s and IBM 370s are still haunting us with this. */ #define IS_ALNUM(c) isalnum ((unsigned char) (c)) #define IS_ALPHA(c) isalpha ((unsigned char) (c)) #define IS_CNTRL(c) iscntrl ((unsigned char) (c)) #define IS_DIGIT(c) isdigit ((unsigned char) (c)) #define IS_GRAPH(c) isgraph ((unsigned char) (c)) #define IS_LOWER(c) islower ((unsigned char) (c)) #define IS_PRINT(c) isprint ((unsigned char) (c)) #define IS_PUNCT(c) ispunct ((unsigned char) (c)) #define IS_SPACE(c) isspace ((unsigned char) (c)) #define IS_UPPER(c) isupper ((unsigned char) (c)) #define IS_XDIGIT(c) isxdigit ((unsigned char) (c)) #define TO_LOWER(c) (char) tolower ((unsigned char) (c)) #define TO_UCHAR(c) ((c) >= 0 ? (int) (c) : (int) (UCHAR_MAX + (int) (c) + 1)) #define TO_UPPER(c) (char) toupper ((unsigned char) (c)) /* Macro's for fat A68 pointers */ #define ADDRESS(z) (&((IS_IN_HEAP (z) ? REF_POINTER (z) : stack_segment)[REF_OFFSET (z)])) #define ARRAY_ADDRESS(z) (&(REF_POINTER (z)[REF_OFFSET (z)])) #define DEREF(mode, expr) ((mode *) ADDRESS (expr)) #define FILE_DEREF(p) DEREF (A68_FILE, (p)) #define HEAP_ADDRESS(n) ((BYTE_T *) & (heap_segment[n])) #define IS_IN_FRAME(z) (STATUS (z) & IN_FRAME_MASK) #define IS_IN_HEAP(z) (STATUS (z) & IN_HEAP_MASK) #define IS_IN_STACK(z) (STATUS (z) & IN_STACK_MASK) #define IS_NIL(p) ((BOOL_T) ((STATUS (&(p)) & NIL_MASK) != 0)) #define LOCAL_ADDRESS(z) (& stack_segment[REF_OFFSET (z)]) #define REF_HANDLE(z) (HANDLE (z)) #define REF_OFFSET(z) (OFFSET (z)) #define REF_POINTER(z) (POINTER (REF_HANDLE (z))) #define REF_SCOPE(z) (SCOPE (z)) #define STACK_ADDRESS(n) ((BYTE_T *) &(stack_segment[(n)])) #define STACK_OFFSET(n) (STACK_ADDRESS (stack_pointer + (int) (n))) #define STACK_TOP (STACK_ADDRESS (stack_pointer)) /* Miscellaneous macros */ #define SIZE_AL(p) ((int) A68_ALIGN (sizeof (p))) #define A68_REF_SIZE (SIZE_AL (A68_REF)) #define A68_UNION_SIZE (SIZE_AL (A68_UNION)) #define A68_ALIGN(s) ((int) ((s) % A68_ALIGNMENT) == 0 ? (s) : ((s) - (s) % A68_ALIGNMENT + A68_ALIGNMENT)) #define A68_ALIGNMENT ((int) (sizeof (A68_ALIGN_T))) #define A68_ALIGN_8(s) ((int) ((s) % 8) == 0 ? (s) : ((s) - (s) % 8 + 8)) #define A68_SOUND_BYTES(s) ((int) (BITS_PER_SAMPLE (s)) / 8 + (int) (BITS_PER_SAMPLE (s) % 8 == 0 ? 0 : 1)) #define A68_SOUND_DATA_SIZE(s) ((int) (NUM_SAMPLES (s)) * (int) (NUM_CHANNELS (s)) * (int) (A68_SOUND_BYTES (s))) #define ABS(n) ((n) >= 0 ? (n) : -(n)) #define BACKWARD(p) (p = PREVIOUS (p)) #define BITS_WIDTH ((int) (1 + ceil (log ((double) A68_MAX_INT) / log((double) 2)))) #define DEFLEX(p) (DEFLEXED (p) != NO_MOID ? DEFLEXED(p) : (p)) #define EXP_WIDTH ((int) (1 + log10 ((double) DBL_MAX_10_EXP))) #define FORWARD(p) ((p) = NEXT (p)) #define INT_WIDTH ((int) (1 + floor (log ((double) A68_MAX_INT) / log ((double) 10)))) #define LONGLONG_INT_WIDTH (1 + LONGLONG_WIDTH) #define LONGLONG_REAL_WIDTH ((varying_mp_digits - 1) * LOG_MP_BASE) #define LONGLONG_WIDTH (varying_mp_digits * LOG_MP_BASE) #define LONG_INT_WIDTH (1 + LONG_WIDTH) #define LONG_REAL_WIDTH ((LONG_MP_DIGITS - 1) * LOG_MP_BASE) #define LONG_WIDTH (LONG_MP_DIGITS * LOG_MP_BASE) #define MP_BITS_WIDTH(k) ((int) ceil((k) * LOG_MP_BASE * LOG2_10) - 1) #define MP_BITS_WORDS(k) ((int) ceil ((double) MP_BITS_WIDTH (k) / (double) MP_BITS_BITS)) #define PM(m) (moid_to_string (m, 132, NO_NODE)) #define SIGN(n) ((n) == 0 ? 0 : ((n) > 0 ? 1 : -1)) #define STATUS_CLEAR(p, q) {STATUS (p) &= (~(q));} #define STATUS_SET(p, q) {STATUS (p) |= (q);} #define STATUS_TEST(p, q) ((STATUS (p) & (q)) != (unsigned) 0) #define WIS(p) where_in_source (STDOUT_FILENO, (p)) #define WRITE(f, s) io_write_string ((f), (s)); #define WRITELN(f, s) {io_close_tty_line (); WRITE ((f), (s));} /* Access macros */ #define A(p) ((p)->a) #define A68G_STANDENV_PROC(p) ((p)->a68g_standenv_proc) #define ACTION(p) ((p)->action) #define ACTIVE(p) ((p)->active) #define ADDR(p) ((p)->addr) #define ANNOTATION(p) ((p)->annotation) #define ANONYMOUS(p) ((p)->anonymous) #define APPLICATIONS(p) ((p)->applications) #define AP_INCREMENT(p) ((p)->ap_increment) #define ARGSIZE(p) ((p)->argsize) #define ARRAY(p) ((p)->array) #define ATTRIBUTE(p) ((p)->attribute) #define B(p) ((p)->b) #define BEGIN(p) ((p)->begin) #define BIN(p) ((p)->bin) #define BITS_PER_SAMPLE(p) ((p)->bits_per_sample) #define BLUE(p) ((p)->blue) #define BODY(p) ((p)->body) #define BSTATE(p) ((p)->bstate) #define BYTES(p) ((p)->bytes) #define CAST(p) ((p)->cast) #define CAT(p) ((p)->cat) #define CHANNEL(p) ((p)->channel) #define CHAR_IN_LINE(p) ((p)->char_in_line) #define CHAR_MOOD(p) ((p)->char_mood) #define CMD(p) ((p)->cmd) #define CMD_ROW(p) ((p)->cmd_row) #define CODE(p) ((p)->code) #define CODEX(p) ((p)->codex) #define COLLECT(p) ((p)->collect) #define COMPILED(p) ((p)->compiled) #define COMPILE_NAME(p) ((p)->compile_name) #define COMPILE_NODE(p) ((p)->compile_node) #define COMPRESS(p) ((p)->compress) #define CONNECTION(p) ((p)->connection) #define CONSTANT(p) ((p)->constant) #define COUNT(p) ((p)->count) #define CROSS_REFERENCE_SAFE(p) ((p)->cross_reference_safe) #define CUR_PTR(p) ((p)->cur_ptr) #define DATA(p) ((p)->data) #define DATA_SIZE(p) ((p)->data_size) #define DATE(p) ((p)->date) #define DEF(p) ((p)->def) #define DEFLEXED(p) ((p)->deflexed_mode) #define DERIVATE(p) ((p)->derivate) #define DEVICE(p) ((p)->device) #define DEVICE_HANDLE(p) ((p)->device_handle) #define DEVICE_MADE(p) ((p)->device_made) #define DEVICE_OPENED(p) ((p)->device_opened) #define DIAGNOSTICS(p) ((p)->diagnostics) #define DIGITS(p) ((p)->digits) #define DIGITSC(p) ((p)->digitsc) #define DIM(p) ((p)->dim) #define DISPLAY(p) ((p)->display) #define DRAW(p) ((p)->draw) #define DRAW_MOOD(p) ((p)->draw_mood) #define DUMP(p) ((p)->dump) #define DYNAMIC_LINK(p) ((p)->dynamic_link) #define DYNAMIC_SCOPE(p) ((p)->dynamic_scope) #define D_NAME(p) ((p)->d_name) #define ELEM_SIZE(p) ((p)->elem_size) #define END(p) ((p)->end) #define END_OF_FILE(p) ((p)->end_of_file) #define ENVIRON(p) ((p)->environ) #define EQUIVALENT(p) ((p)->equivalent_mode) #define EQUIVALENT_MODE(p) ((p)->equivalent_mode) #define ERROR_COUNT(p) ((p)->error_count) #define RENDEZ_VOUS(p) ((p)->rendez_vous) #define EXPR(p) ((p)->expr) #define F(p) ((p)->f) #define FACTOR(p) ((p)->factor) #define FD(p) ((p)->fd) #define FIELD_OFFSET(p) ((p)->field_offset) #define FILENAME(p) ((p)->filename) #define FILES(p) ((p)->files) #define FILE_BINARY_NAME(p) (FILES (p).binary.name) #define FILE_BINARY_OPENED(p) (FILES (p).binary.opened) #define FILE_BINARY_WRITEMOOD(p) (FILES (p).binary.writemood) #define FILE_DIAGS_FD(p) (FILES (p).diags.fd) #define FILE_DIAGS_NAME(p) (FILES (p).diags.name) #define FILE_DIAGS_OPENED(p) (FILES (p).diags.opened) #define FILE_DIAGS_WRITEMOOD(p) (FILES (p).diags.writemood) #define FILE_END_MENDED(p) ((p)->file_end_mended) #define FILE_ENTRY(p) ((p)->file_entry) #define FILE_GENERIC_NAME(p) (FILES (p).generic_name) #define FILE_INITIAL_NAME(p) (FILES (p).initial_name) #define FILE_LIBRARY_NAME(p) (FILES (p).library.name) #define FILE_LIBRARY_OPENED(p) (FILES (p).library.opened) #define FILE_LIBRARY_WRITEMOOD(p) (FILES (p).library.writemood) #define FILE_LISTING_FD(p) (FILES (p).listing.fd) #define FILE_LISTING_NAME(p) (FILES (p).listing.name) #define FILE_LISTING_OPENED(p) (FILES (p).listing.opened) #define FILE_LISTING_WRITEMOOD(p) (FILES (p).listing.writemood) #define FILE_OBJECT_FD(p) (FILES (p).object.fd) #define FILE_OBJECT_NAME(p) (FILES (p).object.name) #define FILE_OBJECT_OPENED(p) (FILES (p).object.opened) #define FILE_OBJECT_WRITEMOOD(p) (FILES (p).object.writemood) #define FILE_PATH(p) (FILES (p).path) #define FILE_PRETTY_FD(p) (FILES (p).pretty.fd) #define FILE_PRETTY_NAME(p) (FILES (p).pretty.name) #define FILE_PRETTY_OPENED(p) (FILES (p).pretty.opened) #define FILE_PRETTY_WRITEMOOD(p) (FILES (p).pretty.writemood) #define FILE_SCRIPT_NAME(p) (FILES (p).script.name) #define FILE_SCRIPT_OPENED(p) (FILES (p).script.opened) #define FILE_SCRIPT_WRITEMOOD(p) (FILES (p).script.writemood) #define FILE_SOURCE_FD(p) (FILES (p).source.fd) #define FILE_SOURCE_NAME(p) (FILES (p).source.name) #define FILE_SOURCE_OPENED(p) (FILES (p).source.opened) #define FILE_SOURCE_WRITEMOOD(p) (FILES (p).source.writemood) #define FIND(p) ((p)->find) #define FORMAT(p) ((p)->format) #define FORMAT_END_MENDED(p) ((p)->format_end_mended) #define FORMAT_ERROR_MENDED(p) ((p)->format_error_mended) #define FRAME(p) ((p)->frame) #define FRAME_LEVEL(p) ((p)->frame_level) #define FRAME_NO(p) ((p)->frame_no) #define FRAME_POINTER(p) ((p)->frame_pointer) #define FUNCTION(p) ((p)->function) #define G(p) ((p)->g) #define GINFO(p) ((p)->genie) #define GET(p) ((p)->get) #define GLOBAL_PROP(p) ((p)->global_prop) #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 HEAP_POINTER(p) ((p)->heap_pointer) #define H_ADDR(p) ((p)->h_addr) #define H_LENGTH(p) ((p)->h_length) #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_CMD(p) ((p)->in_cmd) #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_COMPILED(p) ((p)->is_compiled) #define IS_OPEN(p) ((p)->is_open) #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 LOCALE(p) ((p)->locale) #define LOC_ASSIGNED(p) ((p)->loc_assigned) #define LOWER_BOUND(p) ((p)->lower_bound) #define LWB(p) ((p)->lower_bound) #define MARKER(p) ((p)->marker) #define MATCH(p) ((p)->match) #define MODE(p) (a68_modes.p) #define MODIFIED(p) ((p)->modified) #define MOID(p) ((p)->type) #define MORE(p) ((p)->more) #define MSGS(p) ((p)->msgs) #define MULTIPLE(p) ((p)->multiple_mode) #define MULTIPLE_MODE(p) ((p)->multiple_mode) #define M_EO(p) ((p)->m_eo) #define M_MATCH(p) ((p)->match) #define M_SO(p) ((p)->m_so) #define NAME(p) ((p)->name) #define NEED_DNS(p) ((p)->need_dns) #define NEGATE(p) ((p)->negate) #define NEST(p) ((p)->nest) #define NEW_FILE(p) ((p)->new_file) #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 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 NPRAGMENT(p) (PRAGMENT (INFO (p))) #define NPRAGMENT_TYPE(p) (PRAGMENT_TYPE (INFO (p))) #define NSYMBOL(p) (SYMBOL (INFO (p))) #define NUM(p) ((p)->num) #define NUMBER(p) ((p)->number) #define NUM_CHANNELS(p) ((p)->num_channels) #define NUM_MATCH(p) ((p)->num_match) #define NUM_SAMPLES(p) ((p)->num_samples) #define OFFSET(p) ((p)->offset) #define OPENED(p) ((p)->opened) #define OPEN_ERROR_MENDED(p) ((p)->open_error_mended) #define OPEN_EXCLUSIVE(p) ((p)->open_exclusive) #define OPER(p) ((p)->oper) #define OPERATORS(p) ((p)->operators) #define OPTIONS(p) ((p)->options) #define OPTION_BACKTRACE(p) (OPTIONS (p).backtrace) #define OPTION_BRACKETS(p) (OPTIONS (p).brackets) #define OPTION_CHECK_ONLY(p) (OPTIONS (p).check_only) #define OPTION_CLOCK(p) (OPTIONS (p).clock) #define OPTION_COMPILE(p) (OPTIONS (p).compile) #define OPTION_CROSS_REFERENCE(p) (OPTIONS (p).cross_reference) #define OPTION_DEBUG(p) (OPTIONS (p).debug) #define OPTION_FOLD(p) (OPTIONS (p).fold) #define OPTION_INDENT(p) (OPTIONS (p).indent) #define OPTION_KEEP(p) (OPTIONS (p).keep) #define OPTION_LIST(p) (OPTIONS (p).list) #define OPTION_LOCAL(p) (OPTIONS (p).local) #define OPTION_MOID_LISTING(p) (OPTIONS (p).moid_listing) #define OPTION_NODEMASK(p) (OPTIONS (p).nodemask) #define OPTION_NO_WARNINGS(p) (OPTIONS (p).no_warnings) #define OPTION_OBJECT_LISTING(p) (OPTIONS (p).object_listing) #define OPTION_OPTIMISE(p) (OPTIONS (p).optimise) #define OPTION_OPT_LEVEL(p) (OPTIONS (p).opt_level) #define OPTION_PORTCHECK(p) (OPTIONS (p).portcheck) #define OPTION_PRAGMAT_SEMA(p) (OPTIONS (p).pragmat_sema) #define OPTION_PRETTY(p) (OPTIONS (p).pretty) #define OPTION_QUIET(p) (OPTIONS (p).quiet) #define OPTION_REDUCTIONS(p) (OPTIONS (p).reductions) #define OPTION_REGRESSION_TEST(p) (OPTIONS (p).regression_test) #define OPTION_RERUN(p) (OPTIONS (p).rerun) #define OPTION_RUN(p) (OPTIONS (p).run) #define OPTION_RUN_SCRIPT(p) (OPTIONS (p).run_script) #define OPTION_SOURCE_LISTING(p) (OPTIONS (p).source_listing) #define OPTION_STANDARD_PRELUDE_LISTING(p) (OPTIONS (p).standard_prelude_listing) #define OPTION_STATISTICS_LISTING(p) (OPTIONS (p).statistics_listing) #define OPTION_STRICT(p) (OPTIONS (p).strict) #define OPTION_STROPPING(p) (OPTIONS (p).stropping) #define OPTION_TARGET(p) (OPTIONS (p).target) #define OPTION_TIME_LIMIT(p) (OPTIONS (p).time_limit) #define OPTION_TRACE(p) (OPTIONS (p).trace) #define OPTION_TREE_LISTING(p) (OPTIONS (p).tree_listing) #define OPTION_UNUSED(p) (OPTIONS (p).unused) #define OPTION_VERBOSE(p) (OPTIONS (p).verbose) #define OPTION_VERSION(p) (OPTIONS (p).version) #define OUT(p) ((p)->out) #define OUTER(p) ((p)->outer) #define P(q) ((q)->p) #define PACK(p) ((p)->pack) #define PAGE_END_MENDED(p) ((p)->page_end_mended) #define A68_PAGE_SIZE(p) ((p)->page_size) #define PARAMETERS(p) ((p)->parameters) #define PARAMETER_LEVEL(p) ((p)->parameter_level) #define GSL_PARAMS(p) ((p)->params) #define PARENT(p) ((p)->parent) #define PARTIAL_LOCALE(p) ((p)->partial_locale) #define PARTIAL_PROC(p) ((p)->partial_proc) #define PAR_LEVEL(p) ((p)->par_level) #define PATTERN(p) ((p)->pattern) #define PERM(p) ((p)->perm) #define PERMS(p) ((p)->perms) #define IDF_ROW(p) ((p)->idf_row) #define PHASE(p) ((p)->phase) #define PLOTTER(p) ((p)->plotter) #define PLOTTER_PARAMS(p) ((p)->plotter_params) #define POINTER(p) ((p)->pointer) #define PORTABLE(p) ((p)->portable) #define POS(p) ((p)->pos) #define PRAGMENT(p) ((p)->pragment) #define PRAGMENT_TYPE(p) ((p)->pragment_type) #define PRECMD(p) ((p)->precmd) #define PREVIOUS(p) ((p)->previous) #define PRINT_STATUS(p) ((p)->print_status) #define PRIO(p) ((p)->priority) #define PROCEDURE(p) ((p)->procedure) #define PROCEDURE_LEVEL(p) ((p)->procedure_level) #define PROCESSED(p) ((p)->processed) #define PROC_FRAME(p) ((p)->proc_frame) #define PROC_OPS(p) ((p)->proc_ops) #define GPROP(p) (GINFO (p)->propagator) #define PROP(p) ((p)->propagator) #define PS(p) ((p)->ps) #define PUT(p) ((p)->put) #define P_PROTO(p) ((p)->p_proto) #define R(p) ((p)->r) #define RE(z) (VALUE (&(z)[0])) #define READ_MOOD(p) ((p)->read_mood) #define RED(p) ((p)->red) #define REPL(p) ((p)->repl) #define RESERVED(p) ((p)->reserved) #define RESET(p) ((p)->reset) #define RESET_ERRNO {errno = 0;} #define RESULT(p) ((p)->result) #define RE_NSUB(p) ((p)->re_nsub) #define RLIM_CUR(p) ((p)->rlim_cur) #define RLIM_MAX(p) ((p)->rlim_max) #define RM_EO(p) ((p)->rm_eo) #define RM_SO(p) ((p)->rm_so) #define ROWED(p) ((p)->rowed) #define S(p) ((p)->s) #define SAMPLE_RATE(p) ((p)->sample_rate) #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 SCALE_ROW(p) ((p)->scale_row) #define SCAN(p) ((p)->scan) #define SCAN_ERROR(c, u, v, txt) if (c) {scan_error (u, v, txt);} #define SCOPE(p) ((p)->scope) #define SCOPE_ASSIGNED(p) ((p)->scope_assigned) #define SEARCH(p) ((p)->search) #define SELECT(p) ((p)->select) #define SEQUENCE(p) ((p)->sequence) #define SET(p) ((p)->set) #define SHIFT(p) ((p)->shift) #define SHORT_ID(p) ((p)->short_id) #define SIN_ADDR(p) ((p)->sin_addr) #define SIN_FAMILY(p) ((p)->sin_family) #define SIN_PORT(p) ((p)->sin_port) #define SIZE(p) ((p)->size) #define SIZE1(p) ((p)->size1) #define SIZE2(p) ((p)->size2) #define SIZEC(p) ((p)->sizec) #define SLICE(p) ((p)->slice) #define SLICE_OFFSET(p) ((p)->slice_offset) #define SO(p) ((p)->so) #define SORT(p) ((p)->sort) #define SOURCE(p) ((p)->source) #define SOURCE_SCAN(p) ((p)->source_scan) #define SPAN(p) ((p)->span) #define STACK(p) ((p)->stack) #define STACK_POINTER(p) ((p)->stack_pointer) #define STACK_USED(p) ((p)->stack_used) #define STANDENV_MOID(p) ((p)->standenv_moid) #define START(p) ((p)->start) #define STATIC_LINK(p) ((p)->static_link) #define STATUS(p) ((p)->status) #define STATUS_IM(z) (STATUS (&(z)[1])) #define STATUS_RE(z) (STATUS (&(z)[0])) #define STR(p) ((p)->str) #define STREAM(p) ((p)->stream) #define STRING(p) ((p)->string) #define STRPOS(p) ((p)->strpos) #define ST_MODE(p) ((p)->st_mode) #define ST_MTIME(p) ((p)->st_mtime) #define SUB(p) ((p)->sub) #define SUBSET(p) ((p)->subset) #define SUB_MOID(p) (SUB (MOID (p))) #define SUB_NEXT(p) (SUB (NEXT (p))) #define SUB_SUB(p) (SUB (SUB (p))) #define SWAP(p) ((p)->swap) #define SYMBOL(p) ((p)->symbol) #define SYNC(p) ((p)->sync) #define SYNC_INDEX(p) ((p)->sync_index) #define SYNC_LINE(p) ((p)->sync_line) #define S_PORT(p) ((p)->s_port) #define TABLE(p) ((p)->symbol_table) #define TABS(p) ((p)->tabs) #define TAG_LEX_LEVEL(p) (LEVEL (TAG_TABLE (p))) #define TAG_TABLE(p) ((p)->symbol_table) #define TAX(p) ((p)->tag) #define TERM(p) ((p)->term) #define TERMINATOR(p) ((p)->terminator) #define TEXT(p) ((p)->text) #define THREAD_ID(p) ((p)->thread_id) #define THREAD_STACK_OFFSET(p) ((p)->thread_stack_offset) #define TMP_FILE(p) ((p)->tmp_file) #define TMP_TEXT(p) ((p)->tmp_text) #define TM_HOUR(p) ((p)->tm_hour) #define TM_ISDST(p) ((p)->tm_isdst) #define TM_MDAY(p) ((p)->tm_mday) #define TM_MIN(p) ((p)->tm_min) #define TM_MON(p) ((p)->tm_mon) #define TM_SEC(p) ((p)->tm_sec) #define TM_WDAY(p) ((p)->tm_wday) #define TM_YEAR(p) ((p)->tm_year) #define TOF(p) ((p)->tof) #define TOP_LINE(p) ((p)->top_line) #define TOP_MOID(p) ((p)->top_moid) #define TOP_NODE(p) ((p)->top_node) #define TOP_REFINEMENT(p) ((p)->top_refinement) #define TRANS(p) ((p)->trans) #define TRANSIENT(p) ((p)->transient) #define TRANSPUT_BUFFER(p) ((p)->transput_buffer) #define TRANSPUT_ERROR_MENDED(p) ((p)->transput_error_mended) #define TREE_LISTING_SAFE(p) ((p)->tree_listing_safe) #define TRIM(p) ((p)->trim) #define TUPLE(p) ((p)->tuple) #define TV_SEC(p) ((p)->tv_sec) #define TV_USEC(p) ((p)->tv_usec) #define UNDO(p) ((p)->undo) #define UNDO_LINE(p) ((p)->undo_line) #define UNION_OFFSET (SIZE_AL (A68_UNION)) #define UNIT(p) ((p)->unit) #define UPB(p) ((p)->upper_bound) #define UPPER_BOUND(p) ((p)->upper_bound) #define USE(p) ((p)->use) #define VAL(p) ((p)->val) #define VALUE(p) ((p)->value) #define VALUE_ERROR_MENDED(p) ((p)->value_error_mended) #define WARNING_COUNT(p) ((p)->warning_count) #define WHERE(p) ((p)->where) #define IS(p, s) (ATTRIBUTE (p) == (s)) #define IS_COERCION(p) ((p)->is_coercion) #define IS_LITERALLY(p, s) (strcmp (NSYMBOL (p), s) == 0) #define IS_NEW_LEXICAL_LEVEL(p) ((p)->is_new_lexical_level) #define ISNT(p, s) (! IS (p, s)) #define IS_REF_FLEX(m)\ (IS (m, REF_SYMBOL) && IS (SUB (m), FLEX_SYMBOL)) #define WINDOW_X_SIZE(p) ((p)->window_x_size) #define WINDOW_Y_SIZE(p) ((p)->window_y_size) #define WRITE_MOOD(p) ((p)->write_mood) #define X(p) ((p)->x) #define X_COORD(p) ((p)->x_coord) #define Y(p) ((p)->y) #define YOUNGEST_ENVIRON(p) ((p)->youngest_environ) #define Y_COORD(p) ((p)->y_coord) /***********************************/ /* Interpreter related definitions */ /***********************************/ /* Prelude errors can also occur in the constant folder */ #define PRELUDE_ERROR(cond, p, txt, add)\ if (cond) {\ errno = ERANGE;\ if (in_execution) {\ diagnostic_node (A68_RUNTIME_ERROR, p, txt, add);\ exit_genie (p, A68_RUNTIME_ERROR);\ } else {\ diagnostic_node (A68_MATH_ERROR, p, txt, add);\ }} /* Check on a NIL name */ #define CHECK_REF(p, z, m)\ if (! INITIALISED (&z)) {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_EMPTY_VALUE_FROM, (m));\ exit_genie ((p), A68_RUNTIME_ERROR);\ } else if (IS_NIL (z)) {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_ACCESSING_NIL, (m));\ exit_genie ((p), A68_RUNTIME_ERROR);\ } /***************************/ /* Macros for row-handling */ /***************************/ #define GET_DESCRIPTOR(a, t, p)\ a = (A68_ARRAY *) ARRAY_ADDRESS (p);\ t = (A68_TUPLE *) & (((BYTE_T *) (a)) [SIZE_AL (A68_ARRAY)]); #define GET_DESCRIPTOR2(a, t1, t2, p)\ a = (A68_ARRAY *) ARRAY_ADDRESS (p);\ t1 = (A68_TUPLE *) & (((BYTE_T *) (a)) [SIZE_AL (A68_ARRAY)]);\ t2 = (A68_TUPLE *) & (((BYTE_T *) (a)) [SIZE_AL (A68_ARRAY) + sizeof (A68_TUPLE)]); #define PUT_DESCRIPTOR(a, t1, p) {\ BYTE_T *a_p = ARRAY_ADDRESS (p);\ *(A68_ARRAY *) a_p = (a);\ *(A68_TUPLE *) &(((BYTE_T *) (a_p)) [SIZE_AL (A68_ARRAY)]) = (t1);\ } #define PUT_DESCRIPTOR2(a, t1, t2, p) {\ BYTE_T *a_p = ARRAY_ADDRESS (p);\ *(A68_ARRAY *) a_p = (a);\ *(A68_TUPLE *) &(((BYTE_T *) (a_p)) [SIZE_AL (A68_ARRAY)]) = (t1);\ *(A68_TUPLE *) &(((BYTE_T *) (a_p)) [SIZE_AL (A68_ARRAY) + sizeof (A68_TUPLE)]) = (t2);\ } #define ROW_SIZE(t) ((UPB (t) >= LWB (t)) ? (UPB (t) - LWB (t) + 1) : 0) #define ROW_ELEMENT(a, k) (((ADDR_T) k + SLICE_OFFSET (a)) * ELEM_SIZE (a) + FIELD_OFFSET (a)) #define INDEX_1_DIM(a, t, k) ROW_ELEMENT (a, (SPAN (t) * (int) (k) - SHIFT (t))) /*************/ /* Execution */ /*************/ #define EXECUTE_UNIT_2(p, dest) {\ PROP_T *_prop_ = &GPROP (p);\ last_unit = p;\ dest = (*(UNIT (_prop_))) (SOURCE (_prop_));} #define EXECUTE_UNIT(p) {\ PROP_T *_prop_ = &GPROP (p);\ last_unit = p;\ (void) (*(UNIT (_prop_))) (SOURCE (_prop_));} #define EXECUTE_UNIT_TRACE(p) {\ if (STATUS_TEST (p, (BREAKPOINT_MASK | BREAKPOINT_TEMPORARY_MASK | \ BREAKPOINT_INTERRUPT_MASK | BREAKPOINT_WATCH_MASK | BREAKPOINT_TRACE_MASK))) {\ single_step ((p), STATUS (p));\ }\ EXECUTE_UNIT (p);} /***********************************/ /* Stuff for the garbage collector */ /***********************************/ /* Check whether the heap fills */ #define PREEMPTIVE_GC {\ double f = (double) heap_pointer / (double) heap_size;\ double h = (double) free_handle_count / (double) max_handle_count;\ if ((f > 0.8 || h < 0.2) && stack_pointer == stack_start) {\ gc_heap ((NODE_T *) p, frame_pointer);\ }} /* Save a handle from the GC */ #define BLOCK_GC_HANDLE(z) {\ if (IS_IN_HEAP (z)) {\ STATUS_SET (REF_HANDLE(z), BLOCK_GC_MASK);\ }} #define UNBLOCK_GC_HANDLE(z) {\ if (IS_IN_HEAP (z)) {\ STATUS_CLEAR (REF_HANDLE (z), BLOCK_GC_MASK);\ }} /* Tests for objects of mode INT */ #define CHECK_INT_ADDITION(p, i, j)\ PRELUDE_ERROR (\ ((j) > 0 && (i) > (INT_MAX - (j))) || ((j) < 0 && (i) < (-INT_MAX - (j))),\ p, ERROR_MATH, MODE (INT)) #define CHECK_INT_SUBTRACTION(p, i, j)\ CHECK_INT_ADDITION(p, i, -(j)) #define CHECK_INT_MULTIPLICATION(p, i, j)\ PRELUDE_ERROR (\ (j) != 0 && ABS (i) > INT_MAX / ABS (j),\ p, ERROR_MATH, MODE (INT)) #define CHECK_INT_DIVISION(p, i, j)\ PRELUDE_ERROR ((j) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (INT)) #define CHECK_INDEX(p, k, t) {\ if (VALUE (k) < LWB (t) || VALUE (k) > UPB (t)) {\ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_INDEX_OUT_OF_BOUNDS);\ exit_genie (p, A68_RUNTIME_ERROR);\ }} /* Tests for objects of mode REAL */ #if defined HAVE_IEEE_754 #define NOT_A_REAL(x) (!finite (x)) #define CHECK_REAL_REPRESENTATION(p, u) PRELUDE_ERROR (NOT_A_REAL (u), p, ERROR_MATH, MODE (REAL)) #define CHECK_REAL_ADDITION(p, u, v) CHECK_REAL_REPRESENTATION (p, (u) + (v)) #define CHECK_REAL_SUBTRACTION(p, u, v) CHECK_REAL_REPRESENTATION (p, (u) - (v)) #define CHECK_REAL_MULTIPLICATION(p, u, v) CHECK_REAL_REPRESENTATION (p, (u) * (v)) #define CHECK_REAL_DIVISION(p, u, v)\ PRELUDE_ERROR ((v) == 0, p, ERROR_DIVISION_BY_ZERO, MODE (REAL)) #define CHECK_COMPLEX_REPRESENTATION(p, u, v)\ PRELUDE_ERROR (NOT_A_REAL (u) || NOT_A_REAL (v), p, ERROR_MATH, MODE (COMPLEX)) #else #define CHECK_REAL_REPRESENTATION(p, u) {;} #define CHECK_REAL_ADDITION(p, u, v) {;} #define CHECK_REAL_SUBTRACTION(p, u, v) {;} #define CHECK_REAL_MULTIPLICATION(p, u, v) {;} #define CHECK_REAL_DIVISION(p, u, v) {;} #define CHECK_COMPLEX_REPRESENTATION(p, u, v) {;} #endif #define MATH_RTE(p, z, m, t)\ PRELUDE_ERROR (z, (p), (t == NO_TEXT ? ERROR_MATH : t), (m)) /* Macro's for stack checking. Since the stacks grow by small amounts at a time (A68 rows are in the heap), we check the stacks only at certain points: where A68 recursion may set in, or in the garbage collector. We check whether there still is sufficient overhead to make it to the next check. */ #define TOO_COMPLEX "program too complex" #define SYSTEM_STACK_USED (ABS ((int) (system_stack_offset - &stack_offset))) #define LOW_SYSTEM_STACK_ALERT(p) {\ BYTE_T stack_offset;\ if (stack_size > 0 && SYSTEM_STACK_USED >= stack_limit) {\ errno = 0;\ if ((p) == NO_NODE) {\ ABEND (A68_TRUE, TOO_COMPLEX, ERROR_STACK_OVERFLOW);\ } else {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_STACK_OVERFLOW);\ exit_genie ((p), A68_RUNTIME_ERROR);\ }}} #define LOW_STACK_ALERT(p) {\ LOW_SYSTEM_STACK_ALERT (p);\ if ((p) != NO_NODE && (frame_pointer >= frame_stack_limit || stack_pointer >= expr_stack_limit)) { \ errno = 0;\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_STACK_OVERFLOW);\ exit_genie ((p), A68_RUNTIME_ERROR);\ }} /******************************/ /* Operations on stack frames */ /******************************/ #define FRAME_ADDRESS(n) ((BYTE_T *) &(stack_segment[n])) #define FACT(n) ((ACTIVATION_RECORD *) FRAME_ADDRESS (n)) #define FRAME_CLEAR(m) FILL ((BYTE_T *) FRAME_OFFSET (FRAME_INFO_SIZE), 0, (m)) #define FRAME_BLOCKS(n) (BLOCKS (FACT (n))) #define FRAME_DYNAMIC_LINK(n) (DYNAMIC_LINK (FACT (n))) #define FRAME_DNS(n) (DYNAMIC_SCOPE (FACT (n))) #define FRAME_INCREMENT(n) (AP_INCREMENT (TABLE (FRAME_TREE(n)))) #define FRAME_INFO_SIZE (A68_ALIGN_8 ((int) sizeof (ACTIVATION_RECORD))) #define FRAME_JUMP_STAT(n) (JUMP_STAT (FACT (n))) #define FRAME_LEXICAL_LEVEL(n) (FRAME_LEVEL (FACT (n))) #define FRAME_LOCAL(n, m) (FRAME_ADDRESS ((n) + FRAME_INFO_SIZE + (m))) #define FRAME_NUMBER(n) (FRAME_NO (FACT (n))) #define FRAME_OBJECT(n) (FRAME_OFFSET (FRAME_INFO_SIZE + (n))) #define FRAME_OFFSET(n) (FRAME_ADDRESS (frame_pointer + (n))) #define FRAME_PARAMETER_LEVEL(n) (PARAMETER_LEVEL (FACT (n))) #define FRAME_PARAMETERS(n) (PARAMETERS (FACT (n))) #define FRAME_PROC_FRAME(n) (PROC_FRAME (FACT (n))) #define FRAME_SIZE(fp) (FRAME_INFO_SIZE + FRAME_INCREMENT (fp)) #define FRAME_STATIC_LINK(n) (STATIC_LINK (FACT (n))) #define FRAME_TREE(n) (NODE (FACT (n))) #if defined HAVE_PARALLEL_CLAUSE #define FRAME_THREAD_ID(n) (THREAD_ID (FACT (n))) #endif #define FOLLOW_SL(dest, l) {\ (dest) = frame_pointer;\ if ((l) <= FRAME_PARAMETER_LEVEL ((dest))) {\ (dest) = FRAME_PARAMETERS ((dest));\ }\ while ((l) != FRAME_LEXICAL_LEVEL ((dest))) {\ (dest) = FRAME_STATIC_LINK ((dest));\ }} #define FOLLOW_STATIC_LINK(dest, l) {\ if ((l) == global_level && global_pointer > 0) {\ (dest) = global_pointer;\ } else {\ FOLLOW_SL (dest, l)\ }} #define FRAME_GET(dest, cast, p) {\ ADDR_T _m_z;\ FOLLOW_STATIC_LINK (_m_z, LEVEL (GINFO (p)));\ (dest) = (cast *) & (OFFSET (GINFO (p))[_m_z]);\ } #define GET_FRAME(dest, cast, level, offset) {\ ADDR_T _m_z;\ FOLLOW_SL (_m_z, (level));\ (dest) = (cast *) & (stack_segment [_m_z + FRAME_INFO_SIZE + (offset)]);\ } #define GET_GLOBAL(dest, cast, offset) {\ (dest) = (cast *) & (stack_segment [global_pointer + FRAME_INFO_SIZE + (offset)]);\ } /* Opening of stack frames is in-line */ /* STATIC_LINK_FOR_FRAME: determine static link for stack frame. new_lex_lvl: lexical level of new stack frame. returns: static link for stack frame at 'new_lex_lvl'. */ #define STATIC_LINK_FOR_FRAME(dest, new_lex_lvl) {\ int _m_cur_lex_lvl = FRAME_LEXICAL_LEVEL (frame_pointer);\ if (_m_cur_lex_lvl == (new_lex_lvl)) {\ (dest) = FRAME_STATIC_LINK (frame_pointer);\ } else if (_m_cur_lex_lvl > (new_lex_lvl)) {\ ADDR_T _m_static_link = frame_pointer;\ while (FRAME_LEXICAL_LEVEL (_m_static_link) >= (new_lex_lvl)) {\ _m_static_link = FRAME_STATIC_LINK (_m_static_link);\ }\ (dest) = _m_static_link;\ } else {\ (dest) = frame_pointer;\ }} #define INIT_STATIC_FRAME(p) {\ FRAME_CLEAR (AP_INCREMENT (TABLE (p)));\ if (INITIALISE_FRAME (TABLE (p))) {\ initialise_frame (p);\ }} #define INIT_GLOBAL_POINTER(p) {\ if (LEX_LEVEL (p) == global_level) {\ global_pointer = frame_pointer;\ }} #if defined HAVE_PARALLEL_CLAUSE #define OPEN_STATIC_FRAME(p) {\ ADDR_T dynamic_link = frame_pointer, static_link;\ ACTIVATION_RECORD *act, *pre;\ STATIC_LINK_FOR_FRAME (static_link, LEX_LEVEL (p));\ pre = FACT (frame_pointer);\ frame_pointer += FRAME_SIZE (dynamic_link);\ act = FACT (frame_pointer);\ FRAME_NO (act) = FRAME_NO (pre) + 1;\ FRAME_LEVEL (act) = LEX_LEVEL (p);\ PARAMETER_LEVEL (act) = PARAMETER_LEVEL (pre);\ PARAMETERS (act) = PARAMETERS (pre);\ STATIC_LINK (act) = static_link;\ DYNAMIC_LINK (act) = dynamic_link;\ DYNAMIC_SCOPE (act) = frame_pointer;\ NODE (act) = p;\ JUMP_STAT (act) = NO_JMP_BUF;\ PROC_FRAME (act) = A68_FALSE;\ THREAD_ID (act) = pthread_self ();\ } #else #define OPEN_STATIC_FRAME(p) {\ ADDR_T dynamic_link = frame_pointer, static_link;\ ACTIVATION_RECORD *act, *pre;\ STATIC_LINK_FOR_FRAME (static_link, LEX_LEVEL (p));\ pre = FACT (frame_pointer);\ frame_pointer += FRAME_SIZE (dynamic_link);\ act = FACT (frame_pointer);\ FRAME_NO (act) = FRAME_NO (pre) + 1;\ FRAME_LEVEL (act) = LEX_LEVEL (p);\ PARAMETER_LEVEL (act) = PARAMETER_LEVEL (pre);\ PARAMETERS (act) = PARAMETERS (pre);\ STATIC_LINK (act) = static_link;\ DYNAMIC_LINK (act) = dynamic_link;\ DYNAMIC_SCOPE (act) = frame_pointer;\ NODE (act) = p;\ JUMP_STAT (act) = NO_JMP_BUF;\ PROC_FRAME (act) = A68_FALSE;\ } #endif /** @def OPEN_PROC_FRAME @brief Open a stack frame for a procedure. **/ #if defined HAVE_PARALLEL_CLAUSE #define OPEN_PROC_FRAME(p, environ) {\ ADDR_T dynamic_link = frame_pointer, static_link;\ ACTIVATION_RECORD *act;\ LOW_STACK_ALERT (p);\ static_link = (environ > 0 ? environ : frame_pointer);\ if (frame_pointer < static_link) {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_SCOPE_DYNAMIC_0);\ exit_genie (p, A68_RUNTIME_ERROR);\ }\ frame_pointer += FRAME_SIZE (dynamic_link);\ act = FACT (frame_pointer);\ FRAME_NO (act) = FRAME_NUMBER (dynamic_link) + 1;\ FRAME_LEVEL (act) = LEX_LEVEL (p);\ PARAMETER_LEVEL (act) = LEX_LEVEL (p);\ PARAMETERS (act) = frame_pointer;\ STATIC_LINK (act) = static_link;\ DYNAMIC_LINK (act) = dynamic_link;\ DYNAMIC_SCOPE (act) = frame_pointer;\ NODE (act) = p;\ JUMP_STAT (act) = NO_JMP_BUF;\ PROC_FRAME (act) = A68_TRUE;\ THREAD_ID (act) = pthread_self ();\ } #else #define OPEN_PROC_FRAME(p, environ) {\ ADDR_T dynamic_link = frame_pointer, static_link;\ ACTIVATION_RECORD *act;\ LOW_STACK_ALERT (p);\ static_link = (environ > 0 ? environ : frame_pointer);\ if (frame_pointer < static_link) {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_SCOPE_DYNAMIC_0);\ exit_genie (p, A68_RUNTIME_ERROR);\ }\ frame_pointer += FRAME_SIZE (dynamic_link);\ act = FACT (frame_pointer);\ FRAME_NO (act) = FRAME_NUMBER (dynamic_link) + 1;\ FRAME_LEVEL (act) = LEX_LEVEL (p);\ PARAMETER_LEVEL (act) = LEX_LEVEL (p);\ PARAMETERS (act) = frame_pointer;\ STATIC_LINK (act) = static_link;\ DYNAMIC_LINK (act) = dynamic_link;\ DYNAMIC_SCOPE (act) = frame_pointer;\ NODE (act) = p;\ JUMP_STAT (act) = NO_JMP_BUF;\ PROC_FRAME (act) = A68_TRUE;\ } #endif #define CLOSE_FRAME {\ ACTIVATION_RECORD *act = FACT (frame_pointer);\ frame_pointer = DYNAMIC_LINK (act);\ } /* Macros for check on initialisation of values */ #define CHECK_INIT(p, c, q)\ if (!(c)) {\ diagnostic_node (A68_RUNTIME_ERROR, (p), ERROR_EMPTY_VALUE_FROM, (q));\ exit_genie ((p), A68_RUNTIME_ERROR);\ } #define CHECK_DNS2(p, scope, limit, mode)\ if (scope > limit) {\ char txt[BUFFER_SIZE];\ ASSERT (snprintf (txt, SNPRINTF_SIZE, ERROR_SCOPE_DYNAMIC_1) >= 0);\ diagnostic_node (A68_RUNTIME_ERROR, p, txt, mode);\ exit_genie (p, A68_RUNTIME_ERROR);\ } #define CHECK_DNS(p, m, w, limit)\ if (NEED_DNS (GINFO (p))) {\ ADDR_T _lim = ((limit) < global_pointer ? global_pointer : (limit));\ if (IS ((m), REF_SYMBOL)) {\ CHECK_DNS2 (p, (REF_SCOPE ((A68_REF *) (w))), _lim, (m));\ } else if (IS ((m), PROC_SYMBOL)) {\ CHECK_DNS2 (p, ENVIRON ((A68_PROCEDURE *) (w)), _lim, (m));\ } else if (IS ((m), FORMAT_SYMBOL)) {\ CHECK_DNS2 (p, ENVIRON ((A68_FORMAT *) w), _lim, (m));\ }} /* The void * cast in next macro is to stop warnings about dropping a volatile qualifier to a pointer. This is safe here. */ #define STACK_DNS(p, m, limit)\ if (p != NO_NODE && GINFO (p) != NO_GINFO) {\ CHECK_DNS ((NODE_T *)(void *)(p), (m),\ (STACK_OFFSET (-SIZE (m))), (limit));\ } /***********************************/ /* Macros for the evaluation stack */ /***********************************/ #define INCREMENT_STACK_POINTER(err, i)\ {stack_pointer += (ADDR_T) A68_ALIGN (i); (void) (err);} #define DECREMENT_STACK_POINTER(err, i)\ {stack_pointer -= A68_ALIGN (i); (void) (err);} #define PUSH(p, addr, size) {\ BYTE_T *_sp_ = STACK_TOP;\ INCREMENT_STACK_POINTER ((p), (int) (size));\ COPY (_sp_, (BYTE_T *) (addr), (int) (size));\ } #define POP(p, addr, size) {\ DECREMENT_STACK_POINTER((p), (int) (size));\ COPY ((BYTE_T *) (addr), STACK_TOP, (int) (size));\ } #define POP_ALIGNED(p, addr, size) {\ DECREMENT_STACK_POINTER((p), (int) (size));\ COPY_ALIGNED ((BYTE_T *) (addr), STACK_TOP, (int) (size));\ } #define POP_ADDRESS(p, addr, type) {\ DECREMENT_STACK_POINTER((p), (int) SIZE_AL (type));\ (addr) = (type *) STACK_TOP;\ } #define POP_OPERAND_ADDRESS(p, i, type) {\ (void) (p);\ (i) = (type *) (STACK_OFFSET (-SIZE_AL (type)));\ } #define POP_OPERAND_ADDRESSES(p, i, j, type) {\ DECREMENT_STACK_POINTER ((p), (int) SIZE_AL (type));\ (j) = (type *) STACK_TOP;\ (i) = (type *) (STACK_OFFSET (-SIZE_AL (type)));\ } #define POP_3_OPERAND_ADDRESSES(p, i, j, k, type) {\ DECREMENT_STACK_POINTER ((p), (int) (2 * SIZE_AL (type)));\ (k) = (type *) (STACK_OFFSET (SIZE_AL (type)));\ (j) = (type *) STACK_TOP;\ (i) = (type *) (STACK_OFFSET (-SIZE_AL (type)));\ } #define PUSH_PRIMITIVE(p, z, mode) {\ mode *_x_ = (mode *) STACK_TOP;\ STATUS (_x_) = INIT_MASK;\ VALUE (_x_) = (z);\ INCREMENT_STACK_POINTER ((p), SIZE_AL (mode));\ } #define PUSH_PRIMAL(p, z, m) {\ A68_##m *_x_ = (A68_##m *) STACK_TOP;\ int _size_ = SIZE_AL (A68_##m);\ STATUS (_x_) = INIT_MASK;\ VALUE (_x_) = (z);\ INCREMENT_STACK_POINTER ((p), _size_);\ } #define PUSH_OBJECT(p, z, mode) {\ *(mode *) STACK_TOP = (z);\ INCREMENT_STACK_POINTER (p, SIZE_AL (mode));\ } #define POP_OBJECT(p, z, mode) {\ DECREMENT_STACK_POINTER((p), SIZE_AL (mode));\ (*(z)) = *((mode *) STACK_TOP);\ } #define PUSH_COMPLEX(p, re, im) {\ PUSH_PRIMAL (p, re, REAL);\ PUSH_PRIMAL (p, im, REAL);\ } #define POP_COMPLEX(p, re, im) {\ POP_OBJECT (p, im, A68_REAL);\ POP_OBJECT (p, re, A68_REAL);\ } #define PUSH_BYTES(p, k) {\ A68_BYTES *_z_ = (A68_BYTES *) STACK_TOP;\ STATUS (_z_) = INIT_MASK;\ strncpy (VALUE (_z_), k, BYTES_WIDTH);\ INCREMENT_STACK_POINTER((p), SIZE_AL (A68_BYTES));\ } #define PUSH_LONG_BYTES(p, k) {\ A68_LONG_BYTES *_z_ = (A68_LONG_BYTES *) STACK_TOP;\ STATUS (_z_) = INIT_MASK;\ strncpy (VALUE (_z_), k, LONG_BYTES_WIDTH);\ INCREMENT_STACK_POINTER((p), SIZE_AL (A68_LONG_BYTES));\ } #define PUSH_REF(p, z) PUSH_OBJECT (p, z, A68_REF) #define PUSH_PROCEDURE(p, z) PUSH_OBJECT (p, z, A68_PROCEDURE) #define PUSH_FORMAT(p, z) PUSH_OBJECT (p, z, A68_FORMAT) #define POP_REF(p, z) POP_OBJECT (p, z, A68_REF) #define POP_PROCEDURE(p, z) POP_OBJECT (p, z, A68_PROCEDURE) #define PUSH_UNION(p, z) {\ A68_UNION *_x_ = (A68_UNION *) STACK_TOP;\ STATUS (_x_) = INIT_MASK;\ VALUE (_x_) = (z);\ INCREMENT_STACK_POINTER ((p), SIZE_AL (A68_UNION));\ } /* Macro's for standard environ */ #define A68_ENV_INT(n, k) void n (NODE_T *p) {PUSH_PRIMAL (p, (k), INT);} #define A68_ENV_REAL(n, z) void n (NODE_T *p) {PUSH_PRIMAL (p, (z), REAL);} /* Interpreter macros */ #define INITIALISED(z) ((BOOL_T) (STATUS (z) & INIT_MASK)) #define LHS_MODE(p) (MOID (PACK (MOID (p)))) #define RHS_MODE(p) (MOID (NEXT (PACK (MOID (p))))) /* Transput related macros */ #define IS_NIL_FORMAT(f) ((BOOL_T) (BODY (f) == NO_NODE && ENVIRON (f) == 0)) /* MP Macros */ #define MP_STATUS(z) ((z)[0]) #define MP_EXPONENT(z) ((z)[1]) #define MP_DIGIT(z, n) ((z)[(n) + 1]) #define SIZE_MP(digits) ((2 + digits) * SIZE_AL (MP_T)) #define IS_ZERO_MP(z) (MP_DIGIT (z, 1) == (MP_T) 0) #define MOVE_MP(z, x, digits) {\ MP_T *_m_d = (z), *_m_s = (x); int _m_k = digits + 2;\ while (_m_k--) {*_m_d++ = *_m_s++;}\ } #define MOVE_DIGITS(z, x, digits) {\ MP_T *_m_d = (z), *_m_s = (x); int _m_k = digits;\ while (_m_k--) {*_m_d++ = *_m_s++;}\ } #define CHECK_MP_EXPONENT(p, z) {\ MP_T _expo_ = fabs (MP_EXPONENT (z));\ if (_expo_ > MAX_MP_EXPONENT || (_expo_ == MAX_MP_EXPONENT && ABS (MP_DIGIT (z, 1)) > 1.0)) {\ errno = ERANGE;\ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_MP_OUT_OF_BOUNDS, NULL);\ exit_genie (p, A68_RUNTIME_ERROR);\ }} #define SET_MP_ZERO(z, digits) {\ MP_T *_m_d = &MP_DIGIT ((z), 1); int _m_k = digits;\ MP_STATUS (z) = (MP_T) INIT_MASK;\ MP_EXPONENT (z) = 0.0;\ while (_m_k--) {*_m_d++ = 0.0;}\ } /* stack_mp: allocate temporary space in the evaluation stack */ #define STACK_MP(dest, p, digits) {\ ADDR_T stack_mp_sp = stack_pointer;\ if ((stack_pointer += SIZE_MP (digits)) > expr_stack_limit) {\ diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_STACK_OVERFLOW);\ exit_genie (p, A68_RUNTIME_ERROR);\ }\ dest = (MP_T *) STACK_ADDRESS (stack_mp_sp);\ } /******************************/ /* Library for code generator */ /*****************************/ /* Operators that are inlined in compiled code */ #define a68g_eq_complex(/* A68_REAL * */ x, y) (RE (x) == RE (y) && IM (x) == IM (y)) #define a68g_ne_complex(/* A68_REAL * */ x, y) (! a68g_eq_complex (x, y)) #define a68g_mod_int(/* int */ i, j) (((i) % (j)) >= 0 ? ((i) % (j)) : ((i) % (j)) + labs (j)) #define a68g_plusab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) += (j), (i)) #define a68g_minusab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) -= (j), (i)) #define a68g_timesab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) *= (j), (i)) #define a68g_overab_int(/* A68_REF * */ i, /* int */ j) (VALUE ((A68_INT *) ADDRESS (i)) /= (j), (i)) #define a68g_entier(/* double */ x) ((int) floor (x)) #define a68g_plusab_real(/* A68_REF * */ i, /* double */ j) (VALUE ((A68_REAL *) ADDRESS (i)) += (j), (i)) #define a68g_minusab_real(/* A68_REF * */ i, /* double */ j) (VALUE ((A68_REAL *) ADDRESS (i)) -= (j), (i)) #define a68g_timesab_real(/* A68_REF * */ i, /* double */ j) (VALUE ((A68_REAL *) ADDRESS (i)) *= (j), (i)) #define a68g_divab_real(/* A68_REF * */ i, /* double */ j) (VALUE ((A68_REAL *) ADDRESS (i)) /= (j), (i)) #define a68g_re_complex(/* A68_REAL * */ z) (RE (z)) #define a68g_im_complex(/* A68_REAL * */ z) (IM (z)) #define a68g_abs_complex(/* A68_REAL * */ z) a68g_hypot (RE (z), IM (z)) #define a68g_arg_complex(/* A68_REAL * */ z) atan2 (IM (z), RE (z)) #define a68g_i_complex(/* A68_REAL * */ z, /* double */ re, im) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = re;\ IM (z) = im;} #define a68g_minus_complex(/* A68_REAL * */ z, x) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = -RE (x);\ IM (z) = -IM (x);} #define a68g_conj_complex(/* A68_REAL * */ z, x) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = RE (x);\ IM (z) = -IM (x);} #define a68g_add_complex(/* A68_REAL * */ z, x, y) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = RE (x) + RE (y);\ IM (z) = IM (x) + IM (y);} #define a68g_sub_complex(/* A68_REAL * */ z, x, y) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = RE (x) - RE (y);\ IM (z) = IM (x) - IM (y);} #define a68g_mul_complex(/* A68_REAL * */ z, x, y) {\ STATUS_RE (z) = INIT_MASK;\ STATUS_IM (z) = INIT_MASK;\ RE (z) = RE (x) * RE (y) - IM (x) * IM (y);\ IM (z) = IM (x) * RE (y) + RE (x) * IM (y);} /********************************/ /* All kind of constants ex GSL */ /********************************/ #define GSL_CONST_NUM_FINE_STRUCTURE (7.297352533e-3) /* 1 */ #define GSL_CONST_NUM_AVOGADRO (6.02214199e23) /* 1 / mol */ #define GSL_CONST_NUM_YOTTA (1e24) /* 1 */ #define GSL_CONST_NUM_ZETTA (1e21) /* 1 */ #define GSL_CONST_NUM_EXA (1e18) /* 1 */ #define GSL_CONST_NUM_PETA (1e15) /* 1 */ #define GSL_CONST_NUM_TERA (1e12) /* 1 */ #define GSL_CONST_NUM_GIGA (1e9) /* 1 */ #define GSL_CONST_NUM_MEGA (1e6) /* 1 */ #define GSL_CONST_NUM_KILO (1e3) /* 1 */ #define GSL_CONST_NUM_MILLI (1e-3) /* 1 */ #define GSL_CONST_NUM_MICRO (1e-6) /* 1 */ #define GSL_CONST_NUM_NANO (1e-9) /* 1 */ #define GSL_CONST_NUM_PICO (1e-12) /* 1 */ #define GSL_CONST_NUM_FEMTO (1e-15) /* 1 */ #define GSL_CONST_NUM_ATTO (1e-18) /* 1 */ #define GSL_CONST_NUM_ZEPTO (1e-21) /* 1 */ #define GSL_CONST_NUM_YOCTO (1e-24) /* 1 */ #define GSL_CONST_CGSM_GAUSS (1.0) /* cm / A s^2 */ #define GSL_CONST_CGSM_SPEED_OF_LIGHT (2.99792458e10) /* cm / s */ #define GSL_CONST_CGSM_GRAVITATIONAL_CONSTANT (6.673e-8) /* cm^3 / g s^2 */ #define GSL_CONST_CGSM_ASTRONOMICAL_UNIT (1.49597870691e13) /* cm */ #define GSL_CONST_CGSM_LIGHT_YEAR (9.46053620707e17) /* cm */ #define GSL_CONST_CGSM_PARSEC (3.08567758135e18) /* cm */ #define GSL_CONST_CGSM_GRAV_ACCEL (9.80665e2) /* cm / s^2 */ #define GSL_CONST_CGSM_ELECTRON_VOLT (1.602176487e-12) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_MASS_ELECTRON (9.10938188e-28) /* g */ #define GSL_CONST_CGSM_MASS_MUON (1.88353109e-25) /* g */ #define GSL_CONST_CGSM_MASS_PROTON (1.67262158e-24) /* g */ #define GSL_CONST_CGSM_MASS_NEUTRON (1.67492716e-24) /* g */ #define GSL_CONST_CGSM_RYDBERG (2.17987196968e-11) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_BOLTZMANN (1.3806504e-16) /* g cm^2 / K s^2 */ #define GSL_CONST_CGSM_MOLAR_GAS (8.314472e7) /* g cm^2 / K mol s^2 */ #define GSL_CONST_CGSM_STANDARD_GAS_VOLUME (2.2710981e4) /* cm^3 / mol */ #define GSL_CONST_CGSM_MINUTE (6e1) /* s */ #define GSL_CONST_CGSM_HOUR (3.6e3) /* s */ #define GSL_CONST_CGSM_DAY (8.64e4) /* s */ #define GSL_CONST_CGSM_WEEK (6.048e5) /* s */ #define GSL_CONST_CGSM_INCH (2.54e0) /* cm */ #define GSL_CONST_CGSM_FOOT (3.048e1) /* cm */ #define GSL_CONST_CGSM_YARD (9.144e1) /* cm */ #define GSL_CONST_CGSM_MILE (1.609344e5) /* cm */ #define GSL_CONST_CGSM_NAUTICAL_MILE (1.852e5) /* cm */ #define GSL_CONST_CGSM_FATHOM (1.8288e2) /* cm */ #define GSL_CONST_CGSM_MIL (2.54e-3) /* cm */ #define GSL_CONST_CGSM_POINT (3.52777777778e-2) /* cm */ #define GSL_CONST_CGSM_TEXPOINT (3.51459803515e-2) /* cm */ #define GSL_CONST_CGSM_MICRON (1e-4) /* cm */ #define GSL_CONST_CGSM_ANGSTROM (1e-8) /* cm */ #define GSL_CONST_CGSM_HECTARE (1e8) /* cm^2 */ #define GSL_CONST_CGSM_ACRE (4.04685642241e7) /* cm^2 */ #define GSL_CONST_CGSM_BARN (1e-24) /* cm^2 */ #define GSL_CONST_CGSM_LITER (1e3) /* cm^3 */ #define GSL_CONST_CGSM_US_GALLON (3.78541178402e3) /* cm^3 */ #define GSL_CONST_CGSM_QUART (9.46352946004e2) /* cm^3 */ #define GSL_CONST_CGSM_PINT (4.73176473002e2) /* cm^3 */ #define GSL_CONST_CGSM_CUP (2.36588236501e2) /* cm^3 */ #define GSL_CONST_CGSM_FLUID_OUNCE (2.95735295626e1) /* cm^3 */ #define GSL_CONST_CGSM_TABLESPOON (1.47867647813e1) /* cm^3 */ #define GSL_CONST_CGSM_TEASPOON (4.92892159375e0) /* cm^3 */ #define GSL_CONST_CGSM_CANADIAN_GALLON (4.54609e3) /* cm^3 */ #define GSL_CONST_CGSM_UK_GALLON (4.546092e3) /* cm^3 */ #define GSL_CONST_CGSM_MILES_PER_HOUR (4.4704e1) /* cm / s */ #define GSL_CONST_CGSM_KILOMETERS_PER_HOUR (2.77777777778e1) /* cm / s */ #define GSL_CONST_CGSM_KNOT (5.14444444444e1) /* cm / s */ #define GSL_CONST_CGSM_POUND_MASS (4.5359237e2) /* g */ #define GSL_CONST_CGSM_OUNCE_MASS (2.8349523125e1) /* g */ #define GSL_CONST_CGSM_TON (9.0718474e5) /* g */ #define GSL_CONST_CGSM_METRIC_TON (1e6) /* g */ #define GSL_CONST_CGSM_UK_TON (1.0160469088e6) /* g */ #define GSL_CONST_CGSM_TROY_OUNCE (3.1103475e1) /* g */ #define GSL_CONST_CGSM_CARAT (2e-1) /* g */ #define GSL_CONST_CGSM_UNIFIED_ATOMIC_MASS (1.660538782e-24) /* g */ #define GSL_CONST_CGSM_GRAM_FORCE (9.80665e2) /* cm g / s^2 */ #define GSL_CONST_CGSM_POUND_FORCE (4.44822161526e5) /* cm g / s^2 */ #define GSL_CONST_CGSM_KILOPOUND_FORCE (4.44822161526e8) /* cm g / s^2 */ #define GSL_CONST_CGSM_POUNDAL (1.38255e4) /* cm g / s^2 */ #define GSL_CONST_CGSM_CALORIE (4.1868e7) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_BTU (1.05505585262e10) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_THERM (1.05506e15) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_HORSEPOWER (7.457e9) /* g cm^2 / s^3 */ #define GSL_CONST_CGSM_BAR (1e6) /* g / cm s^2 */ #define GSL_CONST_CGSM_STD_ATMOSPHERE (1.01325e6) /* g / cm s^2 */ #define GSL_CONST_CGSM_TORR (1.33322368421e3) /* g / cm s^2 */ #define GSL_CONST_CGSM_METER_OF_MERCURY (1.33322368421e6) /* g / cm s^2 */ #define GSL_CONST_CGSM_INCH_OF_MERCURY (3.38638815789e4) /* g / cm s^2 */ #define GSL_CONST_CGSM_INCH_OF_WATER (2.490889e3) /* g / cm s^2 */ #define GSL_CONST_CGSM_PSI (6.89475729317e4) /* g / cm s^2 */ #define GSL_CONST_CGSM_POISE (1e0) /* g / cm s */ #define GSL_CONST_CGSM_STOKES (1e0) /* cm^2 / s */ #define GSL_CONST_CGSM_STILB (1e0) /* cd / cm^2 */ #define GSL_CONST_CGSM_LUMEN (1e0) /* cd sr */ #define GSL_CONST_CGSM_LUX (1e-4) /* cd sr / cm^2 */ #define GSL_CONST_CGSM_PHOT (1e0) /* cd sr / cm^2 */ #define GSL_CONST_CGSM_FOOTCANDLE (1.076e-3) /* cd sr / cm^2 */ #define GSL_CONST_CGSM_LAMBERT (1e0) /* cd sr / cm^2 */ #define GSL_CONST_CGSM_FOOTLAMBERT (1.07639104e-3) /* cd sr / cm^2 */ #define GSL_CONST_CGSM_CURIE (3.7e10) /* 1 / s */ #define GSL_CONST_CGSM_ROENTGEN (2.58e-8) /* abamp s / g */ #define GSL_CONST_CGSM_RAD (1e2) /* cm^2 / s^2 */ #define GSL_CONST_CGSM_SOLAR_MASS (1.98892e33) /* g */ #define GSL_CONST_CGSM_BOHR_RADIUS (5.291772083e-9) /* cm */ #define GSL_CONST_CGSM_NEWTON (1e5) /* cm g / s^2 */ #define GSL_CONST_CGSM_DYNE (1e0) /* cm g / s^2 */ #define GSL_CONST_CGSM_JOULE (1e7) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_ERG (1e0) /* g cm^2 / s^2 */ #define GSL_CONST_CGSM_BOHR_MAGNETON (9.27400899e-21) /* abamp cm^2 */ #define GSL_CONST_CGSM_NUCLEAR_MAGNETON (5.05078317e-24) /* abamp cm^2 */ #define GSL_CONST_CGSM_ELECTRON_MAGNETIC_MOMENT (9.28476362e-21) /* abamp cm^2 */ #define GSL_CONST_CGSM_PROTON_MAGNETIC_MOMENT (1.410606633e-23) /* abamp cm^2 */ #define GSL_CONST_CGSM_FARADAY (9.64853429775e3) /* abamp s / mol */ #define GSL_CONST_CGSM_ELECTRON_CHARGE (1.602176487e-20) /* abamp s */ #define GSL_CONST_MKS_SPEED_OF_LIGHT (2.99792458e8) /* m / s */ #define GSL_CONST_MKS_GRAVITATIONAL_CONSTANT (6.673e-11) /* m^3 / kg s^2 */ #define GSL_CONST_MKS_ASTRONOMICAL_UNIT (1.49597870691e11) /* m */ #define GSL_CONST_MKS_LIGHT_YEAR (9.46053620707e15) /* m */ #define GSL_CONST_MKS_PARSEC (3.08567758135e16) /* m */ #define GSL_CONST_MKS_GRAV_ACCEL (9.80665e0) /* m / s^2 */ #define GSL_CONST_MKS_ELECTRON_VOLT (1.602176487e-19) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_MASS_ELECTRON (9.10938188e-31) /* kg */ #define GSL_CONST_MKS_MASS_MUON (1.88353109e-28) /* kg */ #define GSL_CONST_MKS_MASS_PROTON (1.67262158e-27) /* kg */ #define GSL_CONST_MKS_MASS_NEUTRON (1.67492716e-27) /* kg */ #define GSL_CONST_MKS_RYDBERG (2.17987196968e-18) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_BOLTZMANN (1.3806504e-23) /* kg m^2 / K s^2 */ #define GSL_CONST_MKS_MOLAR_GAS (8.314472e0) /* kg m^2 / K mol s^2 */ #define GSL_CONST_MKS_STANDARD_GAS_VOLUME (2.2710981e-2) /* m^3 / mol */ #define GSL_CONST_MKS_MINUTE (6e1) /* s */ #define GSL_CONST_MKS_HOUR (3.6e3) /* s */ #define GSL_CONST_MKS_DAY (8.64e4) /* s */ #define GSL_CONST_MKS_WEEK (6.048e5) /* s */ #define GSL_CONST_MKS_INCH (2.54e-2) /* m */ #define GSL_CONST_MKS_FOOT (3.048e-1) /* m */ #define GSL_CONST_MKS_YARD (9.144e-1) /* m */ #define GSL_CONST_MKS_MILE (1.609344e3) /* m */ #define GSL_CONST_MKS_NAUTICAL_MILE (1.852e3) /* m */ #define GSL_CONST_MKS_FATHOM (1.8288e0) /* m */ #define GSL_CONST_MKS_MIL (2.54e-5) /* m */ #define GSL_CONST_MKS_POINT (3.52777777778e-4) /* m */ #define GSL_CONST_MKS_TEXPOINT (3.51459803515e-4) /* m */ #define GSL_CONST_MKS_MICRON (1e-6) /* m */ #define GSL_CONST_MKS_ANGSTROM (1e-10) /* m */ #define GSL_CONST_MKS_HECTARE (1e4) /* m^2 */ #define GSL_CONST_MKS_ACRE (4.04685642241e3) /* m^2 */ #define GSL_CONST_MKS_BARN (1e-28) /* m^2 */ #define GSL_CONST_MKS_LITER (1e-3) /* m^3 */ #define GSL_CONST_MKS_US_GALLON (3.78541178402e-3) /* m^3 */ #define GSL_CONST_MKS_QUART (9.46352946004e-4) /* m^3 */ #define GSL_CONST_MKS_PINT (4.73176473002e-4) /* m^3 */ #define GSL_CONST_MKS_CUP (2.36588236501e-4) /* m^3 */ #define GSL_CONST_MKS_FLUID_OUNCE (2.95735295626e-5) /* m^3 */ #define GSL_CONST_MKS_TABLESPOON (1.47867647813e-5) /* m^3 */ #define GSL_CONST_MKS_TEASPOON (4.92892159375e-6) /* m^3 */ #define GSL_CONST_MKS_CANADIAN_GALLON (4.54609e-3) /* m^3 */ #define GSL_CONST_MKS_UK_GALLON (4.546092e-3) /* m^3 */ #define GSL_CONST_MKS_MILES_PER_HOUR (4.4704e-1) /* m / s */ #define GSL_CONST_MKS_KILOMETERS_PER_HOUR (2.77777777778e-1) /* m / s */ #define GSL_CONST_MKS_KNOT (5.14444444444e-1) /* m / s */ #define GSL_CONST_MKS_POUND_MASS (4.5359237e-1) /* kg */ #define GSL_CONST_MKS_OUNCE_MASS (2.8349523125e-2) /* kg */ #define GSL_CONST_MKS_TON (9.0718474e2) /* kg */ #define GSL_CONST_MKS_METRIC_TON (1e3) /* kg */ #define GSL_CONST_MKS_UK_TON (1.0160469088e3) /* kg */ #define GSL_CONST_MKS_TROY_OUNCE (3.1103475e-2) /* kg */ #define GSL_CONST_MKS_CARAT (2e-4) /* kg */ #define GSL_CONST_MKS_UNIFIED_ATOMIC_MASS (1.660538782e-27) /* kg */ #define GSL_CONST_MKS_GRAM_FORCE (9.80665e-3) /* kg m / s^2 */ #define GSL_CONST_MKS_POUND_FORCE (4.44822161526e0) /* kg m / s^2 */ #define GSL_CONST_MKS_KILOPOUND_FORCE (4.44822161526e3) /* kg m / s^2 */ #define GSL_CONST_MKS_POUNDAL (1.38255e-1) /* kg m / s^2 */ #define GSL_CONST_MKS_CALORIE (4.1868e0) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_BTU (1.05505585262e3) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_THERM (1.05506e8) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_HORSEPOWER (7.457e2) /* kg m^2 / s^3 */ #define GSL_CONST_MKS_BAR (1e5) /* kg / m s^2 */ #define GSL_CONST_MKS_STD_ATMOSPHERE (1.01325e5) /* kg / m s^2 */ #define GSL_CONST_MKS_TORR (1.33322368421e2) /* kg / m s^2 */ #define GSL_CONST_MKS_METER_OF_MERCURY (1.33322368421e5) /* kg / m s^2 */ #define GSL_CONST_MKS_INCH_OF_MERCURY (3.38638815789e3) /* kg / m s^2 */ #define GSL_CONST_MKS_INCH_OF_WATER (2.490889e2) /* kg / m s^2 */ #define GSL_CONST_MKS_PSI (6.89475729317e3) /* kg / m s^2 */ #define GSL_CONST_MKS_POISE (1e-1) /* kg m^-1 s^-1 */ #define GSL_CONST_MKS_STOKES (1e-4) /* m^2 / s */ #define GSL_CONST_MKS_STILB (1e4) /* cd / m^2 */ #define GSL_CONST_MKS_LUMEN (1e0) /* cd sr */ #define GSL_CONST_MKS_LUX (1e0) /* cd sr / m^2 */ #define GSL_CONST_MKS_PHOT (1e4) /* cd sr / m^2 */ #define GSL_CONST_MKS_FOOTCANDLE (1.076e1) /* cd sr / m^2 */ #define GSL_CONST_MKS_LAMBERT (1e4) /* cd sr / m^2 */ #define GSL_CONST_MKS_FOOTLAMBERT (1.07639104e1) /* cd sr / m^2 */ #define GSL_CONST_MKS_CURIE (3.7e10) /* 1 / s */ #define GSL_CONST_MKS_ROENTGEN (2.58e-4) /* A s / kg */ #define GSL_CONST_MKS_RAD (1e-2) /* m^2 / s^2 */ #define GSL_CONST_MKS_SOLAR_MASS (1.98892e30) /* kg */ #define GSL_CONST_MKS_BOHR_RADIUS (5.291772083e-11) /* m */ #define GSL_CONST_MKS_NEWTON (1e0) /* kg m / s^2 */ #define GSL_CONST_MKS_DYNE (1e-5) /* kg m / s^2 */ #define GSL_CONST_MKS_JOULE (1e0) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_ERG (1e-7) /* kg m^2 / s^2 */ #define GSL_CONST_MKS_BOHR_MAGNETON (9.27400899e-24) /* A m^2 */ #define GSL_CONST_MKS_NUCLEAR_MAGNETON (5.05078317e-27) /* A m^2 */ #define GSL_CONST_MKS_ELECTRON_MAGNETIC_MOMENT (9.28476362e-24) /* A m^2 */ #define GSL_CONST_MKS_PROTON_MAGNETIC_MOMENT (1.410606633e-26) /* A m^2 */ #define GSL_CONST_MKS_FARADAY (9.64853429775e4) /* A s / mol */ #define GSL_CONST_MKS_ELECTRON_CHARGE (1.602176487e-19) /* A s */ #define GSL_CONST_MKS_VACUUM_PERMITTIVITY (8.854187817e-12) /* A^2 s^4 / kg m^3 */ #define GSL_CONST_MKS_VACUUM_PERMEABILITY (1.25663706144e-6) /* kg m / A^2 s^2 */ #define GSL_CONST_MKS_GAUSS (1e-4) /* kg / A s^2 */ /***********************/ /* Global declarations */ /***********************/ extern A68_CHANNEL stand_in_channel, stand_out_channel, stand_draw_channel, stand_back_channel, stand_error_channel, associate_channel, skip_channel; extern A68_FORMAT nil_format; extern A68_HANDLE nil_handle, *free_handles, *busy_handles; extern A68_REF nil_ref, stand_in, stand_out, skip_file; extern ADDR_T fixed_heap_pointer, temp_heap_pointer, frame_pointer, stack_pointer, heap_pointer, handle_pointer, global_pointer, frame_start, frame_end, stack_start, stack_end, finish_frame_pointer; extern BOOL_T halt_typing, heap_is_fluid, in_execution, in_monitor, do_confirm_exit, no_warnings; extern BYTE_T *stack_segment, *heap_segment, *handle_segment, *system_stack_offset; extern KEYWORD_T *top_keyword; extern MODES_T a68_modes; extern MODULE_T program; extern NODE_T **node_register; extern POSTULATE_T *top_postulate, *top_postulate_list; extern TABLE_T *a68g_standenv; extern TAG_T *error_tag; extern TOKEN_T *top_token; extern char **global_argv, *watchpoint_expression, a68g_cmd_name[], output_line[], edit_line[], input_line[]; extern clock_t clock_res; extern double cputime_0, garbage_seconds; extern int frame_stack_size, expr_stack_size, heap_size, handle_pool_size, free_handle_count, max_handle_count, garbage_collects, global_argc, global_level, max_lex_lvl, new_nodes, new_modes, new_postulates, new_node_infos, new_genie_infos, stack_limit, frame_stack_limit, expr_stack_limit, stack_size, storage_overhead, symbol_table_count, mode_count, term_heigth, term_width, varying_mp_digits; extern jmp_buf genie_exit_label; #if defined HAVE_CURSES extern BOOL_T a68g_curses_mode; #endif #if defined HAVE_PARALLEL_CLAUSE extern pthread_t main_thread_id; extern int running_par_level; #endif #if defined HAVE_WIN32 extern int finite (double); #endif extern A68_REF genie_make_row (NODE_T *, MOID_T *, int, ADDR_T); extern A68_REF c_string_to_row_char (NODE_T *, char *, int); extern A68_REF c_to_a_string (NODE_T *, char *, int); extern A68_REF empty_row (NODE_T *, MOID_T *); extern A68_REF empty_string (NODE_T *); extern A68_REF genie_store (NODE_T *, MOID_T *, A68_REF *, A68_REF *); extern A68_REF heap_generator (NODE_T *, MOID_T *, int); extern ADDR_T calculate_internal_index (A68_TUPLE *, int); extern BOOL_T a68g_mkstemp(char *, int, mode_t); extern BOOL_T close_device (NODE_T *, A68_FILE *); extern BOOL_T genie_int_case_unit (NODE_T *, int, int *); extern BOOL_T genie_string_to_value_internal (NODE_T *, MOID_T *, char *, BYTE_T *); extern BOOL_T increment_internal_index (A68_TUPLE *, int); extern BOOL_T lexical_analyser (void); extern BOOL_T match_string (char *, char *, char); extern BOOL_T set_options (OPTION_LIST_T *, BOOL_T); extern BOOL_T whether (NODE_T * p, ...); extern BOOL_T is_coercion (NODE_T *); extern BOOL_T is_firm (MOID_T *, MOID_T *); extern BOOL_T is_modes_equivalent (MOID_T *, MOID_T *); extern BOOL_T is_new_lexical_level (NODE_T *); extern BOOL_T is_one_of (NODE_T * p, ...); extern BOOL_T is_subset (MOID_T *, MOID_T *, int); extern BOOL_T is_unitable (MOID_T *, MOID_T *, int); extern BYTE_T *get_fixed_heap_space (size_t); extern BYTE_T *get_heap_space (size_t); extern BYTE_T *get_temp_heap_space (size_t); extern FILE *a68g_fopen (char *, char *, char *); extern FILE_T open_physical_file (NODE_T *, A68_REF, int, mode_t); extern GINFO_T *new_genie_info (void); extern KEYWORD_T *find_keyword (KEYWORD_T *, char *); extern KEYWORD_T *find_keyword_from_attribute (KEYWORD_T *, int); extern MOID_T *add_mode (MOID_T **, int, int, NODE_T *, MOID_T *, PACK_T *); extern MOID_T *depref_completely (MOID_T *); extern MOID_T *new_moid (void); extern MOID_T *unites_to (MOID_T *, MOID_T *); extern NODE_INFO_T *new_node_info (void); extern NODE_T *get_next_format_pattern (NODE_T *, A68_REF, BOOL_T); extern NODE_T *last_unit; extern NODE_T *new_node (void); extern NODE_T *some_node (char *); extern PACK_T *new_pack (void); extern POSTULATE_T *is_postulated (POSTULATE_T *, MOID_T *); extern POSTULATE_T *is_postulated_pair (POSTULATE_T *, MOID_T *, MOID_T *); extern LINE_T *new_source_line (void); extern TABLE_T *find_level (NODE_T *, int); extern TABLE_T *new_symbol_table (TABLE_T *); extern TAG_T *add_tag (TABLE_T *, int, NODE_T *, MOID_T *, int); extern TAG_T *find_tag_global (TABLE_T *, int, char *); extern TAG_T *find_tag_local (TABLE_T *, int, char *); extern TAG_T *new_tag (void); extern TOKEN_T *add_token (TOKEN_T **, char *); extern char *a68g_strchr (char *, int); extern char *a_to_c_string (NODE_T *, char *, A68_REF); extern char *ctrl_char (int); extern char *error_chars (char *, int); extern char *error_specification (void); extern char *fixed (NODE_T * p); extern char *get_transput_buffer (int); extern char *moid_to_string (MOID_T *, int, NODE_T *); extern char *new_fixed_string (char *); extern char *new_string (char *, ...); extern char *new_temp_string (char *); extern char *non_terminal_string (char *, int); extern char *phrase_to_text (NODE_T *, NODE_T **); extern char *propagator_name (PROP_PROC *p); extern char *read_string_from_tty (char *); extern char *standard_environ_proc_name (GPROC); extern char *sub_fixed (NODE_T *, double, int, int); extern char *sub_whole (NODE_T *, int, int); extern char *whole (NODE_T * p); extern char digit_to_char (int); extern char pop_char_transput_buffer (int); extern double a68g_acosh (double); extern double a68g_asinh (double); extern double a68g_atan2 (double, double); extern double a68g_atanh (double); extern double a68g_exp (double); extern double a68g_hypot (double, double); extern double a68g_log1p (double); extern double a68g_pow_real (double, double); extern double a68g_pow_real_int (double, int); extern double curt (double); extern double inverf (double); extern double inverfc (double); extern double rng_53_bit (void); extern double seconds (void); extern double ten_up (int); extern int a68_string_size (NODE_T *, A68_REF); extern int a68g_round (double); extern int char_scanner (A68_FILE *); extern int count_pack_members (PACK_T *); extern int end_of_format (NODE_T *, A68_REF); extern int first_tag_global (TABLE_T *, char *); extern int get_replicator_value (NODE_T *, BOOL_T); extern int get_row_size (A68_TUPLE *, int); extern int get_transput_buffer_index (int); extern int get_transput_buffer_size (int); extern int get_unblocked_transput_buffer (NODE_T *); extern int grep_in_string (char *, char *, int *, int *); extern int heap_available (void); extern int moid_digits (MOID_T *); extern int moid_size (MOID_T *); extern int store_file_entry (NODE_T *, FILE_T, char *, BOOL_T); extern int is_identifier_or_label_global (TABLE_T *, char *); extern ssize_t io_read (FILE_T, void *, size_t); extern ssize_t io_read_conv (FILE_T, void *, size_t); extern ssize_t io_write (FILE_T, const void *, size_t); extern ssize_t io_write_conv (FILE_T, const void *, size_t); extern unsigned a68g_strtoul (char *, char **, int); extern void a68g_cos_complex (A68_REAL *, A68_REAL *); extern void a68g_div_complex (A68_REAL *, A68_REAL *, A68_REAL *); extern void a68g_exit (int); extern void a68g_exp_complex (A68_REAL *, A68_REAL *); extern void a68g_getty (int *, int *); extern void a68g_ln_complex (A68_REAL *, A68_REAL *); extern void a68g_sin_complex (A68_REAL *, A68_REAL *); extern void a68g_sqrt_complex (A68_REAL *, A68_REAL *); extern void abend (char *, char *, char *, int); extern void add_a_string_transput_buffer (NODE_T *, int, BYTE_T *); extern void add_char_transput_buffer (NODE_T *, int, char); extern void add_mode_to_pack (PACK_T **, MOID_T *, char *, NODE_T *); extern void add_mode_to_pack_end (PACK_T **, MOID_T *, char *, NODE_T *); extern void add_option_list (OPTION_LIST_T **, char *, LINE_T *); extern void add_string_from_stack_transput_buffer (NODE_T *, int); extern void add_string_transput_buffer (NODE_T *, int, char *); extern void apropos (FILE_T, char *, char *); extern void assign_offsets (NODE_T *); extern void assign_offsets_packs (MOID_T *); extern void assign_offsets_table (TABLE_T *); extern void bind_format_tags_to_tree (NODE_T *); extern void bind_routine_tags_to_tree (NODE_T *); extern void bottom_up_error_check (NODE_T *); extern void bottom_up_parser (NODE_T *); extern void bufcat (char *, char *, int); extern void bufcpy (char *, char *, int); extern void change_breakpoints (NODE_T *, unsigned, int, BOOL_T *, char *); extern void change_masks (NODE_T *, unsigned, BOOL_T); extern void check_parenthesis (NODE_T *); extern void coercion_inserter (NODE_T *); extern void collect_taxes (NODE_T *); extern void compiler (FILE_T); extern void default_options (MODULE_T *); extern void diagnostic_line (STATUS_MASK, LINE_T *, char *, char *, ...); extern void diagnostic_node (STATUS_MASK, NODE_T *, char *, ...); extern void diagnostics_to_terminal (LINE_T *, int); extern void discard_heap (void); extern void end_of_file_error (NODE_T * p, A68_REF ref_file); extern void enlarge_transput_buffer (NODE_T *, int, int); extern void exit_genie (NODE_T *, int); extern void fill_symbol_table_outer (NODE_T *, TABLE_T *); extern void finalise_symbol_table_setup (NODE_T *, int); extern void format_error (NODE_T *, A68_REF, char *); extern void free_file_entries (void); extern void free_genie_heap (NODE_T *); extern void free_postulate_list (POSTULATE_T *, POSTULATE_T *); extern void gc_heap (NODE_T *, ADDR_T); extern void genie (void *); extern void genie_argc (NODE_T *); extern void genie_argv (NODE_T *); extern void genie_call_operator (NODE_T *, ADDR_T); extern void genie_call_procedure (NODE_T *, MOID_T *, MOID_T *, MOID_T *, A68_PROCEDURE *, ADDR_T, ADDR_T); extern void genie_call_event_routine (NODE_T *, MOID_T *, A68_PROCEDURE *, ADDR_T, ADDR_T); extern void genie_check_initialisation (NODE_T *, BYTE_T *, MOID_T *); extern void genie_columns (NODE_T *); extern void genie_create_pipe (NODE_T *); extern void genie_declaration (NODE_T *); extern void genie_enquiry_clause (NODE_T *); extern void genie_errno (NODE_T *); extern void genie_execve (NODE_T *); extern void genie_execve_child (NODE_T *); extern void genie_execve_child_pipe (NODE_T *); extern void genie_execve_output (NODE_T *); extern void genie_f_and_becomes (NODE_T *, MOID_T *, GPROC *); extern void genie_find_proc_op (NODE_T *, int *); extern void genie_fork (NODE_T *); extern void genie_generator_bounds (NODE_T *); extern void genie_generator_internal (NODE_T *, MOID_T *, TAG_T *, LEAP_T, ADDR_T); extern void genie_getenv (NODE_T *); extern void genie_identity_dec (NODE_T *); extern void genie_init_heap (NODE_T *); extern void genie_init_rng (void); extern void genie_localtime (NODE_T *); extern void genie_operator_dec (NODE_T *); extern void genie_preprocess (NODE_T *, int *, void *); extern void genie_proc_variable_dec (NODE_T *); extern void genie_push_undefined (NODE_T *, MOID_T *); extern void genie_read_standard (NODE_T *, MOID_T *, BYTE_T *, A68_REF); extern void genie_reset_errno (NODE_T *); extern void genie_rows (NODE_T *); extern void genie_serial_clause (NODE_T *, jmp_buf *); extern void genie_serial_units (NODE_T *, NODE_T **, jmp_buf *, int); extern void genie_strerror (NODE_T *); extern void genie_string_to_value (NODE_T *, MOID_T *, BYTE_T *, A68_REF); extern void genie_subscript (NODE_T *, A68_TUPLE **, int *, NODE_T **); extern void genie_utctime (NODE_T *); extern void genie_value_to_string (NODE_T *, MOID_T *, BYTE_T *, int); extern void genie_variable_dec (NODE_T *, NODE_T **, ADDR_T); extern void genie_waitpid (NODE_T *); extern void genie_write_standard (NODE_T *, MOID_T *, BYTE_T *, A68_REF); extern void get_global_level (NODE_T *); extern void get_max_simplout_size (NODE_T *); extern void get_refinements (void); extern void get_stack_size (void); extern void indenter (MODULE_T *); extern BOOL_T folder_mode (MOID_T *); extern void push_unit (NODE_T *); extern BOOL_T constant_unit (NODE_T *); extern void init_curses (void); extern void init_file_entries (void); extern void init_file_entry (int); extern void init_heap (void); extern void init_options (void); extern void init_postulates (void); extern void init_rng (unsigned long); extern void init_tty (void); extern void initialise_frame (NODE_T *); extern void initialise_internal_index (A68_TUPLE *, int); extern void install_signal_handlers (void); extern void io_close_tty_line (void); extern void io_write_string (FILE_T, const char *); extern void isolate_options (char *, LINE_T *); extern void jumps_from_procs (NODE_T * p); extern void list_source_line (FILE_T, LINE_T *, BOOL_T); extern void make_postulate (POSTULATE_T **, MOID_T *, MOID_T *); extern void make_special_mode (MOID_T **, int); extern void make_standard_environ (void); extern void make_sub (NODE_T *, NODE_T *, int); extern void make_moid_list (MODULE_T *); extern void mark_auxilliary (NODE_T *); extern void mark_moids (NODE_T *); extern void mode_checker (NODE_T *); extern void monitor_error (char *, char *); extern void on_event_handler (NODE_T *, A68_PROCEDURE, A68_REF); extern void online_help (FILE_T); extern void open_error (NODE_T *, A68_REF, char *); extern void pattern_error (NODE_T *, MOID_T *, int); extern void portcheck (NODE_T *); extern void preliminary_symbol_table_setup (NODE_T *); extern void print_bytes (BYTE_T *, int); extern void print_internal_index (FILE_T, A68_TUPLE *, int); extern void print_item (NODE_T *, FILE_T, BYTE_T *, MOID_T *); extern void print_mode_flat (FILE_T, MOID_T *); extern void prune_echoes (OPTION_LIST_T *); extern void put_refinements (void); extern void read_env_options (void); extern void read_insertion (NODE_T *, A68_REF); extern void read_rc_options (void); extern void read_sound (NODE_T *, A68_REF, A68_SOUND *); extern void rearrange_goto_less_jumps (NODE_T *); extern void register_nodes (NODE_T *); extern void renumber_moids (MOID_T *, int); extern void renumber_nodes (NODE_T *, int *); extern void reset_symbol_table_nest_count (NODE_T *); extern void reset_transput_buffer (int); extern void scan_error (LINE_T *, char *, char *); extern void scope_checker (NODE_T *); extern void set_default_event_procedure (A68_PROCEDURE *); extern void set_default_event_procedures (A68_FILE *); extern void set_moid_sizes (MOID_T *); extern void set_nest (NODE_T *, NODE_T *); extern void set_par_level (NODE_T *, int); extern void set_proc_level (NODE_T *, int); extern void set_transput_buffer_index (int, int); extern void set_transput_buffer_size (int, int); extern void set_up_tables (void); extern void single_step (NODE_T *, unsigned); extern void stack_dump (FILE_T, ADDR_T, int, int *); extern void standardise (double *, int, int, int *); extern void state_license (FILE_T); extern void state_version (FILE_T); extern void substitute_brackets (NODE_T *); extern void tie_label_to_serial (NODE_T *); extern void tie_label_to_unit (NODE_T *); extern void top_down_parser (NODE_T *); extern void transput_error (NODE_T *, A68_REF, MOID_T *); extern void tree_listing (FILE_T, NODE_T *, int, LINE_T *, int *); extern void unchar_scanner (NODE_T *, A68_FILE *, char); extern void value_error (NODE_T *, MOID_T *, A68_REF); extern void victal_checker (NODE_T *); extern void warn_for_unused_tags (NODE_T *); extern void where_in_source (FILE_T, NODE_T *); extern void widen_denotation (NODE_T *); extern void write_insertion (NODE_T *, A68_REF, unsigned); extern void write_listing (void); extern void write_listing_header (void); extern void write_object_listing (void); extern void write_purge_buffer (NODE_T *, A68_REF, int); extern void write_sound (NODE_T *, A68_REF, A68_SOUND *); extern void write_source_line (FILE_T, LINE_T *, NODE_T *, int); extern void write_source_listing (void); extern void write_tree_listing (void); #if defined HAVE_CURSES #endif #if defined HAVE_PARALLEL_CLAUSE extern BOOL_T is_main_thread (void); extern void genie_abend_all_threads (NODE_T *, jmp_buf *, NODE_T *); extern void genie_set_exit_from_threads (int); #endif /* External multi-precision procedures */ extern BOOL_T check_long_int (MP_T *); extern BOOL_T check_longlong_int (MP_T *); extern BOOL_T check_mp_int (MP_T *, MOID_T *); extern MP_T *abs_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *minus_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *round_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *entier_mp (NODE_T *, MP_T *, MP_T *, int); extern void eq_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void ne_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void lt_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void le_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void gt_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern void ge_mp (NODE_T *, A68_BOOL *, MP_T *, MP_T *, int); extern MP_T *acos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *acosh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *add_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *asin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *asinh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *atan2_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *atan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *atanh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cacos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *casin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *catan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *ccos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cdiv_mp (NODE_T *, MP_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *cexp_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cln_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cmul_mp (NODE_T *, MP_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *cos_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *cosh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *csin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *csqrt_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *ctan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *curt_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *div_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *div_mp_digit (NODE_T *, MP_T *, MP_T *, MP_T, int); extern MP_T *exp_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *expm1_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *hyp_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *hypot_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *int_to_mp (NODE_T *, MP_T *, int, int); extern MP_T *lengthen_mp (NODE_T *, MP_T *, int, MP_T *, int); extern MP_T *ln_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *log_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *mod_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *mp_pi (NODE_T *, MP_T *, int, int); extern MP_T *mp_ten_up (NODE_T *, MP_T *, int, int); extern MP_T *mul_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *mul_mp_digit (NODE_T *, MP_T *, MP_T *, MP_T, int); extern MP_T *over_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *over_mp_digit (NODE_T *, MP_T *, MP_T *, MP_T, int); extern MP_T *pack_mp_bits (NODE_T *, MP_T *, unsigned *, MOID_T *); extern MP_T *pow_mp_int (NODE_T *, MP_T *, MP_T *, int, int); extern MP_T *real_to_mp (NODE_T *, MP_T *, double, int); extern MP_T *set_mp_short (MP_T *, MP_T, int, int); extern MP_T *shorten_mp (NODE_T *, MP_T *, int, MP_T *, int); extern MP_T *sin_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *sinh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *sqrt_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *string_to_mp (NODE_T *, MP_T *, char *, int); extern MP_T *sub_mp (NODE_T *, MP_T *, MP_T *, MP_T *, int); extern MP_T *tan_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *tanh_mp (NODE_T *, MP_T *, MP_T *, int); extern MP_T *unsigned_to_mp (NODE_T *, MP_T *, unsigned, int); extern char *long_sub_fixed (NODE_T *, MP_T *, int, int, int); extern char *long_sub_whole (NODE_T *, MP_T *, int, int); extern double mp_to_real (NODE_T *, MP_T *, int); extern int get_mp_bits_width (MOID_T *); extern int get_mp_bits_words (MOID_T *); extern int int_to_mp_digits (int); extern int long_mp_digits (void); extern int longlong_mp_digits (void); extern int mp_to_int (NODE_T *, MP_T *, int); extern size_t size_long_mp (void); extern size_t size_longlong_mp (void); extern unsigned *stack_mp_bits (NODE_T *, MP_T *, MOID_T *); extern unsigned mp_to_unsigned (NODE_T *, MP_T *, int); extern void check_long_bits_value (NODE_T *, MP_T *, MOID_T *); extern void long_standardise (NODE_T *, MP_T *, int, int, int, int *); extern void raw_write_mp (char *, MP_T *, int); extern void set_longlong_mp_digits (int); extern void trunc_mp (NODE_T *, MP_T *, MP_T *, int); /* Standard prelude RTS */ extern GPROC genie_abend; extern GPROC genie_abs_bits; extern GPROC genie_abs_bool; extern GPROC genie_abs_char; extern GPROC genie_abs_complex; extern GPROC genie_abs_int; extern GPROC genie_abs_long_complex; extern GPROC genie_abs_long_mp; extern GPROC genie_abs_real; extern GPROC genie_acos_long_complex; extern GPROC genie_acos_long_mp; extern GPROC genie_acronym; extern GPROC genie_add_bytes; extern GPROC genie_add_char; extern GPROC genie_add_complex; extern GPROC genie_add_int; extern GPROC genie_add_long_bytes; extern GPROC genie_add_long_complex; extern GPROC genie_add_long_int; extern GPROC genie_add_long_mp; extern GPROC genie_add_real; extern GPROC genie_add_string; extern GPROC genie_and_bits; extern GPROC genie_and_bool; extern GPROC genie_and_long_mp; extern GPROC genie_arccos_complex; extern GPROC genie_arccos_real; extern GPROC genie_arccosh_complex; extern GPROC genie_arccosh_long_mp; extern GPROC genie_arccosh_real; extern GPROC genie_arcsin_complex; extern GPROC genie_arcsin_real; extern GPROC genie_arcsinh_complex; extern GPROC genie_arcsinh_long_mp; extern GPROC genie_arcsinh_real; extern GPROC genie_arctan_complex; extern GPROC genie_arctan_real; extern GPROC genie_arctanh_complex; extern GPROC genie_arctanh_long_mp; extern GPROC genie_arctanh_real; extern GPROC genie_arg_complex; extern GPROC genie_arg_long_complex; extern GPROC genie_asin_long_complex; extern GPROC genie_asin_long_mp; extern GPROC genie_associate; extern GPROC genie_atan2_long_mp; extern GPROC genie_atan2_real; extern GPROC genie_atan_long_complex; extern GPROC genie_atan_long_mp; extern GPROC genie_backspace; extern GPROC genie_bin_int; extern GPROC genie_bin_long_mp; extern GPROC genie_bin_possible; extern GPROC genie_bits_lengths; extern GPROC genie_bits_pack; extern GPROC genie_bits_shorths; extern GPROC genie_bits_width; extern GPROC genie_blank_char; extern GPROC genie_block; extern GPROC genie_break; extern GPROC genie_bytes_lengths; extern GPROC genie_bytes_shorths; extern GPROC genie_bytes_width; extern GPROC genie_bytespack; extern GPROC genie_cd; extern GPROC genie_char_in_string; extern GPROC genie_clear_bits; extern GPROC genie_clear_long_bits; extern GPROC genie_clear_longlong_bits; extern GPROC genie_close; extern GPROC genie_complex_lengths; extern GPROC genie_complex_shorths; extern GPROC genie_compressible; extern GPROC genie_conj_complex; extern GPROC genie_conj_long_complex; extern GPROC genie_cos_complex; extern GPROC genie_cos_long_complex; extern GPROC genie_cos_long_mp; extern GPROC genie_cos_real; extern GPROC genie_cosh_complex; extern GPROC genie_cosh_long_mp; extern GPROC genie_cosh_real; extern GPROC genie_cputime; extern GPROC genie_create; extern GPROC genie_curt_long_mp; extern GPROC genie_curt_real; extern GPROC genie_debug; extern GPROC genie_directory; extern GPROC genie_div_complex; extern GPROC genie_div_int; extern GPROC genie_div_long_complex; extern GPROC genie_div_long_mp; extern GPROC genie_div_real; extern GPROC genie_divab_complex; extern GPROC genie_divab_long_complex; extern GPROC genie_divab_long_mp; extern GPROC genie_divab_real; extern GPROC genie_draw_possible; extern GPROC genie_dyad_elems; extern GPROC genie_dyad_lwb; extern GPROC genie_dyad_upb; extern GPROC genie_elem_bits; extern GPROC genie_elem_bytes; extern GPROC genie_elem_long_bits; extern GPROC genie_elem_long_bits; extern GPROC genie_elem_long_bytes; extern GPROC genie_elem_longlong_bits; extern GPROC genie_elem_string; extern GPROC genie_entier_long_mp; extern GPROC genie_entier_real; extern GPROC genie_eof; extern GPROC genie_eoln; extern GPROC genie_eq_bits; extern GPROC genie_eq_bool; extern GPROC genie_eq_bytes; extern GPROC genie_eq_char; extern GPROC genie_eq_complex; extern GPROC genie_eq_int; extern GPROC genie_eq_long_bytes; extern GPROC genie_eq_long_complex; extern GPROC genie_eq_long_mp; extern GPROC genie_eq_real; extern GPROC genie_eq_string; extern GPROC genie_erase; extern GPROC genie_erf_real; extern GPROC genie_erfc_real; extern GPROC genie_error_char; extern GPROC genie_establish; extern GPROC genie_evaluate; extern GPROC genie_exp_char; extern GPROC genie_exp_complex; extern GPROC genie_exp_long_complex; extern GPROC genie_exp_long_mp; extern GPROC genie_exp_real; extern GPROC genie_exp_width; extern GPROC genie_file_is_block_device; extern GPROC genie_file_is_char_device; extern GPROC genie_file_is_directory; extern GPROC genie_file_is_regular; extern GPROC genie_file_mode; extern GPROC genie_first_random; extern GPROC genie_fixed; extern GPROC genie_flip_char; extern GPROC genie_float; extern GPROC genie_flop_char; extern GPROC genie_formfeed_char; extern GPROC genie_garbage_collections; extern GPROC genie_garbage_freed; extern GPROC genie_garbage_seconds; extern GPROC genie_gc_heap; extern GPROC genie_ge_bits; extern GPROC genie_ge_bytes; extern GPROC genie_ge_char; extern GPROC genie_ge_int; extern GPROC genie_ge_long_bits; extern GPROC genie_ge_long_bytes; extern GPROC genie_ge_long_mp; extern GPROC genie_ge_real; extern GPROC genie_ge_string; extern GPROC genie_get_possible; extern GPROC genie_get_sound; extern GPROC genie_gt_bytes; extern GPROC genie_gt_char; extern GPROC genie_gt_int; extern GPROC genie_gt_long_bytes; extern GPROC genie_gt_long_mp; extern GPROC genie_gt_real; extern GPROC genie_gt_string; extern GPROC genie_icomplex; extern GPROC genie_idf; extern GPROC genie_idle; extern GPROC genie_iint_complex; extern GPROC genie_im_complex; extern GPROC genie_im_long_complex; extern GPROC genie_init_transput; extern GPROC genie_int_lengths; extern GPROC genie_int_shorths; extern GPROC genie_int_width; extern GPROC genie_inverf_real; extern GPROC genie_inverfc_real; extern GPROC genie_is_alnum; extern GPROC genie_is_alpha; extern GPROC genie_is_cntrl; extern GPROC genie_is_digit; extern GPROC genie_is_graph; extern GPROC genie_is_lower; extern GPROC genie_is_print; extern GPROC genie_is_punct; extern GPROC genie_is_space; extern GPROC genie_is_upper; extern GPROC genie_is_xdigit; extern GPROC genie_last_char_in_string; extern GPROC genie_le_bits; extern GPROC genie_le_bytes; extern GPROC genie_le_char; extern GPROC genie_le_int; extern GPROC genie_le_long_bits; extern GPROC genie_le_long_bytes; extern GPROC genie_le_long_mp; extern GPROC genie_le_real; extern GPROC genie_le_string; extern GPROC genie_leng_bytes; extern GPROC genie_lengthen_complex_to_long_complex; extern GPROC genie_lengthen_int_to_long_mp; extern GPROC genie_lengthen_long_complex_to_longlong_complex; extern GPROC genie_lengthen_long_mp_to_longlong_mp; extern GPROC genie_lengthen_real_to_long_mp; extern GPROC genie_lengthen_unsigned_to_long_mp; extern GPROC genie_lj_e_12_6; extern GPROC genie_lj_f_12_6; extern GPROC genie_ln_complex; extern GPROC genie_ln_long_complex; extern GPROC genie_ln_long_mp; extern GPROC genie_ln_real; extern GPROC genie_lock; extern GPROC genie_log_long_mp; extern GPROC genie_log_real; extern GPROC genie_long_bits_pack; extern GPROC genie_long_bits_width; extern GPROC genie_long_bytes_width; extern GPROC genie_long_bytespack; extern GPROC genie_long_exp_width; extern GPROC genie_long_int_width; extern GPROC genie_long_max_bits; extern GPROC genie_long_max_int; extern GPROC genie_long_max_real; extern GPROC genie_long_min_real; extern GPROC genie_long_next_random; extern GPROC genie_long_real_width; extern GPROC genie_long_small_real; extern GPROC genie_longlong_bits_width; extern GPROC genie_longlong_exp_width; extern GPROC genie_longlong_int_width; extern GPROC genie_longlong_max_bits; extern GPROC genie_longlong_max_int; extern GPROC genie_longlong_max_real; extern GPROC genie_longlong_min_real; extern GPROC genie_longlong_real_width; extern GPROC genie_longlong_small_real; extern GPROC genie_lt_bytes; extern GPROC genie_lt_char; extern GPROC genie_lt_int; extern GPROC genie_lt_long_bytes; extern GPROC genie_lt_long_mp; extern GPROC genie_lt_real; extern GPROC genie_lt_string; extern GPROC genie_make_term; extern GPROC genie_max_abs_char; extern GPROC genie_max_bits; extern GPROC genie_max_int; extern GPROC genie_max_real; extern GPROC genie_min_real; extern GPROC genie_minus_complex; extern GPROC genie_minus_int; extern GPROC genie_minus_long_complex; extern GPROC genie_minus_long_mp; extern GPROC genie_minus_real; extern GPROC genie_minusab_complex; extern GPROC genie_minusab_int; extern GPROC genie_minusab_long_complex; extern GPROC genie_minusab_long_int; extern GPROC genie_minusab_long_mp; extern GPROC genie_minusab_real; extern GPROC genie_mod_int; extern GPROC genie_mod_long_mp; extern GPROC genie_modab_int; extern GPROC genie_modab_long_mp; extern GPROC genie_monad_elems; extern GPROC genie_monad_lwb; extern GPROC genie_monad_upb; extern GPROC genie_mul_complex; extern GPROC genie_mul_int; extern GPROC genie_mul_long_complex; extern GPROC genie_mul_long_int; extern GPROC genie_mul_long_mp; extern GPROC genie_mul_real; extern GPROC genie_ne_bits; extern GPROC genie_ne_bool; extern GPROC genie_ne_bytes; extern GPROC genie_ne_char; extern GPROC genie_ne_complex; extern GPROC genie_ne_int; extern GPROC genie_ne_long_bytes; extern GPROC genie_ne_long_complex; extern GPROC genie_ne_long_mp; extern GPROC genie_ne_real; extern GPROC genie_ne_string; extern GPROC genie_new_line; extern GPROC genie_new_page; extern GPROC genie_new_sound; extern GPROC genie_newline_char; extern GPROC genie_next_random; extern GPROC genie_next_rnd; extern GPROC genie_not_bits; extern GPROC genie_not_bool; extern GPROC genie_not_long_mp; extern GPROC genie_null_char; extern GPROC genie_odd_int; extern GPROC genie_odd_long_mp; extern GPROC genie_on_file_end; extern GPROC genie_on_format_end; extern GPROC genie_on_format_error; extern GPROC genie_on_gc_event; extern GPROC genie_on_line_end; extern GPROC genie_on_open_error; extern GPROC genie_on_page_end; extern GPROC genie_on_transput_error; extern GPROC genie_on_value_error; extern GPROC genie_open; extern GPROC genie_or_bits; extern GPROC genie_or_bool; extern GPROC genie_or_long_mp; extern GPROC genie_over_int; extern GPROC genie_over_long_mp; extern GPROC genie_overab_int; extern GPROC genie_overab_long_mp; extern GPROC genie_pi; extern GPROC genie_pi_long_mp; extern GPROC genie_plusab_bytes; extern GPROC genie_plusab_complex; extern GPROC genie_plusab_int; extern GPROC genie_plusab_long_bytes; extern GPROC genie_plusab_long_complex; extern GPROC genie_plusab_long_int; extern GPROC genie_plusab_long_mp; extern GPROC genie_plusab_real; extern GPROC genie_plusab_string; extern GPROC genie_plusto_bytes; extern GPROC genie_plusto_long_bytes; extern GPROC genie_plusto_string; extern GPROC genie_pow_complex_int; extern GPROC genie_pow_int; extern GPROC genie_pow_long_complex_int; extern GPROC genie_pow_long_mp; extern GPROC genie_pow_long_mp_int; extern GPROC genie_pow_long_mp_int_int; extern GPROC genie_pow_real; extern GPROC genie_pow_real_int; extern GPROC genie_preemptive_gc_heap; extern GPROC genie_print_bits; extern GPROC genie_print_bool; extern GPROC genie_print_char; extern GPROC genie_print_complex; extern GPROC genie_print_int; extern GPROC genie_print_long_bits; extern GPROC genie_print_long_complex; extern GPROC genie_print_long_int; extern GPROC genie_print_long_real; extern GPROC genie_print_longlong_bits; extern GPROC genie_print_longlong_complex; extern GPROC genie_print_longlong_int; extern GPROC genie_print_longlong_real; extern GPROC genie_print_real; extern GPROC genie_print_string; extern GPROC genie_put_bits; extern GPROC genie_put_bool; extern GPROC genie_put_char; extern GPROC genie_put_complex; extern GPROC genie_put_int; extern GPROC genie_put_string; extern GPROC genie_put_long_bits; extern GPROC genie_put_long_complex; extern GPROC genie_put_long_int; extern GPROC genie_put_long_real; extern GPROC genie_put_longlong_bits; extern GPROC genie_put_longlong_complex; extern GPROC genie_put_longlong_int; extern GPROC genie_put_longlong_real; extern GPROC genie_put_real; extern GPROC genie_print_string; extern GPROC genie_program_idf; extern GPROC genie_put_possible; extern GPROC genie_pwd; extern GPROC genie_re_complex; extern GPROC genie_re_long_complex; extern GPROC genie_read; extern GPROC genie_read_bin; extern GPROC genie_read_bin_file; extern GPROC genie_read_bits; extern GPROC genie_read_bool; extern GPROC genie_read_char; extern GPROC genie_read_complex; extern GPROC genie_read_file; extern GPROC genie_read_file_format; extern GPROC genie_read_format; extern GPROC genie_read_int; extern GPROC genie_read_long_bits; extern GPROC genie_read_long_complex; extern GPROC genie_read_long_int; extern GPROC genie_read_long_real; extern GPROC genie_read_longlong_bits; extern GPROC genie_read_longlong_complex; extern GPROC genie_read_longlong_int; extern GPROC genie_read_longlong_real; extern GPROC genie_read_real; extern GPROC genie_read_string; extern GPROC genie_get_bits; extern GPROC genie_get_bool; extern GPROC genie_get_char; extern GPROC genie_get_complex; extern GPROC genie_get_int; extern GPROC genie_get_long_bits; extern GPROC genie_get_long_complex; extern GPROC genie_get_long_int; extern GPROC genie_get_long_real; extern GPROC genie_get_longlong_bits; extern GPROC genie_get_longlong_complex; extern GPROC genie_get_longlong_int; extern GPROC genie_get_longlong_real; extern GPROC genie_get_real; extern GPROC genie_get_string; extern GPROC genie_read_line; extern GPROC genie_real; extern GPROC genie_real_lengths; extern GPROC genie_real_shorths; extern GPROC genie_real_width; extern GPROC genie_reidf_possible; extern GPROC genie_repr_char; extern GPROC genie_reset; extern GPROC genie_reset_possible; extern GPROC genie_round_long_mp; extern GPROC genie_round_real; extern GPROC genie_set; extern GPROC genie_set_bits; extern GPROC genie_set_long_bits; extern GPROC genie_set_longlong_bits; extern GPROC genie_set_possible; extern GPROC genie_set_sound; extern GPROC genie_set_return_code; extern GPROC genie_shl_bits; extern GPROC genie_shl_long_mp; extern GPROC genie_shorten_bytes; extern GPROC genie_shorten_long_complex_to_complex; extern GPROC genie_shorten_long_mp_to_bits; extern GPROC genie_shorten_long_mp_to_int; extern GPROC genie_shorten_long_mp_to_real; extern GPROC genie_shorten_longlong_complex_to_long_complex; extern GPROC genie_shorten_longlong_mp_to_long_mp; extern GPROC genie_shr_bits; extern GPROC genie_shr_long_mp; extern GPROC genie_sign_int; extern GPROC genie_sign_long_mp; extern GPROC genie_sign_real; extern GPROC genie_sin_complex; extern GPROC genie_sin_long_complex; extern GPROC genie_sin_long_mp; extern GPROC genie_sin_real; extern GPROC genie_sinh_complex; extern GPROC genie_sinh_long_mp; extern GPROC genie_sinh_real; extern GPROC genie_small_real; extern GPROC genie_sort_row_string; extern GPROC genie_sound_channels; extern GPROC genie_sound_rate; extern GPROC genie_sound_resolution; extern GPROC genie_sound_samples; extern GPROC genie_space; extern GPROC genie_sqrt_complex; extern GPROC genie_sqrt_long_complex; extern GPROC genie_sqrt_long_mp; extern GPROC genie_sqrt_real; extern GPROC genie_stack_pointer; extern GPROC genie_stand_back; extern GPROC genie_stand_back_channel; extern GPROC genie_stand_draw_channel; extern GPROC genie_stand_error; extern GPROC genie_stand_error_channel; extern GPROC genie_stand_in; extern GPROC genie_stand_in_channel; extern GPROC genie_stand_out; extern GPROC genie_stand_out_channel; extern GPROC genie_string_in_string; extern GPROC genie_sub_complex; extern GPROC genie_sub_int; extern GPROC genie_sub_long_complex; extern GPROC genie_sub_long_int; extern GPROC genie_sub_long_mp; extern GPROC genie_sub_real; extern GPROC genie_system; extern GPROC genie_system_stack_pointer; extern GPROC genie_system_stack_size; extern GPROC genie_tab_char; extern GPROC genie_tan_complex; extern GPROC genie_tan_long_complex; extern GPROC genie_tan_long_mp; extern GPROC genie_tan_real; extern GPROC genie_tanh_complex; extern GPROC genie_tanh_long_mp; extern GPROC genie_tanh_real; extern GPROC genie_term; extern GPROC genie_times_char_int; extern GPROC genie_times_int_char; extern GPROC genie_times_int_string; extern GPROC genie_times_string_int; extern GPROC genie_timesab_complex; extern GPROC genie_timesab_int; extern GPROC genie_timesab_long_complex; extern GPROC genie_timesab_long_int; extern GPROC genie_timesab_long_mp; extern GPROC genie_timesab_real; extern GPROC genie_timesab_string; extern GPROC genie_to_lower; extern GPROC genie_to_upper; extern GPROC genie_unimplemented; extern GPROC genie_whole; extern GPROC genie_write; extern GPROC genie_write_bin; extern GPROC genie_write_bin_file; extern GPROC genie_write_file; extern GPROC genie_write_file_format; extern GPROC genie_write_format; extern GPROC genie_xor_bits; extern GPROC genie_xor_bool; extern GPROC genie_xor_long_mp; #if defined __S_IFIFO extern GPROC genie_file_is_fifo; #endif #if defined __S_IFLNK extern GPROC genie_file_is_link; #endif #if defined HAVE_PARALLEL_CLAUSE extern GPROC genie_down_sema; extern GPROC genie_level_int_sema; extern GPROC genie_level_sema_int; extern GPROC genie_up_sema; #endif #if defined HAVE_HTTP extern GPROC genie_http_content; extern GPROC genie_tcp_request; #endif #if defined HAVE_REGEX_H extern GPROC genie_grep_in_string; extern GPROC genie_grep_in_substring; extern GPROC genie_sub_in_string; #endif /* Constants ex GSL */ extern GPROC genie_cgs_acre; extern GPROC genie_cgs_angstrom; extern GPROC genie_cgs_astronomical_unit; extern GPROC genie_cgs_bar; extern GPROC genie_cgs_barn; extern GPROC genie_cgs_bohr_magneton; extern GPROC genie_cgs_bohr_radius; extern GPROC genie_cgs_boltzmann; extern GPROC genie_cgs_btu; extern GPROC genie_cgs_calorie; extern GPROC genie_cgs_canadian_gallon; extern GPROC genie_cgs_carat; extern GPROC genie_cgs_cup; extern GPROC genie_cgs_curie; extern GPROC genie_cgs_day; extern GPROC genie_cgs_dyne; extern GPROC genie_cgs_electron_charge; extern GPROC genie_cgs_electron_magnetic_moment; extern GPROC genie_cgs_electron_volt; extern GPROC genie_cgs_erg; extern GPROC genie_cgs_faraday; extern GPROC genie_cgs_fathom; extern GPROC genie_cgs_fluid_ounce; extern GPROC genie_cgs_foot; extern GPROC genie_cgs_footcandle; extern GPROC genie_cgs_footlambert; extern GPROC genie_cgs_gauss; extern GPROC genie_cgs_gram_force; extern GPROC genie_cgs_grav_accel; extern GPROC genie_cgs_gravitational_constant; extern GPROC genie_cgs_hectare; extern GPROC genie_cgs_horsepower; extern GPROC genie_cgs_hour; extern GPROC genie_cgs_inch; extern GPROC genie_cgs_inch_of_mercury; extern GPROC genie_cgs_inch_of_water; extern GPROC genie_cgs_joule; extern GPROC genie_cgs_kilometers_per_hour; extern GPROC genie_cgs_kilopound_force; extern GPROC genie_cgs_knot; extern GPROC genie_cgs_lambert; extern GPROC genie_cgs_light_year; extern GPROC genie_cgs_liter; extern GPROC genie_cgs_lumen; extern GPROC genie_cgs_lux; extern GPROC genie_cgs_mass_electron; extern GPROC genie_cgs_mass_muon; extern GPROC genie_cgs_mass_neutron; extern GPROC genie_cgs_mass_proton; extern GPROC genie_cgs_meter_of_mercury; extern GPROC genie_cgs_metric_ton; extern GPROC genie_cgs_micron; extern GPROC genie_cgs_mil; extern GPROC genie_cgs_mile; extern GPROC genie_cgs_miles_per_hour; extern GPROC genie_cgs_minute; extern GPROC genie_cgs_molar_gas; extern GPROC genie_cgs_nautical_mile; extern GPROC genie_cgs_newton; extern GPROC genie_cgs_nuclear_magneton; extern GPROC genie_cgs_ounce_mass; extern GPROC genie_cgs_parsec; extern GPROC genie_cgs_phot; extern GPROC genie_cgs_pint; extern GPROC genie_cgs_planck_constant_h; extern GPROC genie_cgs_planck_constant_hbar; extern GPROC genie_cgs_point; extern GPROC genie_cgs_poise; extern GPROC genie_cgs_pound_force; extern GPROC genie_cgs_pound_mass; extern GPROC genie_cgs_poundal; extern GPROC genie_cgs_proton_magnetic_moment; extern GPROC genie_cgs_psi; extern GPROC genie_cgs_quart; extern GPROC genie_cgs_rad; extern GPROC genie_cgs_roentgen; extern GPROC genie_cgs_rydberg; extern GPROC genie_cgs_solar_mass; extern GPROC genie_cgs_speed_of_light; extern GPROC genie_cgs_standard_gas_volume; extern GPROC genie_cgs_std_atmosphere; extern GPROC genie_cgs_stilb; extern GPROC genie_cgs_stokes; extern GPROC genie_cgs_tablespoon; extern GPROC genie_cgs_teaspoon; extern GPROC genie_cgs_texpoint; extern GPROC genie_cgs_therm; extern GPROC genie_cgs_ton; extern GPROC genie_cgs_torr; extern GPROC genie_cgs_troy_ounce; extern GPROC genie_cgs_uk_gallon; extern GPROC genie_cgs_uk_ton; extern GPROC genie_cgs_unified_atomic_mass; extern GPROC genie_cgs_us_gallon; extern GPROC genie_cgs_week; extern GPROC genie_cgs_yard; extern GPROC genie_mks_acre; extern GPROC genie_mks_angstrom; extern GPROC genie_mks_astronomical_unit; extern GPROC genie_mks_bar; extern GPROC genie_mks_barn; extern GPROC genie_mks_bohr_magneton; extern GPROC genie_mks_bohr_radius; extern GPROC genie_mks_boltzmann; extern GPROC genie_mks_btu; extern GPROC genie_mks_calorie; extern GPROC genie_mks_canadian_gallon; extern GPROC genie_mks_carat; extern GPROC genie_mks_cup; extern GPROC genie_mks_curie; extern GPROC genie_mks_day; extern GPROC genie_mks_dyne; extern GPROC genie_mks_electron_charge; extern GPROC genie_mks_electron_magnetic_moment; extern GPROC genie_mks_electron_volt; extern GPROC genie_mks_erg; extern GPROC genie_mks_faraday; extern GPROC genie_mks_fathom; extern GPROC genie_mks_fluid_ounce; extern GPROC genie_mks_foot; extern GPROC genie_mks_footcandle; extern GPROC genie_mks_footlambert; extern GPROC genie_mks_gauss; extern GPROC genie_mks_gram_force; extern GPROC genie_mks_grav_accel; extern GPROC genie_mks_gravitational_constant; extern GPROC genie_mks_hectare; extern GPROC genie_mks_horsepower; extern GPROC genie_mks_hour; extern GPROC genie_mks_inch; extern GPROC genie_mks_inch_of_mercury; extern GPROC genie_mks_inch_of_water; extern GPROC genie_mks_joule; extern GPROC genie_mks_kilometers_per_hour; extern GPROC genie_mks_kilopound_force; extern GPROC genie_mks_knot; extern GPROC genie_mks_lambert; extern GPROC genie_mks_light_year; extern GPROC genie_mks_liter; extern GPROC genie_mks_lumen; extern GPROC genie_mks_lux; extern GPROC genie_mks_mass_electron; extern GPROC genie_mks_mass_muon; extern GPROC genie_mks_mass_neutron; extern GPROC genie_mks_mass_proton; extern GPROC genie_mks_meter_of_mercury; extern GPROC genie_mks_metric_ton; extern GPROC genie_mks_micron; extern GPROC genie_mks_mil; extern GPROC genie_mks_mile; extern GPROC genie_mks_miles_per_hour; extern GPROC genie_mks_minute; extern GPROC genie_mks_molar_gas; extern GPROC genie_mks_nautical_mile; extern GPROC genie_mks_newton; extern GPROC genie_mks_nuclear_magneton; extern GPROC genie_mks_ounce_mass; extern GPROC genie_mks_parsec; extern GPROC genie_mks_phot; extern GPROC genie_mks_pint; extern GPROC genie_mks_planck_constant_h; extern GPROC genie_mks_planck_constant_hbar; extern GPROC genie_mks_point; extern GPROC genie_mks_poise; extern GPROC genie_mks_pound_force; extern GPROC genie_mks_pound_mass; extern GPROC genie_mks_poundal; extern GPROC genie_mks_proton_magnetic_moment; extern GPROC genie_mks_psi; extern GPROC genie_mks_quart; extern GPROC genie_mks_rad; extern GPROC genie_mks_roentgen; extern GPROC genie_mks_rydberg; extern GPROC genie_mks_solar_mass; extern GPROC genie_mks_speed_of_light; extern GPROC genie_mks_standard_gas_volume; extern GPROC genie_mks_std_atmosphere; extern GPROC genie_mks_stilb; extern GPROC genie_mks_stokes; extern GPROC genie_mks_tablespoon; extern GPROC genie_mks_teaspoon; extern GPROC genie_mks_texpoint; extern GPROC genie_mks_therm; extern GPROC genie_mks_ton; extern GPROC genie_mks_torr; extern GPROC genie_mks_troy_ounce; extern GPROC genie_mks_uk_gallon; extern GPROC genie_mks_uk_ton; extern GPROC genie_mks_unified_atomic_mass; extern GPROC genie_mks_us_gallon; extern GPROC genie_mks_vacuum_permeability; extern GPROC genie_mks_vacuum_permittivity; extern GPROC genie_mks_week; extern GPROC genie_mks_yard; extern GPROC genie_num_atto; extern GPROC genie_num_avogadro; extern GPROC genie_num_exa; extern GPROC genie_num_femto; extern GPROC genie_num_fine_structure; extern GPROC genie_num_giga; extern GPROC genie_num_kilo; extern GPROC genie_num_mega; extern GPROC genie_num_micro; extern GPROC genie_num_milli; extern GPROC genie_num_nano; extern GPROC genie_num_peta; extern GPROC genie_num_pico; extern GPROC genie_num_tera; extern GPROC genie_num_yocto; extern GPROC genie_num_yotta; extern GPROC genie_num_zepto; extern GPROC genie_num_zetta; #if defined HAVE_GNU_PLOTUTILS extern GPROC genie_draw_aspect; extern GPROC genie_draw_atom; extern GPROC genie_draw_background_colour; extern GPROC genie_draw_background_colour_name; extern GPROC genie_draw_circle; extern GPROC genie_draw_clear; extern GPROC genie_draw_colour; extern GPROC genie_draw_colour_name; extern GPROC genie_draw_fillstyle; extern GPROC genie_draw_fontname; extern GPROC genie_draw_fontsize; extern GPROC genie_draw_get_colour_name; extern GPROC genie_draw_line; extern GPROC genie_draw_linestyle; extern GPROC genie_draw_linewidth; extern GPROC genie_draw_move; extern GPROC genie_draw_point; extern GPROC genie_draw_rect; extern GPROC genie_draw_show; extern GPROC genie_draw_star; extern GPROC genie_draw_text; extern GPROC genie_draw_textangle; extern GPROC genie_make_device; #endif #if defined HAVE_GNU_GSL extern GPROC genie_airy_ai_deriv_real; extern GPROC genie_airy_ai_real; extern GPROC genie_airy_bi_deriv_real; extern GPROC genie_airy_bi_real; extern GPROC genie_bessel_exp_il_real; extern GPROC genie_bessel_exp_in_real; extern GPROC genie_bessel_exp_inu_real; extern GPROC genie_bessel_exp_kl_real; extern GPROC genie_bessel_exp_kn_real; extern GPROC genie_bessel_exp_knu_real; extern GPROC genie_bessel_in_real; extern GPROC genie_bessel_inu_real; extern GPROC genie_bessel_jl_real; extern GPROC genie_bessel_jn_real; extern GPROC genie_bessel_jnu_real; extern GPROC genie_bessel_kn_real; extern GPROC genie_bessel_knu_real; extern GPROC genie_bessel_yl_real; extern GPROC genie_bessel_yn_real; extern GPROC genie_bessel_ynu_real; extern GPROC genie_beta_inc_real; extern GPROC genie_beta_real; extern GPROC genie_complex_scale_matrix_complex; extern GPROC genie_complex_scale_vector_complex; extern GPROC genie_elliptic_integral_e_real; extern GPROC genie_elliptic_integral_k_real; extern GPROC genie_elliptic_integral_rc_real; extern GPROC genie_elliptic_integral_rd_real; extern GPROC genie_elliptic_integral_rf_real; extern GPROC genie_elliptic_integral_rj_real; extern GPROC genie_factorial_real; extern GPROC genie_fft_backward; extern GPROC genie_fft_complex_backward; extern GPROC genie_fft_complex_forward; extern GPROC genie_fft_complex_inverse; extern GPROC genie_fft_forward; extern GPROC genie_fft_inverse; extern GPROC genie_gamma_inc_real; extern GPROC genie_gamma_real; extern GPROC genie_laplace; extern GPROC genie_lngamma_real; extern GPROC genie_matrix_add; extern GPROC genie_matrix_ch; extern GPROC genie_matrix_ch_solve; extern GPROC genie_matrix_complex_add; extern GPROC genie_matrix_complex_det; extern GPROC genie_matrix_complex_div_complex; extern GPROC genie_matrix_complex_div_complex_ab; extern GPROC genie_matrix_complex_echo; extern GPROC genie_matrix_complex_eq; extern GPROC genie_matrix_complex_inv; extern GPROC genie_matrix_complex_lu; extern GPROC genie_matrix_complex_lu_det; extern GPROC genie_matrix_complex_lu_inv; extern GPROC genie_matrix_complex_lu_solve; extern GPROC genie_matrix_complex_minus; extern GPROC genie_matrix_complex_minusab; extern GPROC genie_matrix_complex_ne; extern GPROC genie_matrix_complex_plusab; extern GPROC genie_matrix_complex_scale_complex; extern GPROC genie_matrix_complex_scale_complex_ab; extern GPROC genie_matrix_complex_sub; extern GPROC genie_matrix_complex_times_matrix; extern GPROC genie_matrix_complex_times_vector; extern GPROC genie_matrix_complex_trace; extern GPROC genie_matrix_complex_transpose; extern GPROC genie_matrix_det; extern GPROC genie_matrix_div_real; extern GPROC genie_matrix_div_real_ab; extern GPROC genie_matrix_echo; extern GPROC genie_matrix_eq; extern GPROC genie_matrix_inv; extern GPROC genie_matrix_lu; extern GPROC genie_matrix_lu_det; extern GPROC genie_matrix_lu_inv; extern GPROC genie_matrix_lu_solve; extern GPROC genie_matrix_minus; extern GPROC genie_matrix_minusab; extern GPROC genie_matrix_ne; extern GPROC genie_matrix_plusab; extern GPROC genie_matrix_qr; extern GPROC genie_matrix_qr_ls_solve; extern GPROC genie_matrix_qr_solve; extern GPROC genie_matrix_scale_real; extern GPROC genie_matrix_scale_real_ab; extern GPROC genie_matrix_sub; extern GPROC genie_matrix_svd; extern GPROC genie_matrix_svd_solve; extern GPROC genie_matrix_times_matrix; extern GPROC genie_matrix_times_vector; extern GPROC genie_matrix_trace; extern GPROC genie_matrix_transpose; extern GPROC genie_prime_factors; extern GPROC genie_real_scale_matrix; extern GPROC genie_real_scale_vector; extern GPROC genie_vector_add; extern GPROC genie_vector_complex_add; extern GPROC genie_vector_complex_div_complex; extern GPROC genie_vector_complex_div_complex_ab; extern GPROC genie_vector_complex_dot; extern GPROC genie_vector_complex_dyad; extern GPROC genie_vector_complex_echo; extern GPROC genie_vector_complex_eq; extern GPROC genie_vector_complex_minus; extern GPROC genie_vector_complex_minusab; extern GPROC genie_vector_complex_ne; extern GPROC genie_vector_complex_norm; extern GPROC genie_vector_complex_plusab; extern GPROC genie_vector_complex_scale_complex; extern GPROC genie_vector_complex_scale_complex_ab; extern GPROC genie_vector_complex_sub; extern GPROC genie_vector_complex_times_matrix; extern GPROC genie_vector_div_real; extern GPROC genie_vector_div_real_ab; extern GPROC genie_vector_dot; extern GPROC genie_vector_dyad; extern GPROC genie_vector_echo; extern GPROC genie_vector_eq; extern GPROC genie_vector_minus; extern GPROC genie_vector_minusab; extern GPROC genie_vector_ne; extern GPROC genie_vector_norm; extern GPROC genie_vector_plusab; extern GPROC genie_vector_scale_real; extern GPROC genie_vector_scale_real_ab; extern GPROC genie_vector_sub; extern GPROC genie_vector_times_matrix; #endif #if defined HAVE_CURSES extern GPROC genie_curses_clear; extern GPROC genie_curses_del_char; extern GPROC genie_curses_green; extern GPROC genie_curses_cyan; extern GPROC genie_curses_white; extern GPROC genie_curses_red; extern GPROC genie_curses_yellow; extern GPROC genie_curses_magenta; extern GPROC genie_curses_blue; extern GPROC genie_curses_green_inverse; extern GPROC genie_curses_cyan_inverse; extern GPROC genie_curses_white_inverse; extern GPROC genie_curses_red_inverse; extern GPROC genie_curses_yellow_inverse; extern GPROC genie_curses_magenta_inverse; extern GPROC genie_curses_blue_inverse; extern GPROC genie_curses_columns; extern GPROC genie_curses_end; extern GPROC genie_curses_getchar; extern GPROC genie_curses_lines; extern GPROC genie_curses_move; extern GPROC genie_curses_putchar; extern GPROC genie_curses_refresh; extern GPROC genie_curses_start; #endif #if defined HAVE_POSTGRESQL extern GPROC genie_pq_backendpid; extern GPROC genie_pq_cmdstatus; extern GPROC genie_pq_cmdtuples; extern GPROC genie_pq_connectdb; extern GPROC genie_pq_db; extern GPROC genie_pq_errormessage; extern GPROC genie_pq_exec; extern GPROC genie_pq_fformat; extern GPROC genie_pq_finish; extern GPROC genie_pq_fname; extern GPROC genie_pq_fnumber; extern GPROC genie_pq_getisnull; extern GPROC genie_pq_getvalue; extern GPROC genie_pq_host; extern GPROC genie_pq_nfields; extern GPROC genie_pq_ntuples; extern GPROC genie_pq_options; extern GPROC genie_pq_parameterstatus; extern GPROC genie_pq_pass; extern GPROC genie_pq_port; extern GPROC genie_pq_protocolversion; extern GPROC genie_pq_reset; extern GPROC genie_pq_resulterrormessage; extern GPROC genie_pq_serverversion; extern GPROC genie_pq_socket; extern GPROC genie_pq_tty; extern GPROC genie_pq_user; #endif /********************/ /* Diagnostic texts */ /********************/ #define ERROR_ACCESSING_NIL "attempt to access N" #define ERROR_ALIGNMENT "alignment error" #define ERROR_ARGUMENT_NUMBER "incorrect number of arguments for M" #define ERROR_CANNOT_OPEN_NAME "cannot open Z" #define ERROR_CANNOT_WIDEN "cannot widen M to M" #define ERROR_CANNOT_WRITE_LISTING "cannot write listing file" #define ERROR_CHANNEL_DOES_NOT_ALLOW "channel does not allow Y" #define ERROR_CLAUSE_WITHOUT_VALUE "clause does not yield a value" #define ERROR_CLOSING_DEVICE "error while closing device" #define ERROR_CLOSING_FILE "error while closing file" #define ERROR_CODE "clause should be compiled" #define ERROR_COMMA_MUST_SEPARATE "A and A must be separated by a comma-symbol" #define ERROR_COMPONENT_NUMBER "M must have at least two components" #define ERROR_COMPONENT_RELATED "M has firmly related components" #define ERROR_CURSES "error in curses operation" #define ERROR_CURSES_OFF_SCREEN "curses operation moves cursor off the screen" #define ERROR_DEVICE_ALREADY_SET "device parameters already set" #define ERROR_DEVICE_CANNOT_ALLOCATE "cannot allocate device parameters" #define ERROR_DEVICE_CANNOT_OPEN "cannot open device" #define ERROR_DEVICE_NOT_OPEN "device is not open" #define ERROR_DEVICE_NOT_SET "device parameters not set" #define ERROR_DIFFERENT_BOUNDS "rows have different bounds" #define ERROR_DIVISION_BY_ZERO "attempt at M division by zero" #define ERROR_DYADIC_PRIORITY "dyadic S has no priority declaration" #define ERROR_EMPTY_ARGUMENT "empty argument" #define ERROR_EMPTY_VALUE "attempt to use an uninitialised M value" #define ERROR_EMPTY_VALUE_FROM (ERROR_EMPTY_VALUE) #define ERROR_EXPECTED "Y expected" #define ERROR_EXPECTED_NEAR "B expected in A, near Z L" #define ERROR_EXPONENT_DIGIT "invalid exponent digit" #define ERROR_EXPONENT_INVALID "invalid M exponent" #define ERROR_FALSE_ASSERTION "false assertion" #define ERROR_FFT "fourier transform error; U; U" #define ERROR_FILE_ACCESS "file access error" #define ERROR_FILE_ALREADY_OPEN "file is already open" #define ERROR_FILE_CANNOT_OPEN_FOR "cannot open Z for Y" #define ERROR_FILE_CANT_RESET "cannot reset file" #define ERROR_FILE_CANT_SET "cannot set file" #define ERROR_FILE_CLOSE "error while closing file" #define ERROR_FILE_ENDED "end of file reached" #define ERROR_FILE_INCLUDE_CTRL "control characters in include file" #define ERROR_FILE_LOCK "error while locking file" #define ERROR_FILE_NOT_OPEN "file is not open" #define ERROR_FILE_NO_TEMP "cannot create unique temporary file name" #define ERROR_FILE_READ "error while reading file" #define ERROR_FILE_RESET "error while resetting file" #define ERROR_FILE_SCRATCH "error while scratching file" #define ERROR_FILE_SET "error while setting file" #define ERROR_FILE_SOURCE_CTRL "control characters in source file" #define ERROR_FILE_TRANSPUT "error transputting M value" #define ERROR_FILE_TRANSPUT_SIGN "error transputting sign in M value" #define ERROR_FILE_WRONG_MOOD "file is in Y mood" #define ERROR_FORMAT_CANNOT_TRANSPUT "cannot transput M value with A" #define ERROR_FORMAT_EXHAUSTED "patterns exhausted in format" #define ERROR_FORMAT_INTS_REQUIRED "1 .. 3 M arguments required" #define ERROR_FORMAT_INVALID_REPLICATOR "negative replicator" #define ERROR_FORMAT_PICTURES "number of pictures does not match number of arguments" #define ERROR_FORMAT_PICTURE_NUMBER "incorrect number of pictures for A" #define ERROR_FORMAT_UNDEFINED "cannot use undefined format" #define ERROR_INCORRECT_FILENAME "incorrect filename" #define ERROR_INDEXER_NUMBER "incorrect number of indexers for M" #define ERROR_INDEX_OUT_OF_BOUNDS "index out of bounds" #define ERROR_INTERNAL_CONSISTENCY "internal consistency check failure" #define ERROR_INVALID_ARGUMENT "invalid M argument" #define ERROR_INVALID_DIMENSION "invalid dimension D" #define ERROR_INVALID_OPERAND "M construct is an invalid operand" #define ERROR_INVALID_OPERATOR_TAG "invalid operator tag" #define ERROR_INVALID_PARAMETER "invalid parameter (U Z)" #define ERROR_INVALID_PRIORITY "invalid priority declaration" #define ERROR_INVALID_RADIX "invalid radix D" #define ERROR_INVALID_SEQUENCE "U is not a valid A" #define ERROR_INVALID_SIZE "object of invalid size" #define ERROR_IN_DENOTATION "error in M denotation" #define ERROR_KEYWORD "check for missing or unmatched keyword in clause starting at S" #define ERROR_LABELED_UNIT_MUST_FOLLOW "S must be followed by a labeled unit" #define ERROR_LABEL_BEFORE_DECLARATION "declaration cannot follow a labeled unit" #define ERROR_LABEL_IN_PAR_CLAUSE "target label is in another parallel unit" #define ERROR_LAPLACE "laplace transform error; U; U" #define ERROR_LONG_STRING "string exceeds end of line" #define ERROR_MATH "M math error" #define ERROR_MATH_EXCEPTION "math exception E" #define ERROR_MODE_SPECIFICATION "M construct must yield a routine, row or structured value" #define ERROR_MP_OUT_OF_BOUNDS "multiprecision value out of bounds" #define ERROR_MULTIPLE_FIELD "multiple declaration of field S" #define ERROR_MULTIPLE_TAG "multiple declaration of tag S" #define ERROR_NOT_WELL_FORMED "M does not specify a well formed mode" #define ERROR_NO_COMPONENT "M is neither component nor subset of M" #define ERROR_NO_DYADIC "dyadic operator O S O has not been declared" #define ERROR_NO_FIELD "M has no field Z" #define ERROR_NO_FLEX_ARGUMENT "M value from A cannot be flexible" #define ERROR_NO_MATRIX "M A does not yield a two-dimensional row" #define ERROR_NO_MONADIC "monadic operator S O has not been declared" #define ERROR_NO_NAME "M A does not yield a name" #define ERROR_NO_NAME_REQUIRED "context does not require a name" #define ERROR_NO_PARALLEL_CLAUSE "interpreter was compiled without support for the parallel-clause" #define ERROR_NO_PRIORITY "S has no priority declaration" #define ERROR_NO_ROW_OR_PROC "M A does not yield a row or procedure" #define ERROR_NO_SOURCE_FILE "no source file specified" #define ERROR_NO_SQUARE_MATRIX "M matrix is not square" #define ERROR_NO_STRUCT "M A does not yield a structured value" #define ERROR_NO_UNION "M is not a united mode" #define ERROR_NO_UNIQUE_MODE "construct has no unique mode" #define ERROR_NO_VECTOR "M A does not yield a one-dimensional row" #define ERROR_OPERAND_NUMBER "incorrect number of operands for S" #define ERROR_OPERATOR_INVALID "monadic S cannot start with a character from Z" #define ERROR_OPERATOR_INVALID_END "probably missing symbol near invalid operator S" #define ERROR_OPERATOR_RELATED "M Z is firmly related to M Z" #define ERROR_OUT_OF_BOUNDS "M value out of bounds" #define ERROR_OUT_OF_CORE "insufficient memory" #define ERROR_PAGE_SIZE "error in page size" #define ERROR_PARALLEL_CANNOT_CREATE "cannot create thread" #define ERROR_PARALLEL_OUTSIDE "invalid outside a parallel clause" #define ERROR_PARALLEL_OVERFLOW "too many parallel units" #define ERROR_PARENTHESIS "incorrect parenthesis nesting; check for Y" #define ERROR_PARENTHESIS_2 "incorrect parenthesis nesting; encountered X L but expected X; check for Y" #define ERROR_PRAGMENT "error in pragment" #define ERROR_QUOTED_BOLD_TAG "error in quoted bold tag" #define ERROR_REDEFINED_KEYWORD "attempt to redefine keyword U in A" #define ERROR_REFINEMENT_APPLIED "refinement is applied more than once" #define ERROR_REFINEMENT_DEFINED "refinement already defined" #define ERROR_REFINEMENT_EMPTY "empty refinement at end of source" #define ERROR_REFINEMENT_INVALID "invalid refinement" #define ERROR_REFINEMENT_NOT_APPLIED "refinement is not applied" #define ERROR_SCOPE_DYNAMIC_0 "value is exported out of its scope" #define ERROR_SCOPE_DYNAMIC_1 "M value is exported out of its scope" #define ERROR_SCOPE_DYNAMIC_2 "M value from %s is exported out of its scope" #define ERROR_SHELL_SCRIPT "source is a shell script" #define ERROR_SOUND_INTERNAL "error while processing M value (Y)" #define ERROR_SOUND_INTERNAL_STRING "error while processing M value (Y \"Y\")" #define ERROR_SOURCE_FILE_OPEN "error while opening source file" #define ERROR_STACK_OVERFLOW "stack overflow" #define ERROR_SUBSET_RELATED "M has firmly related subset M" #define ERROR_SYNTAX "detected in A" #define ERROR_SYNTAX_EXPECTED "expected A" #define ERROR_SYNTAX_MIXED_DECLARATION "possibly mixed identity and variable declaration" #define ERROR_SYNTAX_STRANGE_SEPARATOR "possibly a missing or erroneous separator nearby" #define ERROR_SYNTAX_STRANGE_TOKENS "possibly a missing or erroneous symbol nearby" #define ERROR_TIME_LIMIT_EXCEEDED "time limit exceeded" #define ERROR_TOO_MANY_ARGUMENTS "too many arguments" #define ERROR_TOO_MANY_OPEN_FILES "too many open files" #define ERROR_TORRIX "linear algebra error; U; U" #define ERROR_TRANSIENT_NAME "attempt at storing a transient name" #define ERROR_UNBALANCED_KEYWORD "missing or unbalanced keyword in A, near Z L" #define ERROR_UNDECLARED_TAG "tag S has not been declared properly" #define ERROR_UNDECLARED_TAG_2 "tag Z has not been declared properly" #define ERROR_UNDEFINED_TRANSPUT "transput of M value by this procedure is not defined" #define ERROR_UNIMPLEMENTED "S is either not implemented or not compiled" #define ERROR_UNSPECIFIED "unspecified error" #define ERROR_UNTERMINATED_COMMENT "unterminated comment" #define ERROR_UNTERMINATED_PRAGMAT "unterminated pragmat" #define ERROR_UNTERMINATED_PRAGMENT "unterminated pragment" #define ERROR_UNTERMINATED_STRING "unterminated string" #define ERROR_UNWORTHY_CHARACTER "unworthy character" #define ERROR_VACUO "this vacuum cannot have row elements (use a U generator)" #define ERROR_VACUUM "this vacuum cannot have row elements (use a U M generator)" #define INFO_APPROPRIATE_DECLARER "appropriate declarer" #define INFO_MISSING_KEYWORDS "missing or unmatched keyword" #define WARNING_EXTENSION "@ is an extension" #define WARNING_HIDES "declaration hides a declaration of S with larger reach" #define WARNING_HIDES_PRELUDE "declaration hides prelude declaration of M S" #define WARNING_OPTIMISATION "optimisation has no effect on this platform" #define WARNING_OVERFLOW "M constant overflow" #define WARNING_SCOPE_STATIC "M A is a potential scope violation" #define WARNING_SKIPPED_SUPERFLUOUS "skipped superfluous A" #define WARNING_TAG_NOT_PORTABLE "tag S is not portable" #define WARNING_TAG_UNUSED "tag S is not used" #define WARNING_TRAILING "ignoring trailing character H in A" #define WARNING_UNDERFLOW "M constant underflow" #define WARNING_UNINITIALISED "identifier S might be used before being initialised" #define WARNING_UNINTENDED "possibly unintended M A in M A" #define WARNING_VOIDED "value of M @ will be voided" #define WARNING_WIDENING_NOT_PORTABLE "implicit widening is not portable" #endif /* ! defined A68G_ALGOL68G_H */ extern A68_PROCEDURE on_gc_event; algol68g-2.8/source/mp.c0000644000175000001440000032370712161136314012015 00000000000000/** @file mp.c @author J. Marcel van der Veer. @brief Multiprecision arithmetic library. @section Copyright This file is part of Algol68G - an Algol 68 compiler-interpreter. Copyright 2001-2013 J. Marcel van der Veer . @section License 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 . @section Description This is a multiprecision arithmetic library for Algol68G. The question that is often raised is what applications justify multiprecision calculations. A number of applications, some of them practical, have surfaced over the years. Most common application of multiprecision calculations are numerically unstable calculations, that require many significant digits to arrive at a reliable result. Multiprecision calculations are used in "experimental mathematics". An increasingly important application of computers is in doing experiments on mathematical systems, when such system is not easily, or not at all, tractable by analysis. One important area of applications is in pure mathematics. Although numerical calculations cannot substitute a formal proof, calculations can be used to explore conjectures and reject those that are not sound, before a lengthy attempt at such proof is undertaken. Multiprecision calculations are especially useful in the study of mathematical constants. One of the oldest applications of multiprecision computation is to explore whether the expansions of classical constants such as "pi", "e" or "sqrt(2)" are random in some sense. For example, digits of "pi" have not shown statistical anomalies even now that billions of digits have been calculated. A practical application of multiprecision computation is the emerging field of public-key cryptography, that has spawned much research into advanced algorithms for factoring large integers. An indirect application of multiprecision computation is integrity testing. A unique feature of multiprecision calculations is that they are unforgiving of hardware, program or compiler error. Even a single computational error will almost certainly result in a completely incorrect outcome after a possibly correct start. The routines in this library follow algorithms as described in the literature, notably D.M. Smith, "Efficient Multiple-Precision Evaluation of Elementary Functions" Mathematics of Computation 52 (1989) 131-134 D.M. Smith, "A Multiple-Precision Division Algorithm" Mathematics of Computation 66 (1996) 157-163 There are multiprecision libraries (freely) available, but this one is particularly designed to work with Algol68G. It implements following modes: LONG INT, LONG REAL, LONG COMPLEX, LONG BITS LONG LONG INT, LONG LONG REAL, LONG LONG COMPLEX, LONG LONG BITS Currently, LONG modes have a fixed precision, and LONG LONG modes have user-definable precision. Precisions span about 30 decimal digits for LONG modes up to (default) about 60 decimal digits for LONG LONG modes, a range that is said to be adequate for most multiprecision applications. Although the maximum length of a mp number is unbound, this implementation is not particularly designed for more than about a thousand digits. It will work at higher precisions, but with a performance penalty with respect to state of the art implementations that may for instance use convolution for multiplication. This library takes a sloppy approach towards LONG INT and LONG BITS which are implemented as LONG REAL and truncated where appropriate. This keeps the code short at the penalty of some performance loss. As is common practice, mp numbers are represented by a row of digits in a large base. Layout of a mp number "z" is: MP_T *z; MP_STATUS (z) Status word MP_EXPONENT (z) Exponent with base MP_RADIX MP_DIGIT (z, 1 .. N) Digits 1 .. N Note that this library assumes IEEE 754 compatible implementation of type "double". It also assumes 32 (or 64) bit type "int". Most "vintage" multiple precision libraries stored numbers as [] int. However, since division and multiplication are O (N ** 2) operations, it is advantageous to keep the base as high as possible. Modern computers handle doubles at similar or better speed as integers, therefore this library opts for storing numbers as [] double, trading space for speed. This may change when 64 bit integers become commonplace. Set a base such that "base ** 2" can be exactly represented by "double". To facilitate transput, we require a base that is a power of 10. If we choose the base right then in multiplication and division we do not need to normalise intermediate results at each step since a number of additions can be made before overflow occurs. That is why we specify "MAX_REPR_INT". Mind that the precision of a mp number is at worst just (LONG_MP_DIGITS - 1) * LOG_MP_BASE + 1, since the most significant mp digit is also in range [0 .. MP_RADIX>. Do not specify less than 2 digits. Since this software is distributed without any warranty, it is your responsibility to validate the behaviour of the routines and their accuracy using the source code provided. See the GNU General Public License for details. **/ #if defined HAVE_CONFIG_H #include "a68g-config.h" #endif #include "a68g.h" /* If DOUBLE_PRECISION is defined functions are evaluated in double precision */ #undef DOUBLE_PRECISION /* Internal mp constants */ static MP_T *ref_mp_pi = NO_MP; static int mp_pi_size = -1; static MP_T *ref_mp_ln_scale = NO_MP; static int mp_ln_scale_size = -1; static MP_T *ref_mp_ln_10 = NO_MP; static int mp_ln_10_size = -1; int varying_mp_digits = 10; static int _j1_, _j2_; #define MINIMUM(x, y) (_j1_ = (x), _j2_ = (y), _j1_ < _j2_ ? _j1_ : _j2_) /* GUARD_DIGITS: number of guard digits. In calculations using intermediate results we will use guard digits. We follow D.M. Smith in his recommendations for precisions greater than LONG. */ #if defined DOUBLE_PRECISION #define GUARD_DIGITS(digits) (digits) #else #define GUARD_DIGITS(digits) (((digits) == LONG_MP_DIGITS) ? 2 : (LOG_MP_BASE <= 5) ? 3 : 2) #endif #define FUN_DIGITS(n) ((n) + GUARD_DIGITS (n)) /** @brief Length in bytes of a long mp number. @return Length in bytes of a long mp number. **/ size_t size_long_mp (void) { return ((size_t) SIZE_MP (LONG_MP_DIGITS)); } /** @brief Length in digits of a long mp number. @return Length in digits of a long mp number. **/ int long_mp_digits (void) { return (LONG_MP_DIGITS); } /** @brief Length in bytes of a long long mp number. @return Length in bytes of a long long mp number. **/ size_t size_longlong_mp (void) { return ((size_t) (SIZE_MP (varying_mp_digits))); } /** @brief Length in digits of a long long mp number. @return Length in digits of a long long mp number. **/ int longlong_mp_digits (void) { return (varying_mp_digits); } /** @brief Length in bits of mode. @param m Mode. @return Length in bits of mode m. **/ int get_mp_bits_width (MOID_T * m) { if (m == MODE (LONG_BITS)) { return (MP_BITS_WIDTH (LONG_MP_DIGITS)); } else if (m == MODE (LONGLONG_BITS)) { return (MP_BITS_WIDTH (varying_mp_digits)); } return (0); } /** @brief Length in words of mode. @param m Mode. @return Length in words of mode m. **/ int get_mp_bits_words (MOID_T * m) { if (m == MODE (LONG_BITS)) { return (MP_BITS_WORDS (LONG_MP_DIGITS)); } else if (m == MODE (LONGLONG_BITS)) { return (MP_BITS_WORDS (varying_mp_digits)); } return (0); } /** @brief Whether z is a valid LONG INT. @param z Multiprecision number. @return See brief description. **/ BOOL_T check_long_int (MP_T * z) { return ((BOOL_T) ((MP_EXPONENT (z) >= (MP_T) 0) && (MP_EXPONENT (z) < (MP_T) LONG_MP_DIGITS))); } /** @brief Whether z is a valid LONG LONG INT. @param z Multiprecision number. @return See brief description. **/ BOOL_T check_longlong_int (MP_T * z) { return ((BOOL_T) ((MP_EXPONENT (z) >= (MP_T) 0) && (MP_EXPONENT (z) < (MP_T) varying_mp_digits))); } /** @brief Whether z is a valid representation for its mode. @param z Multiprecision number. @param m Mode. @return See brief description. **/ BOOL_T check_mp_int (MP_T * z, MOID_T * m) { if (m == MODE (LONG_INT) || m == MODE (LONG_BITS)) { return (check_long_int (z)); } else if (m == MODE (LONGLONG_INT) || m == MODE (LONGLONG_BITS)) { return (check_longlong_int (z)); } return (A68_FALSE); } /** @brief Convert precision to digits for long long number. @param n Precision to convert. @return See brief description. **/ int int_to_mp_digits (int n) { return (2 + (int) ceil ((double) n / (double) LOG_MP_BASE)); } /** @brief Set number of digits for long long numbers. @param n Number of digits. **/ void set_longlong_mp_digits (int n) { varying_mp_digits = n; } /** @brief Set "z" to short value x * MP_RADIX ** x_expo. @param z Multiprecision number to set. @param x Most significant mp digit. @param x_expo Multiprecision exponent. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *set_mp_short (MP_T * z, MP_T x, int x_expo, int digits) { MP_T *d = &MP_DIGIT ((z), 2); MP_STATUS (z) = (MP_T) INIT_MASK; MP_EXPONENT (z) = (MP_T) x_expo; MP_DIGIT (z, 1) = (MP_T) x; while (--digits) { *d++ = (MP_T) 0; } return (z); } /** @brief Test whether x = y. @param p Node in syntax tree. @param x Multiprecision number 1. @param y Multiprecision number 2. @param digits Precision in mp-digits. @return See brief description. **/ static BOOL_T same_mp (NODE_T * p, MP_T * x, MP_T * y, int digits) { int k; (void) p; if (MP_EXPONENT (x) == MP_EXPONENT (y)) { for (k = digits; k >= 1; k--) { if (MP_DIGIT (x, k) != MP_DIGIT (y, k)) { return (A68_FALSE); } } return (A68_TRUE); } else { return (A68_FALSE); } } /** @brief Align 10-base z in a MP_RADIX mantissa. @param z Multiprecision number. @param expo @param digits Precision in mp-digits. @return Result "z". **/ static MP_T *align_mp (MP_T * z, int *expo, int digits) { int i, shift; if (*expo >= 0) { shift = LOG_MP_BASE - *expo % LOG_MP_BASE - 1; *expo /= LOG_MP_BASE; } else { shift = (-*expo - 1) % LOG_MP_BASE; *expo = (*expo + 1) / LOG_MP_BASE; (*expo)--; } /* Now normalise "z" */ for (i = 1; i <= shift; i++) { int j, carry = 0; for (j = 1; j <= digits; j++) { int k = (int) MP_DIGIT (z, j) % 10; MP_DIGIT (z, j) = (MP_T) ((int) (MP_DIGIT (z, j) / 10) + carry * (MP_RADIX / 10)); carry = k; } } return (z); } /** @brief Transform string into multi-precision number. @param p Node in syntax tree. @param z Multiprecision number. @param s String to convert. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *string_to_mp (NODE_T * p, MP_T * z, char *s, int digits) { int i, j, sign, weight, sum, comma, power; int expo; BOOL_T ok = A68_TRUE; RESET_ERRNO; SET_MP_ZERO (z, digits); while (IS_SPACE (s[0])) { s++; } /* Get the sign */ sign = (s[0] == '-' ? -1 : 1); if (s[0] == '+' || s[0] == '-') { s++; } /* Scan mantissa digits and put them into "z" */ while (s[0] == '0') { s++; } i = 0; j = 1; sum = 0; comma = -1; power = 0; weight = MP_RADIX / 10; while (s[i] != NULL_CHAR && j <= digits && (IS_DIGIT (s[i]) || s[i] == POINT_CHAR)) { if (s[i] == POINT_CHAR) { comma = i; } else { int value = (int) s[i] - (int) '0'; sum += weight * value; weight /= 10; power++; if (weight < 1) { MP_DIGIT (z, j++) = (MP_T) sum; sum = 0; weight = MP_RADIX / 10; } } i++; } /* Store the last digits */ if (j <= digits) { MP_DIGIT (z, j++) = (MP_T) sum; } /* See if there is an exponent */ expo = 0; if (s[i] != NULL_CHAR && TO_UPPER (s[i]) == TO_UPPER (EXPONENT_CHAR)) { char *end; expo = (int) strtol (&(s[++i]), &end, 10); ok = (BOOL_T) (end[0] == NULL_CHAR); } else { ok = (BOOL_T) (s[i] == NULL_CHAR); } /* Calculate effective exponent */ expo += (comma >= 0 ? comma - 1 : power - 1); (void) align_mp (z, &expo, digits); MP_EXPONENT (z) = (MP_DIGIT (z, 1) == 0 ? 0 : (double) expo); MP_DIGIT (z, 1) *= sign; CHECK_MP_EXPONENT (p, z); if (errno == 0 && ok) { return (z); } else { return (NO_MP); } } /** @brief Convert integer to multi-precison number. @param p Node in syntax tree. @param z Multiprecision number. @param k Integer to convert. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *int_to_mp (NODE_T * p, MP_T * z, int k, int digits) { int n = 0, j, sign_k = SIGN (k); int k2 = k; if (k < 0) { k = -k; } while ((k2 /= MP_RADIX) != 0) { n++; } SET_MP_ZERO (z, digits); MP_EXPONENT (z) = (MP_T) n; for (j = 1 + n; j >= 1; j--) { MP_DIGIT (z, j) = (MP_T) (k % MP_RADIX); k /= MP_RADIX; } MP_DIGIT (z, 1) = sign_k * MP_DIGIT (z, 1); CHECK_MP_EXPONENT (p, z); return (z); } /** @brief Convert unsigned to multi-precison number. @param p Node in syntax tree. @param z Multiprecision number. @param k Unsigned to convert. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *unsigned_to_mp (NODE_T * p, MP_T * z, unsigned k, int digits) { int n = 0, j; unsigned k2 = k; while ((k2 /= MP_RADIX) != 0) { n++; } SET_MP_ZERO (z, digits); MP_EXPONENT (z) = (MP_T) n; for (j = 1 + n; j >= 1; j--) { MP_DIGIT (z, j) = (MP_T) (k % MP_RADIX); k /= MP_RADIX; } CHECK_MP_EXPONENT (p, z); return (z); } /** @brief Convert multi-precision number to integer. @param p Node in syntax tree. @param z Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ int mp_to_int (NODE_T * p, MP_T * z, int digits) { /* This routines looks a lot like "strtol". We do not use "mp_to_real" since int could be wider than 2 ** 52. */ int j, expo = (int) MP_EXPONENT (z); int sum = 0, weight = 1; BOOL_T negative; if (expo >= digits) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MOID (p)); exit_genie (p, A68_RUNTIME_ERROR); } negative = (BOOL_T) (MP_DIGIT (z, 1) < 0); if (negative) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } for (j = 1 + expo; j >= 1; j--) { int term; if ((int) MP_DIGIT (z, j) > A68_MAX_INT / weight) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); } term = (int) MP_DIGIT (z, j) * weight; if (sum > A68_MAX_INT - term) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MODE (INT)); exit_genie (p, A68_RUNTIME_ERROR); } sum += term; weight *= MP_RADIX; } return (negative ? -sum : sum); } /** @brief Convert multi-precision number to unsigned. @param p Node in syntax tree. @param z Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ unsigned mp_to_unsigned (NODE_T * p, MP_T * z, int digits) { /* This routines looks a lot like "strtol". We do not use "mp_to_real" since int could be wider than 2 ** 52. */ int j, expo = (int) MP_EXPONENT (z); unsigned sum = 0, weight = 1; if (expo >= digits) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MOID (p)); exit_genie (p, A68_RUNTIME_ERROR); } for (j = 1 + expo; j >= 1; j--) { unsigned term; if ((unsigned) MP_DIGIT (z, j) > A68_MAX_UNT / weight) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MODE (BITS)); exit_genie (p, A68_RUNTIME_ERROR); } term = (unsigned) MP_DIGIT (z, j) * weight; if (sum > A68_MAX_UNT - term) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, MODE (BITS)); exit_genie (p, A68_RUNTIME_ERROR); } sum += term; weight *= MP_RADIX; } return (sum); } /** @brief Convert double to multi-precison number. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *real_to_mp (NODE_T * p, MP_T * z, double x, int digits) { int j, k, sign_x, sum, weight; int expo; double a; MP_T *u; SET_MP_ZERO (z, digits); if (x == 0.0) { return (z); } /* Small integers can be done better by int_to_mp */ if (ABS (x) < MP_RADIX && (double) (int) x == x) { return (int_to_mp (p, z, (int) x, digits)); } sign_x = SIGN (x); /* Scale to [0, 0.1> */ a = x = ABS (x); expo = (int) log10 (a); a /= ten_up (expo); expo--; if (a >= 1) { a /= 10; expo++; } /* Transport digits of x to the mantissa of z */ k = 0; j = 1; sum = 0; weight = (MP_RADIX / 10); u = &MP_DIGIT (z, 1); while (j <= digits && k < DBL_DIG) { double y = floor (a * 10); int value = (int) y; a = a * 10 - y; sum += weight * value; weight /= 10; if (weight < 1) { (u++)[0] = (MP_T) sum; sum = 0; weight = (MP_RADIX / 10); } k++; } /* Store the last digits */ if (j <= digits) { u[0] = (MP_T) sum; } (void) align_mp (z, &expo, digits); MP_EXPONENT (z) = (MP_T) expo; MP_DIGIT (z, 1) *= sign_x; CHECK_MP_EXPONENT (p, z); return (z); } /** @brief Convert multi-precision number to double. @param p Node in syntax tree. @param z Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ double mp_to_real (NODE_T * p, MP_T * z, int digits) { /* This routine looks a lot like "strtod" */ (void) p; if (MP_EXPONENT (z) * (MP_T) LOG_MP_BASE <= (MP_T) DBL_MIN_10_EXP) { return (0); } else { int j; double sum = 0, weight; weight = ten_up ((int) (MP_EXPONENT (z) * LOG_MP_BASE)); for (j = 1; j <= digits && (j - 2) * LOG_MP_BASE <= DBL_DIG; j++) { sum += ABS (MP_DIGIT (z, j)) * weight; weight /= MP_RADIX; } CHECK_REAL_REPRESENTATION (p, sum); return (MP_DIGIT (z, 1) >= 0 ? sum : -sum); } } /** @brief Convert z to a row of unsigned in the stack. @param p Node in syntax tree. @param z Multiprecision number. @param m Mode of "z". @return Result "z". **/ unsigned *stack_mp_bits (NODE_T * p, MP_T * z, MOID_T * m) { int digits = DIGITS (m), words = get_mp_bits_words (m), k, lim; unsigned *row, mask; MP_T *u, *v, *w; row = (unsigned *) STACK_ADDRESS (stack_pointer); INCREMENT_STACK_POINTER (p, words * SIZE_AL (unsigned)); STACK_MP (u, p, digits); STACK_MP (v, p, digits); STACK_MP (w, p, digits); MOVE_MP (u, z, digits); /* Argument check */ if (MP_DIGIT (u, 1) < 0.0) { errno = EDOM; diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, m); exit_genie (p, A68_RUNTIME_ERROR); } /* Convert radix MP_BITS_RADIX number */ for (k = words - 1; k >= 0; k--) { MOVE_MP (w, u, digits); (void) over_mp_digit (p, u, u, (MP_T) MP_BITS_RADIX, digits); (void) mul_mp_digit (p, v, u, (MP_T) MP_BITS_RADIX, digits); (void) sub_mp (p, v, w, v, digits); row[k] = (unsigned) MP_DIGIT (v, 1); } /* Test on overflow: too many bits or not reduced to 0 */ mask = 0x1; lim = get_mp_bits_width (m) % MP_BITS_BITS; for (k = 1; k < lim; k++) { mask <<= 1; mask |= 0x1; } if ((row[0] & ~mask) != 0x0 || MP_DIGIT (u, 1) != 0.0) { errno = ERANGE; diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, m); exit_genie (p, A68_RUNTIME_ERROR); } /* Exit */ return (row); } /** @brief Whether LONG BITS value is in range. @param p Node in syntax tree. @param u Multiprecision number. @param m Mode of "u". **/ void check_long_bits_value (NODE_T * p, MP_T * u, MOID_T * m) { if (MP_EXPONENT (u) >= (MP_T) (DIGITS (m) - 1)) { ADDR_T pop_sp = stack_pointer; (void) stack_mp_bits (p, u, m); stack_pointer = pop_sp; } } /** @brief Convert row of unsigned to LONG BITS. @param p Node in syntax tree. @param u Multiprecision number. @param row @param m Mode of "u". @return Result "u". **/ MP_T *pack_mp_bits (NODE_T * p, MP_T * u, unsigned *row, MOID_T * m) { int digits = DIGITS (m), words = get_mp_bits_words (m), k, lim; ADDR_T pop_sp = stack_pointer; MP_T *v, *w; /* Discard excess bits */ unsigned mask = 0x1, musk = 0x0; STACK_MP (v, p, digits); STACK_MP (w, p, digits); lim = get_mp_bits_width (m) % MP_BITS_BITS; for (k = 1; k < lim; k++) { mask <<= 1; mask |= 0x1; } row[0] &= mask; for (k = 1; k < (BITS_WIDTH - MP_BITS_BITS); k++) { musk <<= 1; } for (k = 0; k < MP_BITS_BITS; k++) { musk <<= 1; musk |= 0x1; } /* Convert */ SET_MP_ZERO (u, digits); (void) set_mp_short (v, (MP_T) 1, 0, digits); for (k = words - 1; k >= 0; k--) { (void) mul_mp_digit (p, w, v, (MP_T) (musk & row[k]), digits); (void) add_mp (p, u, u, w, digits); if (k != 0) { (void) mul_mp_digit (p, v, v, (MP_T) MP_BITS_RADIX, digits); } } MP_STATUS (u) = (MP_T) INIT_MASK; stack_pointer = pop_sp; return (u); } /** @brief Normalise positive intermediate, fast. @param w Argument. @param k Last digit to normalise. @param digits Precision in mp-digits. **/ static void norm_mp_light (MP_T * w, int k, int digits) { /* Bring every digit back to [0 .. MP_RADIX> */ int j; MP_T *z; for (j = digits, z = &MP_DIGIT (w, digits); j >= k; j--, z--) { if (z[0] >= MP_RADIX) { z[0] -= (MP_T) MP_RADIX; z[-1] += 1; } else if (z[0] < 0) { z[0] += (MP_T) MP_RADIX; z[-1] -= 1; } } } /** @brief Normalise positive intermediate. @param w Argument. @param k Last digit to normalise. @param digits Precision in mp-digits. **/ static void norm_mp (MP_T * w, int k, int digits) { /* Bring every digit back to [0 .. MP_RADIX> */ int j; MP_T *z; for (j = digits, z = &MP_DIGIT (w, digits); j >= k; j--, z--) { if (z[0] >= (MP_T) MP_RADIX) { MP_T carry = (MP_T) ((int) (z[0] / (MP_T) MP_RADIX)); z[0] -= carry * (MP_T) MP_RADIX; z[-1] += carry; } else if (z[0] < (MP_T) 0) { MP_T carry = (MP_T) 1 + (MP_T) ((int) ((-z[0] - 1) / (MP_T) MP_RADIX)); z[0] += carry * (MP_T) MP_RADIX; z[-1] -= carry; } } } /** @brief Round multi-precision number. @param z Result. @param w Argument, must be positive. @param digits Precision in mp-digits. **/ static void round_internal_mp (MP_T * z, MP_T * w, int digits) { /* Assume that w has precision of at least 2 + digits */ int last = (MP_DIGIT (w, 1) == 0 ? 2 + digits : 1 + digits); if (MP_DIGIT (w, last) >= MP_RADIX / 2) { MP_DIGIT (w, last - 1) += 1; } if (MP_DIGIT (w, last - 1) >= MP_RADIX) { norm_mp (w, 2, last); } if (MP_DIGIT (w, 1) == 0) { MOVE_DIGITS (&MP_DIGIT (z, 1), &MP_DIGIT (w, 2), digits); MP_EXPONENT (z) = MP_EXPONENT (w) - 1; } else { /* Normally z != w, so no test on this */ MOVE_DIGITS (&MP_EXPONENT (z), &MP_EXPONENT (w), (1 + digits)); } /* Zero is zero is zero */ if (MP_DIGIT (z, 1) == 0) { MP_EXPONENT (z) = (MP_T) 0; } } /** @brief Truncate at decimal point. @param p Node in syntax tree. @param z Result. @param x Argument. @param digits Precision in mp-digits. **/ void trunc_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { if (MP_EXPONENT (x) < 0) { SET_MP_ZERO (z, digits); } else if (MP_EXPONENT (x) >= (MP_T) digits) { errno = EDOM; diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_OUT_OF_BOUNDS, (IS (MOID (p), PROC_SYMBOL) ? SUB_MOID (p) : MOID (p))); exit_genie (p, A68_RUNTIME_ERROR); } else { int k; MOVE_MP (z, x, digits); for (k = (int) (MP_EXPONENT (x) + 2); k <= digits; k++) { MP_DIGIT (z, k) = (MP_T) 0; } } } /** @brief Shorten and round. @param p Node in syntax tree. @param z Result. @param digits Precision in mp-digits. @param x Multiprecision number. @param digits_x Precision of "x". @return Result "z". **/ MP_T *shorten_mp (NODE_T * p, MP_T * z, int digits, MP_T * x, int digits_x) { if (digits >= digits_x) { errno = EDOM; return (NO_MP); } else { /* Reserve extra digits for proper rounding */ int pop_sp = stack_pointer, digits_h = digits + 2; MP_T *w; BOOL_T negative = (BOOL_T) (MP_DIGIT (x, 1) < 0); STACK_MP (w, p, digits_h); if (negative) { MP_DIGIT (x, 1) = -MP_DIGIT (x, 1); } MP_STATUS (w) = (MP_T) 0; MP_EXPONENT (w) = MP_EXPONENT (x) + 1; MP_DIGIT (w, 1) = (MP_T) 0; MOVE_DIGITS (&MP_DIGIT (w, 2), &MP_DIGIT (x, 1), digits + 1); round_internal_mp (z, w, digits); if (negative) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } stack_pointer = pop_sp; return (z); } } /** @brief Lengthen x and assign to z. @param p Node in syntax tree. @param z Multiprecision number. @param digits_z Precision in mp-digits of "z". @param x Multiprecision number. @param digits_x Precision in mp-digits of "x". @return Result "z". **/ MP_T *lengthen_mp (NODE_T * p, MP_T * z, int digits_z, MP_T * x, int digits_x) { int j; (void) p; if (digits_z > digits_x) { if (z != x) { MOVE_DIGITS (&MP_DIGIT (z, 1), &MP_DIGIT (x, 1), digits_x); MP_EXPONENT (z) = MP_EXPONENT (x); MP_STATUS (z) = MP_STATUS (x); } for (j = 1 + digits_x; j <= digits_z; j++) { MP_DIGIT (z, j) = (MP_T) 0; } } return (z); } /** @brief Set "z" to the sum of positive "x" and positive "y". @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *add_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); MP_STATUS (z) = (MP_T) INIT_MASK; /* Trivial cases */ if (MP_DIGIT (x, 1) == (MP_T) 0) { MOVE_MP (z, y, digits); return (z); } else if (MP_DIGIT (y, 1) == 0) { MOVE_MP (z, x, digits); return (z); } /* We want positive arguments */ MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); if (x_1 >= 0 && y_1 < 0) { (void) sub_mp (p, z, x, y, digits); } else if (x_1 < 0 && y_1 >= 0) { (void) sub_mp (p, z, y, x, digits); } else if (x_1 < 0 && y_1 < 0) { (void) add_mp (p, z, x, y, digits); MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } else { /* Add */ int j, digits_h = 2 + digits; STACK_MP (w, p, digits_h); MP_DIGIT (w, 1) = (MP_T) 0; if (MP_EXPONENT (x) == MP_EXPONENT (y)) { MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); for (j = 1; j <= digits; j++) { MP_DIGIT (w, j + 1) = MP_DIGIT (x, j) + MP_DIGIT (y, j); } MP_DIGIT (w, digits_h) = (MP_T) 0; } else if (MP_EXPONENT (x) > MP_EXPONENT (y)) { int shl_y = (int) MP_EXPONENT (x) - (int) MP_EXPONENT (y); MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); for (j = 1; j < digits_h; j++) { int i_y = j - (int) shl_y; MP_T x_j = (j > digits ? 0 : MP_DIGIT (x, j)); MP_T y_j = (i_y <= 0 || i_y > digits ? 0 : MP_DIGIT (y, i_y)); MP_DIGIT (w, j + 1) = x_j + y_j; } } else { int shl_x = (int) MP_EXPONENT (y) - (int) MP_EXPONENT (x); MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (y); for (j = 1; j < digits_h; j++) { int i_x = j - (int) shl_x; MP_T x_j = (i_x <= 0 || i_x > digits ? 0 : MP_DIGIT (x, i_x)); MP_T y_j = (j > digits ? 0 : MP_DIGIT (y, j)); MP_DIGIT (w, j + 1) = x_j + y_j; } } norm_mp_light (w, 2, digits_h); round_internal_mp (z, w, digits); CHECK_MP_EXPONENT (p, z); } /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (y, 1) = y_1; MP_DIGIT (z, 1) = z_1; /* In case z IS x OR z IS y */ return (z); } /** @brief Set "z" to the difference of positive "x" and positive "y". @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *sub_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; int fnz, k; MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); BOOL_T negative = A68_FALSE; MP_STATUS (z) = (MP_T) INIT_MASK; /* Trivial cases */ if (MP_DIGIT (x, 1) == (MP_T) 0) { MOVE_MP (z, y, digits); MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); return (z); } else if (MP_DIGIT (y, 1) == (MP_T) 0) { MOVE_MP (z, x, digits); return (z); } MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); /* We want positive arguments */ if (x_1 >= 0 && y_1 < 0) { (void) add_mp (p, z, x, y, digits); } else if (x_1 < 0 && y_1 >= 0) { (void) add_mp (p, z, y, x, digits); MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } else if (x_1 < 0 && y_1 < 0) { (void) sub_mp (p, z, y, x, digits); } else { /* Subtract */ int j, digits_h = 2 + digits; STACK_MP (w, p, digits_h); MP_DIGIT (w, 1) = (MP_T) 0; if (MP_EXPONENT (x) == MP_EXPONENT (y)) { MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); for (j = 1; j <= digits; j++) { MP_DIGIT (w, j + 1) = MP_DIGIT (x, j) - MP_DIGIT (y, j); } MP_DIGIT (w, digits_h) = (MP_T) 0; } else if (MP_EXPONENT (x) > MP_EXPONENT (y)) { int shl_y = (int) MP_EXPONENT (x) - (int) MP_EXPONENT (y); MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (x); for (j = 1; j < digits_h; j++) { int i_y = j - (int) shl_y; MP_T x_j = (j > digits ? 0 : MP_DIGIT (x, j)); MP_T y_j = (i_y <= 0 || i_y > digits ? 0 : MP_DIGIT (y, i_y)); MP_DIGIT (w, j + 1) = x_j - y_j; } } else { int shl_x = (int) MP_EXPONENT (y) - (int) MP_EXPONENT (x); MP_EXPONENT (w) = (MP_T) 1 + MP_EXPONENT (y); for (j = 1; j < digits_h; j++) { int i_x = j - (int) shl_x; MP_T x_j = (i_x <= 0 || i_x > digits ? 0 : MP_DIGIT (x, i_x)); MP_T y_j = (j > digits ? 0 : MP_DIGIT (y, j)); MP_DIGIT (w, j + 1) = x_j - y_j; } } /* Correct if we subtract large from small */ if (MP_DIGIT (w, 2) <= 0) { fnz = -1; for (j = 2; j <= digits_h && fnz < 0; j++) { if (MP_DIGIT (w, j) != 0) { fnz = j; } } negative = (BOOL_T) (MP_DIGIT (w, fnz) < 0); if (negative) { for (j = fnz; j <= digits_h; j++) { MP_DIGIT (w, j) = -MP_DIGIT (w, j); } } } /* Normalise */ norm_mp_light (w, 2, digits_h); fnz = -1; for (j = 1; j <= digits_h && fnz < 0; j++) { if (MP_DIGIT (w, j) != 0) { fnz = j; } } if (fnz > 1) { int j2 = fnz - 1; for (k = 1; k <= digits_h - j2; k++) { MP_DIGIT (w, k) = MP_DIGIT (w, k + j2); MP_DIGIT (w, k + j2) = (MP_T) 0; } MP_EXPONENT (w) -= j2; } /* Round */ round_internal_mp (z, w, digits); if (negative) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } CHECK_MP_EXPONENT (p, z); } /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (y, 1) = y_1; MP_DIGIT (z, 1) = z_1; /* In case z IS x OR z IS y */ return (z); } /** @brief Set "z" to the product of "x" and "y". @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *mul_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); int i, oflow, digits_h = 2 + digits; ADDR_T pop_sp = stack_pointer; MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); MP_STATUS (z) = (MP_T) INIT_MASK; if (x_1 == 0 || y_1 == 0) { stack_pointer = pop_sp; MP_DIGIT (x, 1) = x_1; MP_DIGIT (y, 1) = y_1; SET_MP_ZERO (z, digits); return (z); } /* Calculate z = x * y */ STACK_MP (w, p, digits_h); SET_MP_ZERO (w, digits_h); MP_EXPONENT (w) = MP_EXPONENT (x) + MP_EXPONENT (y) + 1; oflow = (int) (floor) ((double) MAX_REPR_INT / (2 * (double) MP_RADIX * (double) MP_RADIX)) - 1; ABEND (oflow <= 1, "inadequate MP_RADIX", NO_TEXT); if (digits < oflow) { for (i = digits; i >= 1; i--) { MP_T yi = MP_DIGIT (y, i); if (yi != 0) { int k = digits_h - i; int j = (k > digits ? digits : k); MP_T *u = &MP_DIGIT (w, i + j); MP_T *v = &MP_DIGIT (x, j); while (j-- >= 1) { (u--)[0] += yi * (v--)[0]; } } } } else { for (i = digits; i >= 1; i--) { MP_T yi = MP_DIGIT (y, i); if (yi != 0) { int k = digits_h - i; int j = (k > digits ? digits : k); MP_T *u = &MP_DIGIT (w, i + j); MP_T *v = &MP_DIGIT (x, j); if ((digits - i + 1) % oflow == 0) { norm_mp (w, 2, digits_h); } while (j-- >= 1) { (u--)[0] += yi * (v--)[0]; } } } } norm_mp (w, 2, digits_h); round_internal_mp (z, w, digits); /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (y, 1) = y_1; MP_DIGIT (z, 1) = ((x_1 * y_1) >= 0 ? z_1 : -z_1); CHECK_MP_EXPONENT (p, z); return (z); } /** @brief Set "z" to the quotient of "x" and "y". @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *div_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { /* This routine is an implementation of D. M. Smith, "A Multiple-Precision Division Algorithm" Mathematics of Computation 66 (1996) 157-163. This algorithm is O(N ** 2) but runs faster than straightforward methods by skipping most of the intermediate normalisation and recovering from wrong guesses without separate correction steps. */ double xd; MP_T *t, *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = MP_DIGIT (y, 1); int k, oflow, digits_w = 4 + digits; ADDR_T pop_sp = stack_pointer; if (y_1 == 0) { errno = ERANGE; return (NO_MP); } /* Determine normalisation interval assuming that q < 2b in each step */ oflow = (int) (floor) ((double) MAX_REPR_INT / (3 * (double) MP_RADIX * (double) MP_RADIX)) - 1; ABEND (oflow <= 1, "inadequate MP_RADIX", NO_TEXT); MP_DIGIT (x, 1) = ABS (x_1); MP_DIGIT (y, 1) = ABS (y_1); MP_STATUS (z) = (MP_T) INIT_MASK; /* `w' will be the working nominator in which the quotient develops */ STACK_MP (w, p, digits_w); MP_EXPONENT (w) = MP_EXPONENT (x) - MP_EXPONENT (y); MP_DIGIT (w, 1) = (MP_T) 0; MOVE_DIGITS (&MP_DIGIT (w, 2), &MP_DIGIT (x, 1), digits); MP_DIGIT (w, digits + 2) = (MP_T) 0; MP_DIGIT (w, digits + 3) = (MP_T) 0; MP_DIGIT (w, digits + 4) = (MP_T) 0; /* Estimate the denominator. Take four terms to also suit small MP_RADIX */ xd = (MP_DIGIT (y, 1) * MP_RADIX + MP_DIGIT (y, 2)) * MP_RADIX + MP_DIGIT (y, 3) + MP_DIGIT (y, 4) / MP_RADIX; t = &MP_DIGIT (w, 2); if (digits + 2 < oflow) { for (k = 1; k <= digits + 2; k++, t++) { double xn, q; int first = k + 2; /* Estimate quotient digit */ xn = ((t[-1] * MP_RADIX + t[0]) * MP_RADIX + t[1]) * MP_RADIX + (digits_w >= (first + 2) ? t[2] : 0); q = (double) ((int) (xn / xd)); if (q != 0) { /* Correct the nominator */ int j, len = k + digits + 1; int lim = (len < digits_w ? len : digits_w); MP_T *u = t, *v = &MP_DIGIT (y, 1); for (j = first; j <= lim; j++) { (u++)[0] -= q * (v++)[0]; } } t[0] += (t[-1] * MP_RADIX); t[-1] = q; } } else { for (k = 1; k <= digits + 2; k++, t++) { double xn, q; int first = k + 2; if (k % oflow == 0) { norm_mp (w, first, digits_w); } /* Estimate quotient digit */ xn = ((t[-1] * MP_RADIX + t[0]) * MP_RADIX + t[1]) * MP_RADIX + (digits_w >= (first + 2) ? t[2] : 0); q = (double) ((int) (xn / xd)); if (q != 0) { /* Correct the nominator */ int j, len = k + digits + 1; int lim = (len < digits_w ? len : digits_w); MP_T *u = t, *v = &MP_DIGIT (y, 1); for (j = first; j <= lim; j++) { (u++)[0] -= q * (v++)[0]; } } t[0] += (t[-1] * MP_RADIX); t[-1] = q; } } norm_mp (w, 2, digits_w); round_internal_mp (z, w, digits); /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (y, 1) = y_1; MP_DIGIT (z, 1) = ((x_1 * y_1) >= 0 ? z_1 : -z_1); CHECK_MP_EXPONENT (p, z); return (z); } /** @brief Set "z" to the integer quotient of "x" and "y". @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *over_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { int digits_g = FUN_DIGITS (digits); MP_T *x_g, *y_g, *z_g; ADDR_T pop_sp = stack_pointer; if (MP_DIGIT (y, 1) == 0) { errno = ERANGE; return (NO_MP); } STACK_MP (x_g, p, digits_g); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) lengthen_mp (p, y_g, digits_g, y, digits); (void) div_mp (p, z_g, x_g, y_g, digits_g); trunc_mp (p, z_g, z_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); MP_STATUS (z) = (MP_T) INIT_MASK; /* Restore and exit */ stack_pointer = pop_sp; return (z); } /** @brief Set "z" to x mod y. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *mod_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { int digits_g = FUN_DIGITS (digits); ADDR_T pop_sp = stack_pointer; MP_T *x_g, *y_g, *z_g; if (MP_DIGIT (y, 1) == 0) { errno = EDOM; return (NO_MP); } STACK_MP (x_g, p, digits_g); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) lengthen_mp (p, y_g, digits_g, y, digits); (void) lengthen_mp (p, x_g, digits_g, x, digits); /* x mod y = x - y * trunc (x / y) */ (void) over_mp (p, z_g, x_g, y_g, digits_g); (void) mul_mp (p, z_g, y_g, z_g, digits_g); (void) sub_mp (p, z_g, x_g, z_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); /* Restore and exit */ stack_pointer = pop_sp; return (z); } /** @brief Set "z" to the product of x and digit y. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *mul_mp_digit (NODE_T * p, MP_T * z, MP_T * x, MP_T y, int digits) { /* This is an O(N) routine for multiplication by a short value */ MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = y, *u, *v; int j, digits_h = 2 + digits; ADDR_T pop_sp = stack_pointer; MP_DIGIT (x, 1) = ABS (x_1); MP_STATUS (z) = (MP_T) INIT_MASK; y = ABS (y_1); STACK_MP (w, p, digits_h); SET_MP_ZERO (w, digits_h); MP_EXPONENT (w) = MP_EXPONENT (x) + 1; j = digits; u = &MP_DIGIT (w, 1 + digits); v = &MP_DIGIT (x, digits); while (j-- >= 1) { (u--)[0] += y * (v--)[0]; } norm_mp (w, 2, digits_h); round_internal_mp (z, w, digits); /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (z, 1) = ((x_1 * y_1) >= 0 ? z_1 : -z_1); CHECK_MP_EXPONENT (p, z); return (z); } /** @brief Set "z" to x/2. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *half_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { MP_T *w, z_1, x_1 = MP_DIGIT (x, 1), *u, *v; int j, digits_h = 2 + digits; ADDR_T pop_sp = stack_pointer; MP_DIGIT (x, 1) = ABS (x_1); MP_STATUS (z) = (MP_T) INIT_MASK; STACK_MP (w, p, digits_h); SET_MP_ZERO (w, digits_h); /* Calculate x * 0.5 */ MP_EXPONENT (w) = MP_EXPONENT (x); j = digits; u = &MP_DIGIT (w, 1 + digits); v = &MP_DIGIT (x, digits); while (j-- >= 1) { (u--)[0] += (MP_RADIX / 2) * (v--)[0]; } norm_mp (w, 2, digits_h); round_internal_mp (z, w, digits); /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (z, 1) = (x_1 >= 0 ? z_1 : -z_1); CHECK_MP_EXPONENT (p, z); return (z); } /** @brief Set "z" to the quotient of x and digit y. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *div_mp_digit (NODE_T * p, MP_T * z, MP_T * x, MP_T y, int digits) { double xd; MP_T *t, *w, z_1, x_1 = MP_DIGIT (x, 1), y_1 = y; int k, oflow, digits_w = 4 + digits; ADDR_T pop_sp = stack_pointer; if (y == 0) { errno = ERANGE; return (NO_MP); } /* Determine normalisation interval assuming that q < 2b in each step */ oflow = (int) (floor) ((double) MAX_REPR_INT / (3 * (double) MP_RADIX * (double) MP_RADIX)) - 1; ABEND (oflow <= 1, "inadequate MP_RADIX", NO_TEXT); /* Work with positive operands */ MP_DIGIT (x, 1) = ABS (x_1); MP_STATUS (z) = (MP_T) INIT_MASK; y = ABS (y_1); STACK_MP (w, p, digits_w); MP_EXPONENT (w) = MP_EXPONENT (x); MP_DIGIT (w, 1) = (MP_T) 0; MOVE_DIGITS (&MP_DIGIT (w, 2), &MP_DIGIT (x, 1), digits); MP_DIGIT (w, digits + 2) = (MP_T) 0; MP_DIGIT (w, digits + 3) = (MP_T) 0; MP_DIGIT (w, digits + 4) = (MP_T) 0; /* Estimate the denominator */ xd = (double) y *MP_RADIX * MP_RADIX; t = &MP_DIGIT (w, 2); if (digits + 2 < oflow) { for (k = 1; k <= digits + 2; k++, t++) { double xn, q; int first = k + 2; /* Estimate quotient digit and correct */ xn = ((t[-1] * MP_RADIX + t[0]) * MP_RADIX + t[1]) * MP_RADIX + (digits_w >= (first + 2) ? t[2] : 0); q = (double) ((int) (xn / xd)); t[0] += (t[-1] * MP_RADIX - q * y); t[-1] = q; } } else { for (k = 1; k <= digits + 2; k++, t++) { double xn, q; int first = k + 2; if (k % oflow == 0) { norm_mp (w, first, digits_w); } /* Estimate quotient digit and correct */ xn = ((t[-1] * MP_RADIX + t[0]) * MP_RADIX + t[1]) * MP_RADIX + (digits_w >= (first + 2) ? t[2] : 0); q = (double) ((int) (xn / xd)); t[0] += (t[-1] * MP_RADIX - q * y); t[-1] = q; } } norm_mp (w, 2, digits_w); round_internal_mp (z, w, digits); /* Restore and exit */ stack_pointer = pop_sp; z_1 = MP_DIGIT (z, 1); MP_DIGIT (x, 1) = x_1; MP_DIGIT (z, 1) = ((x_1 * y_1) >= 0 ? z_1 : -z_1); CHECK_MP_EXPONENT (p, z); return (z); } /** @brief Set "z" to the integer quotient of "x" and "y". @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *over_mp_digit (NODE_T * p, MP_T * z, MP_T * x, MP_T y, int digits) { int digits_g = FUN_DIGITS (digits); ADDR_T pop_sp = stack_pointer; MP_T *x_g, *z_g; if (y == 0) { errno = ERANGE; return (NO_MP); } STACK_MP (x_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) div_mp_digit (p, z_g, x_g, y, digits_g); trunc_mp (p, z_g, z_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); /* Restore and exit */ stack_pointer = pop_sp; return (z); } /** @brief Set "z" to the reciprocal of "x". @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *rec_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *one; if (MP_DIGIT (x, 1) == 0) { errno = ERANGE; return (NO_MP); } STACK_MP (one, p, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits); (void) div_mp (p, z, one, x, digits); /* Restore and exit */ stack_pointer = pop_sp; return (z); } /** @brief Set "z" to "x" ** "n". @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param n Integer power. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *pow_mp_int (NODE_T * p, MP_T * z, MP_T * x, int n, int digits) { int pop_sp = stack_pointer, bit, digits_g = FUN_DIGITS (digits); BOOL_T negative; MP_T *z_g, *x_g; STACK_MP (z_g, p, digits_g); STACK_MP (x_g, p, digits_g); (void) set_mp_short (z_g, (MP_T) 1, 0, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); negative = (BOOL_T) (n < 0); if (negative) { n = -n; } bit = 1; while ((unsigned) bit <= (unsigned) n) { if (n & bit) { (void) mul_mp (p, z_g, z_g, x_g, digits_g); } (void) mul_mp (p, x_g, x_g, x_g, digits_g); bit *= 2; } (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; if (negative) { (void) rec_mp (p, z, z, digits); } CHECK_MP_EXPONENT (p, z); return (z); } /** @brief Set "z" to 10 ** "n". @param p Node in syntax tree. @param z Multiprecision number. @param n Integer power. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *mp_ten_up (NODE_T * p, MP_T * z, int n, int digits) { int pop_sp = stack_pointer, bit, digits_g = FUN_DIGITS (digits); BOOL_T negative; MP_T *z_g, *x_g; STACK_MP (z_g, p, digits_g); STACK_MP (x_g, p, digits_g); (void) set_mp_short (x_g, (MP_T) 10, 0, digits_g); (void) set_mp_short (z_g, (MP_T) 1, 0, digits_g); negative = (BOOL_T) (n < 0); if (negative) { n = -n; } bit = 1; while ((unsigned) bit <= (unsigned) n) { if (n & bit) { (void) mul_mp (p, z_g, z_g, x_g, digits_g); } (void) mul_mp (p, x_g, x_g, x_g, digits_g); bit *= 2; } (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; if (negative) { (void) rec_mp (p, z, z, digits); } CHECK_MP_EXPONENT (p, z); return (z); } /** @brief Test on |"z"| > 0.001 for argument reduction in "sin" and "exp". @param z Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ static BOOL_T eps_mp (MP_T * z, int digits) { if (MP_DIGIT (z, 1) == 0) { return (A68_FALSE); } else if (MP_EXPONENT (z) > -1) { return (A68_TRUE); } else if (MP_EXPONENT (z) < -1) { return (A68_FALSE); } else { #if (MP_RADIX == DEFAULT_MP_RADIX) /* More or less optimised for LONG and default LONG LONG precisions */ return ((BOOL_T) (digits <= 10 ? ABS (MP_DIGIT (z, 1)) > 100000 : ABS (MP_DIGIT (z, 1)) > 10000)); #else switch (LOG_MP_BASE) { case 3: { return (ABS (MP_DIGIT (z, 1)) > 1); } case 4: { return (ABS (MP_DIGIT (z, 1)) > 10); } case 5: { return (ABS (MP_DIGIT (z, 1)) > 100); } case 6: { return (ABS (MP_DIGIT (z, 1)) > 1000); } default: { ABEND (A68_TRUE, "unexpected mp base", ""); return (A68_FALSE); } } #endif } } /** @brief Set "z" to sqrt ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *sqrt_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits), digits_h; MP_T *tmp, *x_g, *z_g; BOOL_T reciprocal = A68_FALSE; if (MP_DIGIT (x, 1) == 0) { stack_pointer = pop_sp; SET_MP_ZERO (z, digits); return (z); } if (MP_DIGIT (x, 1) < 0) { stack_pointer = pop_sp; errno = EDOM; return (NO_MP); } STACK_MP (z_g, p, digits_g); STACK_MP (x_g, p, digits_g); STACK_MP (tmp, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); /* Scaling for small x; sqrt (x) = 1 / sqrt (1 / x) */ if ((reciprocal = (BOOL_T) (MP_EXPONENT (x_g) < 0)) == A68_TRUE) { (void) rec_mp (p, x_g, x_g, digits_g); } if (ABS (MP_EXPONENT (x_g)) >= 2) { /* For extreme arguments we want accurate results as well */ int expo = (int) MP_EXPONENT (x_g); MP_EXPONENT (x_g) = (MP_T) (expo % 2); (void) sqrt_mp (p, z_g, x_g, digits_g); MP_EXPONENT (z_g) += (MP_T) (expo / 2); } else { /* Argument is in range. Estimate the root as double */ int decimals; double x_d = mp_to_real (p, x_g, digits_g); (void) real_to_mp (p, z_g, sqrt (x_d), digits_g); /* Newton's method: x = (x + a / x) / 2 */ decimals = DOUBLE_ACCURACY; do { decimals <<= 1; digits_h = MINIMUM (1 + decimals / LOG_MP_BASE, digits_g); (void) div_mp (p, tmp, x_g, z_g, digits_h); (void) add_mp (p, tmp, z_g, tmp, digits_h); (void) half_mp (p, z_g, tmp, digits_h); } while (decimals < 2 * digits_g * LOG_MP_BASE); } if (reciprocal) { (void) rec_mp (p, z_g, z_g, digits); } (void) shorten_mp (p, z, digits, z_g, digits_g); /* Exit */ stack_pointer = pop_sp; return (z); } /** @brief Set "z" to curt ("x"), the cube root. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *curt_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits), digits_h; MP_T *tmp, *x_g, *z_g; BOOL_T reciprocal = A68_FALSE, change_sign = A68_FALSE; if (MP_DIGIT (x, 1) == 0) { stack_pointer = pop_sp; SET_MP_ZERO (z, digits); return (z); } if (MP_DIGIT (x, 1) < 0) { change_sign = A68_TRUE; MP_DIGIT (x, 1) = -MP_DIGIT (x, 1); } STACK_MP (z_g, p, digits_g); STACK_MP (x_g, p, digits_g); STACK_MP (tmp, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); /* Scaling for small x; curt (x) = 1 / curt (1 / x) */ if ((reciprocal = (BOOL_T) (MP_EXPONENT (x_g) < 0)) == A68_TRUE) { (void) rec_mp (p, x_g, x_g, digits_g); } if (ABS (MP_EXPONENT (x_g)) >= 3) { /* For extreme arguments we want accurate results as well */ int expo = (int) MP_EXPONENT (x_g); MP_EXPONENT (x_g) = (MP_T) (expo % 3); (void) curt_mp (p, z_g, x_g, digits_g); MP_EXPONENT (z_g) += (MP_T) (expo / 3); } else { /* Argument is in range. Estimate the root as double */ int decimals; (void) real_to_mp (p, z_g, curt (mp_to_real (p, x_g, digits_g)), digits_g); /* Newton's method: x = (2 x + a / x ^ 2) / 3 */ decimals = DOUBLE_ACCURACY; do { decimals <<= 1; digits_h = MINIMUM (1 + decimals / LOG_MP_BASE, digits_g); (void) mul_mp (p, tmp, z_g, z_g, digits_h); (void) div_mp (p, tmp, x_g, tmp, digits_h); (void) add_mp (p, tmp, z_g, tmp, digits_h); (void) add_mp (p, tmp, z_g, tmp, digits_h); (void) div_mp_digit (p, z_g, tmp, (MP_T) 3, digits_h); } while (decimals < digits_g * LOG_MP_BASE); } if (reciprocal) { (void) rec_mp (p, z_g, z_g, digits); } (void) shorten_mp (p, z, digits, z_g, digits_g); /* Exit */ stack_pointer = pop_sp; if (change_sign) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } return (z); } /** @brief Set "z" to sqrt ("x"^2 + "y"^2). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *hypot_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *t, *u, *v; STACK_MP (t, p, digits); STACK_MP (u, p, digits); STACK_MP (v, p, digits); MOVE_MP (u, x, digits); MOVE_MP (v, y, digits); MP_DIGIT (u, 1) = ABS (MP_DIGIT (u, 1)); MP_DIGIT (v, 1) = ABS (MP_DIGIT (v, 1)); if (IS_ZERO_MP (u)) { MOVE_MP (z, v, digits); } else if (IS_ZERO_MP (v)) { MOVE_MP (z, u, digits); } else { (void) set_mp_short (t, (MP_T) 1, 0, digits); (void) sub_mp (p, z, u, v, digits); if (MP_DIGIT (z, 1) > 0) { (void) div_mp (p, z, v, u, digits); (void) mul_mp (p, z, z, z, digits); (void) add_mp (p, z, t, z, digits); (void) sqrt_mp (p, z, z, digits); (void) mul_mp (p, z, u, z, digits); } else { (void) div_mp (p, z, u, v, digits); (void) mul_mp (p, z, z, z, digits); (void) add_mp (p, z, t, z, digits); (void) sqrt_mp (p, z, z, digits); (void) mul_mp (p, z, v, z, digits); } } stack_pointer = pop_sp; return (z); } /** @brief Set "z" to exp ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *exp_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Argument is reduced by using exp (z / (2 ** n)) ** (2 ** n) = exp(z) */ int m, n, pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *x_g, *sum, *a68g_pow, *fac, *tmp; BOOL_T iterate; if (MP_DIGIT (x, 1) == 0) { (void) set_mp_short (z, (MP_T) 1, 0, digits); return (z); } STACK_MP (x_g, p, digits_g); STACK_MP (sum, p, digits_g); STACK_MP (a68g_pow, p, digits_g); STACK_MP (fac, p, digits_g); STACK_MP (tmp, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); m = 0; /* Scale x down */ while (eps_mp (x_g, digits_g)) { m++; (void) half_mp (p, x_g, x_g, digits_g); } /* Calculate Taylor sum exp (z) = 1 + z / 1 ! + z ** 2 / 2 ! + .. */ (void) set_mp_short (sum, (MP_T) 1, 0, digits_g); (void) add_mp (p, sum, sum, x_g, digits_g); (void) mul_mp (p, a68g_pow, x_g, x_g, digits_g); #if (MP_RADIX == DEFAULT_MP_RADIX) (void) half_mp (p, tmp, a68g_pow, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 6, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 24, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 120, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 720, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 5040, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 40320, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 362880, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) set_mp_short (fac, (MP_T) (MP_T) 3628800, 0, digits_g); n = 10; #else (void) set_mp_short (fac, (MP_T) 2, 0, digits_g); n = 2; #endif iterate = (BOOL_T) (MP_DIGIT (a68g_pow, 1) != 0); while (iterate) { (void) div_mp (p, tmp, a68g_pow, fac, digits_g); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (sum) - digits_g)) { iterate = A68_FALSE; } else { (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); n++; (void) mul_mp_digit (p, fac, fac, (MP_T) n, digits_g); } } /* Square exp (x) up */ while (m--) { (void) mul_mp (p, sum, sum, sum, digits_g); } (void) shorten_mp (p, z, digits, sum, digits_g); /* Exit */ stack_pointer = pop_sp; return (z); } /** @brief Set "z" to exp ("x") - 1, assuming "x" to be close to 0. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *expm1_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int n, pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *x_g, *sum, *a68g_pow, *fac, *tmp; BOOL_T iterate; if (MP_DIGIT (x, 1) == 0) { (void) set_mp_short (z, (MP_T) 1, 0, digits); return (z); } STACK_MP (x_g, p, digits_g); STACK_MP (sum, p, digits_g); STACK_MP (a68g_pow, p, digits_g); STACK_MP (fac, p, digits_g); STACK_MP (tmp, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); /* Calculate Taylor sum expm1 (z) = z / 1 ! + z ** 2 / 2 ! + .. */ SET_MP_ZERO (sum, digits_g); (void) add_mp (p, sum, sum, x_g, digits_g); (void) mul_mp (p, a68g_pow, x_g, x_g, digits_g); #if (MP_RADIX == DEFAULT_MP_RADIX) (void) half_mp (p, tmp, a68g_pow, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 6, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 24, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 120, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 720, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 5040, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 40320, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 362880, digits_g); (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); (void) set_mp_short (fac, (MP_T) (MP_T) 3628800, 0, digits_g); n = 10; #else (void) set_mp_short (fac, (MP_T) 2, 0, digits_g); n = 2; #endif iterate = (BOOL_T) (MP_DIGIT (a68g_pow, 1) != 0); while (iterate) { (void) div_mp (p, tmp, a68g_pow, fac, digits_g); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (sum) - digits_g)) { iterate = A68_FALSE; } else { (void) add_mp (p, sum, sum, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); n++; (void) mul_mp_digit (p, fac, fac, (MP_T) n, digits_g); } } (void) shorten_mp (p, z, digits, sum, digits_g); /* Exit */ stack_pointer = pop_sp; return (z); } /** @brief Ln scale with digits precision. @param p Node in syntax tree. @param z Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *mp_ln_scale (NODE_T * p, MP_T * z, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *z_g; STACK_MP (z_g, p, digits_g); /* First see if we can restore a previous calculation */ if (digits_g <= mp_ln_scale_size) { MOVE_MP (z_g, ref_mp_ln_scale, digits_g); } else { /* No luck with the kept value, we generate a longer one */ (void) set_mp_short (z_g, (MP_T) 1, 1, digits_g); (void) ln_mp (p, z_g, z_g, digits_g); ref_mp_ln_scale = (MP_T *) get_heap_space ((unsigned) SIZE_MP (digits_g)); MOVE_MP (ref_mp_ln_scale, z_g, digits_g); mp_ln_scale_size = digits_g; } (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /** @brief Ln 10 with digits precision. @param p Node in syntax tree. @param z Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *mp_ln_10 (NODE_T * p, MP_T * z, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *z_g; STACK_MP (z_g, p, digits_g); /* First see if we can restore a previous calculation */ if (digits_g <= mp_ln_10_size) { MOVE_MP (z_g, ref_mp_ln_10, digits_g); } else { /* No luck with the kept value, we generate a longer one */ (void) set_mp_short (z_g, (MP_T) 10, 0, digits_g); (void) ln_mp (p, z_g, z_g, digits_g); ref_mp_ln_10 = (MP_T *) get_heap_space ((unsigned) SIZE_MP (digits_g)); MOVE_MP (ref_mp_ln_10, z_g, digits_g); mp_ln_10_size = digits_g; } (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /** @brief Set "z" to ln ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *ln_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Depending on the argument we choose either Taylor or Newton */ int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); BOOL_T negative, scale; MP_T *x_g, *z_g, expo = 0; if (MP_DIGIT (x, 1) <= 0) { errno = EDOM; return (NO_MP); } STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (z_g, p, digits_g); /* We use ln (1 / x) = - ln (x) */ negative = (BOOL_T) (MP_EXPONENT (x_g) < 0); if (negative) { (void) rec_mp (p, x_g, x_g, digits); } /* We want correct results for extreme arguments. We scale when "x_g" exceeds "MP_RADIX ** +- 2", using ln (x * MP_RADIX ** n) = ln (x) + n * ln (MP_RADIX).*/ scale = (BOOL_T) (ABS (MP_EXPONENT (x_g)) >= 2); if (scale) { expo = MP_EXPONENT (x_g); MP_EXPONENT (x_g) = (MP_T) 0; } if (MP_EXPONENT (x_g) == 0 && MP_DIGIT (x_g, 1) == 1 && MP_DIGIT (x_g, 2) == 0) { /* Taylor sum for x close to unity. ln (x) = (x - 1) - (x - 1) ** 2 / 2 + (x - 1) ** 3 / 3 - ... This is faster for small x and avoids cancellation */ MP_T *one, *tmp, *a68g_pow; int n = 2; BOOL_T iterate; STACK_MP (one, p, digits_g); STACK_MP (tmp, p, digits_g); STACK_MP (a68g_pow, p, digits_g); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); (void) sub_mp (p, x_g, x_g, one, digits_g); (void) mul_mp (p, a68g_pow, x_g, x_g, digits_g); MOVE_MP (z_g, x_g, digits_g); iterate = (BOOL_T) (MP_DIGIT (a68g_pow, 1) != 0); while (iterate) { (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) n, digits_g); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (z_g) - digits_g)) { iterate = A68_FALSE; } else { MP_DIGIT (tmp, 1) = (n % 2 == 0 ? -MP_DIGIT (tmp, 1) : MP_DIGIT (tmp, 1)); (void) add_mp (p, z_g, z_g, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, x_g, digits_g); n++; } } } else { /* Newton's method: x = x - 1 + a / exp (x) */ MP_T *tmp, *z_0, *one; int decimals; STACK_MP (tmp, p, digits_g); STACK_MP (one, p, digits_g); STACK_MP (z_0, p, digits_g); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); SET_MP_ZERO (z_0, digits_g); /* Construct an estimate */ (void) real_to_mp (p, z_g, log (mp_to_real (p, x_g, digits_g)), digits_g); decimals = DOUBLE_ACCURACY; do { int digits_h; decimals <<= 1; digits_h = MINIMUM (1 + decimals / LOG_MP_BASE, digits_g); (void) exp_mp (p, tmp, z_g, digits_h); (void) div_mp (p, tmp, x_g, tmp, digits_h); (void) sub_mp (p, z_g, z_g, one, digits_h); (void) add_mp (p, z_g, z_g, tmp, digits_h); } while (decimals < digits_g * LOG_MP_BASE); } /* Inverse scaling */ if (scale) { /* ln (x * MP_RADIX ** n) = ln (x) + n * ln (MP_RADIX) */ MP_T *ln_base; STACK_MP (ln_base, p, digits_g); (void) mp_ln_scale (p, ln_base, digits_g); (void) mul_mp_digit (p, ln_base, ln_base, (MP_T) expo, digits_g); (void) add_mp (p, z_g, z_g, ln_base, digits_g); } if (negative) { MP_DIGIT (z_g, 1) = -MP_DIGIT (z_g, 1); } (void) shorten_mp (p, z, digits, z_g, digits_g); /* Exit */ stack_pointer = pop_sp; return (z); } /** @brief Set "z" to log ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *log_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int pop_sp = stack_pointer; MP_T *ln_10; STACK_MP (ln_10, p, digits); if (ln_mp (p, z, x, digits) == NO_MP) { errno = EDOM; return (NO_MP); } (void) mp_ln_10 (p, ln_10, digits); (void) div_mp (p, z, z, ln_10, digits); stack_pointer = pop_sp; return (z); } /** @brief Set "sh" and "ch" to sinh ("z") and cosh ("z") respectively. @param p Node in syntax tree. @param sh Multiprecision number. @param ch Multiprecision number. @param z Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *hyp_mp (NODE_T * p, MP_T * sh, MP_T * ch, MP_T * z, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *x_g, *y_g, *z_g; STACK_MP (x_g, p, digits); STACK_MP (y_g, p, digits); STACK_MP (z_g, p, digits); MOVE_MP (z_g, z, digits); (void) exp_mp (p, x_g, z_g, digits); (void) rec_mp (p, y_g, x_g, digits); (void) add_mp (p, ch, x_g, y_g, digits); /* Avoid cancellation for sinh */ if ((MP_DIGIT (x_g, 1) == 1 && MP_DIGIT (x_g, 2) == 0) || (MP_DIGIT (y_g, 1) == 1 && MP_DIGIT (y_g, 2) == 0)) { (void) expm1_mp (p, x_g, z_g, digits); MP_DIGIT (z_g, 1) = -MP_DIGIT (z_g, 1); (void) expm1_mp (p, y_g, z_g, digits); } (void) sub_mp (p, sh, x_g, y_g, digits); (void) half_mp (p, sh, sh, digits); (void) half_mp (p, ch, ch, digits); stack_pointer = pop_sp; return (z); } /** @brief Set "z" to sinh ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *sinh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g = FUN_DIGITS (digits); MP_T *x_g, *y_g, *z_g; STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) hyp_mp (p, z_g, y_g, x_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /** @brief Set "z" to asinh ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *asinh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { if (IS_ZERO_MP (x)) { SET_MP_ZERO (z, digits); return (z); } else { ADDR_T pop_sp = stack_pointer; int digits_g; MP_T *x_g, *y_g, *z_g; if (MP_EXPONENT (x) >= -1) { digits_g = FUN_DIGITS (digits); } else { /* Extra precision when x^2+1 gets close to 1 */ digits_g = 2 * FUN_DIGITS (digits); } STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) mul_mp (p, z_g, x_g, x_g, digits_g); (void) set_mp_short (y_g, (MP_T) 1, 0, digits_g); (void) add_mp (p, y_g, z_g, y_g, digits_g); (void) sqrt_mp (p, y_g, y_g, digits_g); (void) add_mp (p, y_g, y_g, x_g, digits_g); (void) ln_mp (p, z_g, y_g, digits_g); if (IS_ZERO_MP (z_g)) { MOVE_MP (z, x, digits); } else { (void) shorten_mp (p, z, digits, z_g, digits_g); } stack_pointer = pop_sp; return (z); } } /** @brief Set "z" to cosh ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *cosh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g = FUN_DIGITS (digits); MP_T *x_g, *y_g, *z_g; STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) hyp_mp (p, y_g, z_g, x_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /** @brief Set "z" to acosh ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *acosh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g; MP_T *x_g, *y_g, *z_g; if (MP_DIGIT (x, 1) == 1 && MP_DIGIT (x, 2) == 0) { /* Extra precision when x^2-1 gets close to 0 */ digits_g = 2 * FUN_DIGITS (digits); } else { digits_g = FUN_DIGITS (digits); } STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) mul_mp (p, z_g, x_g, x_g, digits_g); (void) set_mp_short (y_g, (MP_T) 1, 0, digits_g); (void) sub_mp (p, y_g, z_g, y_g, digits_g); (void) sqrt_mp (p, y_g, y_g, digits_g); (void) add_mp (p, y_g, y_g, x_g, digits_g); (void) ln_mp (p, z_g, y_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /** @brief Set "z" to tanh ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *tanh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g = FUN_DIGITS (digits); MP_T *x_g, *y_g, *z_g; STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) hyp_mp (p, y_g, z_g, x_g, digits_g); (void) div_mp (p, z_g, y_g, z_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /** @brief Set "z" to atanh ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *atanh_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g = FUN_DIGITS (digits); MP_T *x_g, *y_g, *z_g; STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); STACK_MP (y_g, p, digits_g); STACK_MP (z_g, p, digits_g); (void) set_mp_short (y_g, (MP_T) 1, 0, digits_g); (void) add_mp (p, z_g, y_g, x_g, digits_g); (void) sub_mp (p, y_g, y_g, x_g, digits_g); (void) div_mp (p, y_g, z_g, y_g, digits_g); (void) ln_mp (p, z_g, y_g, digits_g); (void) half_mp (p, z_g, z_g, digits_g); (void) shorten_mp (p, z, digits, z_g, digits_g); stack_pointer = pop_sp; return (z); } /** @brief Return "pi" with "digits" precision, using Borwein & Borwein AGM. @param p Node in syntax tree. @param api Multiprecision number. @param mult Small multiplier. @param digits Precision in mp-digits. @return Result "api". **/ MP_T *mp_pi (NODE_T * p, MP_T * api, int mult, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); BOOL_T iterate; MP_T *pi_g, *one, *two, *x_g, *y_g, *u_g, *v_g; STACK_MP (pi_g, p, digits_g); /* First see if we can restore a previous calculation */ if (digits_g <= mp_pi_size) { MOVE_MP (pi_g, ref_mp_pi, digits_g); } else { /* No luck with the kept value, hence we generate a longer "pi". Calculate "pi" using the Borwein & Borwein AGM algorithm. This AGM doubles the numbers of digits at every pass */ STACK_MP (one, p, digits_g); STACK_MP (two, p, digits_g); STACK_MP (x_g, p, digits_g); STACK_MP (y_g, p, digits_g); STACK_MP (u_g, p, digits_g); STACK_MP (v_g, p, digits_g); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); (void) set_mp_short (two, (MP_T) 2, 0, digits_g); (void) set_mp_short (x_g, (MP_T) 2, 0, digits_g); (void) sqrt_mp (p, x_g, x_g, digits_g); (void) add_mp (p, pi_g, x_g, two, digits_g); (void) sqrt_mp (p, y_g, x_g, digits_g); iterate = A68_TRUE; while (iterate) { /* New x */ (void) sqrt_mp (p, u_g, x_g, digits_g); (void) div_mp (p, v_g, one, u_g, digits_g); (void) add_mp (p, u_g, u_g, v_g, digits_g); (void) half_mp (p, x_g, u_g, digits_g); /* New pi */ (void) add_mp (p, u_g, x_g, one, digits_g); (void) add_mp (p, v_g, y_g, one, digits_g); (void) div_mp (p, u_g, u_g, v_g, digits_g); (void) mul_mp (p, v_g, pi_g, u_g, digits_g); /* Done yet? */ if (same_mp (p, v_g, pi_g, digits_g)) { iterate = A68_FALSE; } else { MOVE_MP (pi_g, v_g, digits_g); /* New y */ (void) sqrt_mp (p, u_g, x_g, digits_g); (void) div_mp (p, v_g, one, u_g, digits_g); (void) mul_mp (p, u_g, y_g, u_g, digits_g); (void) add_mp (p, u_g, u_g, v_g, digits_g); (void) add_mp (p, v_g, y_g, one, digits_g); (void) div_mp (p, y_g, u_g, v_g, digits_g); } } /* Keep the result for future restore */ ref_mp_pi = (MP_T *) get_heap_space ((unsigned) SIZE_MP (digits_g)); MOVE_MP (ref_mp_pi, pi_g, digits_g); mp_pi_size = digits_g; } switch (mult) { case MP_PI: { break; } case MP_TWO_PI: { (void) mul_mp_digit (p, pi_g, pi_g, (MP_T) 2, digits_g); break; } case MP_HALF_PI: { (void) half_mp (p, pi_g, pi_g, digits_g); break; } } (void) shorten_mp (p, api, digits, pi_g, digits_g); stack_pointer = pop_sp; return (api); } /** @brief Set "z" to sin ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *sin_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Use triple-angle relation to reduce argument */ int pop_sp = stack_pointer, m, n, digits_g = FUN_DIGITS (digits); BOOL_T flip, negative, iterate, even; MP_T *x_g, *pi, *tpi, *hpi, *sqr, *tmp, *a68g_pow, *fac, *z_g; /* We will use "pi" */ STACK_MP (pi, p, digits_g); STACK_MP (tpi, p, digits_g); STACK_MP (hpi, p, digits_g); (void) mp_pi (p, pi, MP_PI, digits_g); (void) mp_pi (p, tpi, MP_TWO_PI, digits_g); (void) mp_pi (p, hpi, MP_HALF_PI, digits_g); /* Argument reduction (1): sin (x) = sin (x mod 2 pi) */ STACK_MP (x_g, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) mod_mp (p, x_g, x_g, tpi, digits_g); /* Argument reduction (2): sin (-x) = sin (x) sin (x) = - sin (x - pi); pi < x <= 2 pi sin (x) = sin (pi - x); pi / 2 < x <= pi */ negative = (BOOL_T) (MP_DIGIT (x_g, 1) < 0); if (negative) { MP_DIGIT (x_g, 1) = -MP_DIGIT (x_g, 1); } STACK_MP (tmp, p, digits_g); (void) sub_mp (p, tmp, x_g, pi, digits_g); flip = (BOOL_T) (MP_DIGIT (tmp, 1) > 0); if (flip) { /* x > pi */ (void) sub_mp (p, x_g, x_g, pi, digits_g); } (void) sub_mp (p, tmp, x_g, hpi, digits_g); if (MP_DIGIT (tmp, 1) > 0) { /* x > pi / 2 */ (void) sub_mp (p, x_g, pi, x_g, digits_g); } /* Argument reduction (3): (follows from De Moivre's theorem) sin (3x) = sin (x) * (3 - 4 sin ^ 2 (x)) */ m = 0; while (eps_mp (x_g, digits_g)) { m++; (void) div_mp_digit (p, x_g, x_g, (MP_T) 3, digits_g); } /* Taylor sum */ STACK_MP (sqr, p, digits_g); STACK_MP (a68g_pow, p, digits_g); STACK_MP (fac, p, digits_g); STACK_MP (z_g, p, digits_g); (void) mul_mp (p, sqr, x_g, x_g, digits_g); /* sqr = x ** 2 */ (void) mul_mp (p, a68g_pow, sqr, x_g, digits_g); /* pow = x ** 3 */ MOVE_MP (z_g, x_g, digits_g); #if (MP_RADIX == DEFAULT_MP_RADIX) (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 6, digits_g); (void) sub_mp (p, z_g, z_g, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, sqr, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 120, digits_g); (void) add_mp (p, z_g, z_g, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, sqr, digits_g); (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) 5040, digits_g); (void) sub_mp (p, z_g, z_g, tmp, digits_g); (void) mul_mp (p, a68g_pow, a68g_pow, sqr, digits_g); (void) set_mp_short (fac, (MP_T) 362880, 0, digits_g); n = 9; even = A68_TRUE; #else (void) set_mp_short (fac, (MP_T) 6, 0, digits_g); n = 3; even = A68_FALSE; #endif iterate = (BOOL_T) (MP_DIGIT (a68g_pow, 1) != 0); while (iterate) { (void) div_mp (p, tmp, a68g_pow, fac, digits_g); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (z_g) - digits_g)) { iterate = A68_FALSE; } else { if (even) { (void) add_mp (p, z_g, z_g, tmp, digits_g); even = A68_FALSE; } else { (void) sub_mp (p, z_g, z_g, tmp, digits_g); even = A68_TRUE; } (void) mul_mp (p, a68g_pow, a68g_pow, sqr, digits_g); (void) mul_mp_digit (p, fac, fac, (MP_T) (++n), digits_g); (void) mul_mp_digit (p, fac, fac, (MP_T) (++n), digits_g); } } /* Inverse scaling using sin (3x) = sin (x) * (3 - 4 sin ** 2 (x)) Use existing mp's for intermediates */ (void) set_mp_short (fac, (MP_T) 3, 0, digits_g); while (m--) { (void) mul_mp (p, a68g_pow, z_g, z_g, digits_g); (void) mul_mp_digit (p, a68g_pow, a68g_pow, (MP_T) 4, digits_g); (void) sub_mp (p, a68g_pow, fac, a68g_pow, digits_g); (void) mul_mp (p, z_g, a68g_pow, z_g, digits_g); } (void) shorten_mp (p, z, digits, z_g, digits_g); if (negative ^ flip) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } /* Exit */ stack_pointer = pop_sp; return (z); } /** @brief Set "z" to cos ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *cos_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Use cos (x) = sin (pi / 2 - x). Compute x mod 2 pi before subtracting to avoid cancellation. */ int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *hpi, *tpi, *x_g, *y; STACK_MP (hpi, p, digits_g); STACK_MP (tpi, p, digits_g); STACK_MP (x_g, p, digits_g); STACK_MP (y, p, digits); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) mp_pi (p, hpi, MP_HALF_PI, digits_g); (void) mp_pi (p, tpi, MP_TWO_PI, digits_g); (void) mod_mp (p, x_g, x_g, tpi, digits_g); (void) sub_mp (p, x_g, hpi, x_g, digits_g); (void) shorten_mp (p, y, digits, x_g, digits_g); (void) sin_mp (p, z, y, digits); stack_pointer = pop_sp; return (z); } /** @brief Set "z" to tan ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *tan_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Use tan (x) = sin (x) / sqrt (1 - sin ^ 2 (x)) */ int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *sns, *cns, *one, *pi, *hpi, *x_g, *y_g; BOOL_T negate; STACK_MP (one, p, digits); STACK_MP (pi, p, digits_g); STACK_MP (hpi, p, digits_g); STACK_MP (x_g, p, digits_g); STACK_MP (y_g, p, digits_g); STACK_MP (sns, p, digits); STACK_MP (cns, p, digits); /* Argument mod pi */ (void) mp_pi (p, pi, MP_PI, digits_g); (void) mp_pi (p, hpi, MP_HALF_PI, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) mod_mp (p, x_g, x_g, pi, digits_g); if (MP_DIGIT (x_g, 1) >= 0) { (void) sub_mp (p, y_g, x_g, hpi, digits_g); negate = (BOOL_T) (MP_DIGIT (y_g, 1) > 0); } else { (void) add_mp (p, y_g, x_g, hpi, digits_g); negate = (BOOL_T) (MP_DIGIT (y_g, 1) < 0); } (void) shorten_mp (p, x, digits, x_g, digits_g); /* tan(x) = sin(x) / sqrt (1 - sin ** 2 (x)) */ (void) sin_mp (p, sns, x, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits); (void) mul_mp (p, cns, sns, sns, digits); (void) sub_mp (p, cns, one, cns, digits); (void) sqrt_mp (p, cns, cns, digits); if (div_mp (p, z, sns, cns, digits) == NO_MP) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } stack_pointer = pop_sp; if (negate) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } return (z); } /** @brief Set "z" to arcsin ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *asin_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *one, *x_g, *y, *z_g; STACK_MP (y, p, digits); STACK_MP (x_g, p, digits_g); STACK_MP (z_g, p, digits_g); STACK_MP (one, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); (void) mul_mp (p, z_g, x_g, x_g, digits_g); (void) sub_mp (p, z_g, one, z_g, digits_g); if (sqrt_mp (p, z_g, z_g, digits) == NO_MP) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } if (MP_DIGIT (z_g, 1) == 0) { (void) mp_pi (p, z, MP_HALF_PI, digits); MP_DIGIT (z, 1) = (MP_DIGIT (x_g, 1) >= 0 ? MP_DIGIT (z, 1) : -MP_DIGIT (z, 1)); stack_pointer = pop_sp; return (z); } if (div_mp (p, x_g, x_g, z_g, digits_g) == NO_MP) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } (void) shorten_mp (p, y, digits, x_g, digits_g); (void) atan_mp (p, z, y, digits); stack_pointer = pop_sp; return (z); } /** @brief Set "z" to arccos ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *acos_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *one, *x_g, *y, *z_g; BOOL_T negative = (BOOL_T) (MP_DIGIT (x, 1) < 0); if (MP_DIGIT (x, 1) == 0) { (void) mp_pi (p, z, MP_HALF_PI, digits); stack_pointer = pop_sp; return (z); } STACK_MP (y, p, digits); STACK_MP (x_g, p, digits_g); STACK_MP (z_g, p, digits_g); STACK_MP (one, p, digits_g); (void) lengthen_mp (p, x_g, digits_g, x, digits); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); (void) mul_mp (p, z_g, x_g, x_g, digits_g); (void) sub_mp (p, z_g, one, z_g, digits_g); if (sqrt_mp (p, z_g, z_g, digits) == NO_MP) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } if (div_mp (p, x_g, z_g, x_g, digits_g) == NO_MP) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } (void) shorten_mp (p, y, digits, x_g, digits_g); (void) atan_mp (p, z, y, digits); if (negative) { (void) mp_pi (p, y, MP_PI, digits); (void) add_mp (p, z, z, y, digits); } stack_pointer = pop_sp; return (z); } /** @brief Set "z" to arctan ("x"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *atan_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { /* Depending on the argument we choose either Taylor or Newton */ int pop_sp = stack_pointer, digits_g = FUN_DIGITS (digits); MP_T *x_g, *z_g; BOOL_T flip, negative; STACK_MP (x_g, p, digits_g); STACK_MP (z_g, p, digits_g); if (MP_DIGIT (x, 1) == 0) { stack_pointer = pop_sp; SET_MP_ZERO (z, digits); return (z); } (void) lengthen_mp (p, x_g, digits_g, x, digits); negative = (BOOL_T) (MP_DIGIT (x_g, 1) < 0); if (negative) { MP_DIGIT (x_g, 1) = -MP_DIGIT (x_g, 1); } /* For larger arguments we use atan(x) = pi/2 - atan(1/x) */ flip = (BOOL_T) (((MP_EXPONENT (x_g) > 0) || (MP_EXPONENT (x_g) == 0 && MP_DIGIT (x_g, 1) > 1)) && (MP_DIGIT (x_g, 1) != 0)); if (flip) { (void) rec_mp (p, x_g, x_g, digits_g); } if (MP_EXPONENT (x_g) < -1 || (MP_EXPONENT (x_g) == -1 && MP_DIGIT (x_g, 1) < MP_RADIX / 100)) { /* Taylor sum for x close to zero. arctan (x) = x - x ** 3 / 3 + x ** 5 / 5 - x ** 7 / 7 + .. This is faster for small x and avoids cancellation */ MP_T *tmp, *a68g_pow, *sqr; int n = 3; BOOL_T iterate, even; STACK_MP (tmp, p, digits_g); STACK_MP (a68g_pow, p, digits_g); STACK_MP (sqr, p, digits_g); (void) mul_mp (p, sqr, x_g, x_g, digits_g); (void) mul_mp (p, a68g_pow, sqr, x_g, digits_g); MOVE_MP (z_g, x_g, digits_g); even = A68_FALSE; iterate = (BOOL_T) (MP_DIGIT (a68g_pow, 1) != 0); while (iterate) { (void) div_mp_digit (p, tmp, a68g_pow, (MP_T) n, digits_g); if (MP_EXPONENT (tmp) <= (MP_EXPONENT (z_g) - digits_g)) { iterate = A68_FALSE; } else { if (even) { (void) add_mp (p, z_g, z_g, tmp, digits_g); even = A68_FALSE; } else { (void) sub_mp (p, z_g, z_g, tmp, digits_g); even = A68_TRUE; } (void) mul_mp (p, a68g_pow, a68g_pow, sqr, digits_g); n += 2; } } } else { /* Newton's method: x = x - cos (x) * (sin (x) - a cos (x)) */ MP_T *tmp, *z_0, *sns, *cns, *one; int decimals, digits_h; STACK_MP (tmp, p, digits_g); STACK_MP (z_0, p, digits_g); STACK_MP (sns, p, digits_g); STACK_MP (cns, p, digits_g); STACK_MP (one, p, digits_g); SET_MP_ZERO (z_0, digits_g); (void) set_mp_short (one, (MP_T) 1, 0, digits_g); /* Construct an estimate */ (void) real_to_mp (p, z_g, atan (mp_to_real (p, x_g, digits_g)), digits_g); decimals = DOUBLE_ACCURACY; do { decimals <<= 1; digits_h = MINIMUM (1 + decimals / LOG_MP_BASE, digits_g); (void) sin_mp (p, sns, z_g, digits_h); (void) mul_mp (p, tmp, sns, sns, digits_h); (void) sub_mp (p, tmp, one, tmp, digits_h); (void) sqrt_mp (p, cns, tmp, digits_h); (void) mul_mp (p, tmp, x_g, cns, digits_h); (void) sub_mp (p, tmp, sns, tmp, digits_h); (void) mul_mp (p, tmp, tmp, cns, digits_h); (void) sub_mp (p, z_g, z_g, tmp, digits_h); } while (decimals < digits_g * LOG_MP_BASE); } if (flip) { MP_T *hpi; STACK_MP (hpi, p, digits_g); (void) sub_mp (p, z_g, mp_pi (p, hpi, MP_HALF_PI, digits_g), z_g, digits_g); } (void) shorten_mp (p, z, digits, z_g, digits_g); MP_DIGIT (z, 1) = (negative ? -MP_DIGIT (z, 1) : MP_DIGIT (z, 1)); /* Exit */ stack_pointer = pop_sp; return (z); } /** @brief Set "z" to atan2 ("x", "y"). @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Result "z". **/ MP_T *atan2_mp (NODE_T * p, MP_T * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *t; STACK_MP (t, p, digits); if (MP_DIGIT (x, 1) == 0 && MP_DIGIT (y, 1) == 0) { errno = EDOM; stack_pointer = pop_sp; return (NO_MP); } else { BOOL_T flip = (BOOL_T) (MP_DIGIT (y, 1) < 0); MP_DIGIT (y, 1) = ABS (MP_DIGIT (y, 1)); if (IS_ZERO_MP (x)) { (void) mp_pi (p, z, MP_HALF_PI, digits); } else { BOOL_T flop = (BOOL_T) (MP_DIGIT (x, 1) <= 0); MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1)); (void) div_mp (p, z, y, x, digits); (void) atan_mp (p, z, z, digits); if (flop) { (void) mp_pi (p, t, MP_PI, digits); (void) sub_mp (p, z, t, z, digits); } } if (flip) { MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); } } stack_pointer = pop_sp; return (z); } /** @brief Set "a" I "b" to "a" I "b" * "c" I "d". @param p Node in syntax tree. @param a Real mp number. @param b Imaginary mp number. @param c Real mp number. @param d Imaginary mp number. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *cmul_mp (NODE_T * p, MP_T * a, MP_T * b, MP_T * c, MP_T * d, int digits) { ADDR_T pop_sp = stack_pointer; int digits_g = FUN_DIGITS (digits); MP_T *la, *lb, *lc, *ld, *ac, *bd, *ad, *bc; STACK_MP (la, p, digits_g); STACK_MP (lb, p, digits_g); STACK_MP (lc, p, digits_g); STACK_MP (ld, p, digits_g); (void) lengthen_mp (p, la, digits_g, a, digits); (void) lengthen_mp (p, lb, digits_g, b, digits); (void) lengthen_mp (p, lc, digits_g, c, digits); (void) lengthen_mp (p, ld, digits_g, d, digits); STACK_MP (ac, p, digits_g); STACK_MP (bd, p, digits_g); STACK_MP (ad, p, digits_g); STACK_MP (bc, p, digits_g); (void) mul_mp (p, ac, la, lc, digits_g); (void) mul_mp (p, bd, lb, ld, digits_g); (void) mul_mp (p, ad, la, ld, digits_g); (void) mul_mp (p, bc, lb, lc, digits_g); (void) sub_mp (p, la, ac, bd, digits_g); (void) add_mp (p, lb, ad, bc, digits_g); (void) shorten_mp (p, a, digits, la, digits_g); (void) shorten_mp (p, b, digits, lb, digits_g); stack_pointer = pop_sp; return (a); } /** @brief Set "a" I "b" to "a" I "b" / "c" I "d". @param p Node in syntax tree. @param a Real mp number. @param b Imaginary mp number. @param c Real mp number. @param d Imaginary mp number. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *cdiv_mp (NODE_T * p, MP_T * a, MP_T * b, MP_T * c, MP_T * d, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *q, *r; if (MP_DIGIT (c, 1) == (MP_T) 0 && MP_DIGIT (d, 1) == (MP_T) 0) { errno = ERANGE; return (NO_MP); } STACK_MP (q, p, digits); STACK_MP (r, p, digits); MOVE_MP (q, c, digits); MOVE_MP (r, d, digits); MP_DIGIT (q, 1) = ABS (MP_DIGIT (q, 1)); MP_DIGIT (r, 1) = ABS (MP_DIGIT (r, 1)); (void) sub_mp (p, q, q, r, digits); if (MP_DIGIT (q, 1) >= 0) { if (div_mp (p, q, d, c, digits) == NO_MP) { errno = ERANGE; return (NO_MP); } (void) mul_mp (p, r, d, q, digits); (void) add_mp (p, r, r, c, digits); (void) mul_mp (p, c, b, q, digits); (void) add_mp (p, c, c, a, digits); (void) div_mp (p, c, c, r, digits); (void) mul_mp (p, d, a, q, digits); (void) sub_mp (p, d, b, d, digits); (void) div_mp (p, d, d, r, digits); } else { if (div_mp (p, q, c, d, digits) == NO_MP) { errno = ERANGE; return (NO_MP); } (void) mul_mp (p, r, c, q, digits); (void) add_mp (p, r, r, d, digits); (void) mul_mp (p, c, a, q, digits); (void) add_mp (p, c, c, b, digits); (void) div_mp (p, c, c, r, digits); (void) mul_mp (p, d, b, q, digits); (void) sub_mp (p, d, d, a, digits); (void) div_mp (p, d, d, r, digits); } MOVE_MP (a, c, digits); MOVE_MP (b, d, digits); stack_pointer = pop_sp; return (a); } /** @brief Set "r" I "i" to sqrt ("r" I "i"). @param p Node in syntax tree. @param r Multiprecision real part. @param i Multiprecision imaginary part. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *csqrt_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); if (IS_ZERO_MP (re) && IS_ZERO_MP (im)) { SET_MP_ZERO (re, digits_g); SET_MP_ZERO (im, digits_g); } else { MP_T *c1, *t, *x, *y, *u, *v, *w; STACK_MP (c1, p, digits_g); STACK_MP (t, p, digits_g); STACK_MP (x, p, digits_g); STACK_MP (y, p, digits_g); STACK_MP (u, p, digits_g); STACK_MP (v, p, digits_g); STACK_MP (w, p, digits_g); (void) set_mp_short (c1, (MP_T) 1, 0, digits_g); MOVE_MP (x, re, digits_g); MOVE_MP (y, im, digits_g); MP_DIGIT (x, 1) = ABS (MP_DIGIT (x, 1)); MP_DIGIT (y, 1) = ABS (MP_DIGIT (y, 1)); (void) sub_mp (p, w, x, y, digits_g); if (MP_DIGIT (w, 1) >= 0) { (void) div_mp (p, t, y, x, digits_g); (void) mul_mp (p, v, t, t, digits_g); (void) add_mp (p, u, c1, v, digits_g); (void) sqrt_mp (p, v, u, digits_g); (void) add_mp (p, u, c1, v, digits_g); (void) half_mp (p, v, u, digits_g); (void) sqrt_mp (p, u, v, digits_g); (void) sqrt_mp (p, v, x, digits_g); (void) mul_mp (p, w, u, v, digits_g); } else { (void) div_mp (p, t, x, y, digits_g); (void) mul_mp (p, v, t, t, digits_g); (void) add_mp (p, u, c1, v, digits_g); (void) sqrt_mp (p, v, u, digits_g); (void) add_mp (p, u, t, v, digits_g); (void) half_mp (p, v, u, digits_g); (void) sqrt_mp (p, u, v, digits_g); (void) sqrt_mp (p, v, y, digits_g); (void) mul_mp (p, w, u, v, digits_g); } if (MP_DIGIT (re, 1) >= 0) { MOVE_MP (re, w, digits_g); (void) add_mp (p, u, w, w, digits_g); (void) div_mp (p, im, im, u, digits_g); } else { if (MP_DIGIT (im, 1) < 0) { MP_DIGIT (w, 1) = -MP_DIGIT (w, 1); } (void) add_mp (p, v, w, w, digits_g); (void) div_mp (p, re, im, v, digits_g); MOVE_MP (im, w, digits_g); } } (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (r); } /** @brief Set "r" I "i" to exp("r" I "i"). @param p Node in syntax tree. @param r Multiprecision real part. @param i Multiprecision imaginary part. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *cexp_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im, *u; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); STACK_MP (u, p, digits_g); (void) exp_mp (p, u, re, digits_g); (void) cos_mp (p, re, im, digits_g); (void) sin_mp (p, im, im, digits_g); (void) mul_mp (p, re, re, u, digits_g); (void) mul_mp (p, im, im, u, digits_g); (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (r); } /** @brief Set "r" I "i" to ln ("r" I "i"). @param p Node in syntax tree. @param r Multiprecision real part. @param i Multiprecision imaginary part. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *cln_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im, *u, *v, *s, *t; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); STACK_MP (s, p, digits_g); STACK_MP (t, p, digits_g); STACK_MP (u, p, digits_g); STACK_MP (v, p, digits_g); MOVE_MP (u, re, digits_g); MOVE_MP (v, im, digits_g); (void) hypot_mp (p, s, u, v, digits_g); MOVE_MP (u, re, digits_g); MOVE_MP (v, im, digits_g); (void) atan2_mp (p, t, u, v, digits_g); (void) ln_mp (p, re, s, digits_g); MOVE_MP (im, t, digits_g); (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (r); } /** @brief Set "r" I "i" to sin ("r" I "i"). @param p Node in syntax tree. @param r Multiprecision real part. @param i Multiprecision imaginary part. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *csin_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im, *s, *c, *sh, *ch; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); STACK_MP (s, p, digits_g); STACK_MP (c, p, digits_g); STACK_MP (sh, p, digits_g); STACK_MP (ch, p, digits_g); if (IS_ZERO_MP (im)) { (void) sin_mp (p, re, re, digits_g); SET_MP_ZERO (im, digits_g); } else { (void) sin_mp (p, s, re, digits_g); (void) cos_mp (p, c, re, digits_g); (void) hyp_mp (p, sh, ch, im, digits_g); (void) mul_mp (p, re, s, ch, digits_g); (void) mul_mp (p, im, c, sh, digits_g); } (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (r); } /** @brief Set "r" I "i" to cos ("r" I "i"). @param p Node in syntax tree. @param r Multiprecision real part. @param i Multiprecision imaginary part. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *ccos_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im, *s, *c, *sh, *ch; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); STACK_MP (s, p, digits_g); STACK_MP (c, p, digits_g); STACK_MP (sh, p, digits_g); STACK_MP (ch, p, digits_g); if (IS_ZERO_MP (im)) { (void) cos_mp (p, re, re, digits_g); SET_MP_ZERO (im, digits_g); } else { (void) sin_mp (p, s, re, digits_g); (void) cos_mp (p, c, re, digits_g); (void) hyp_mp (p, sh, ch, im, digits_g); MP_DIGIT (sh, 1) = -MP_DIGIT (sh, 1); (void) mul_mp (p, re, c, ch, digits_g); (void) mul_mp (p, im, s, sh, digits_g); } (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (r); } /** @brief Set "r" I "i" to tan ("r" I "i"). @param p Node in syntax tree. @param r Multiprecision real part. @param i Multiprecision imaginary part. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *ctan_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *s, *t, *u, *v; RESET_ERRNO; STACK_MP (s, p, digits); STACK_MP (t, p, digits); STACK_MP (u, p, digits); STACK_MP (v, p, digits); MOVE_MP (u, r, digits); MOVE_MP (v, i, digits); (void) csin_mp (p, u, v, digits); MOVE_MP (s, u, digits); MOVE_MP (t, v, digits); MOVE_MP (u, r, digits); MOVE_MP (v, i, digits); (void) ccos_mp (p, u, v, digits); (void) cdiv_mp (p, s, t, u, v, digits); MOVE_MP (r, s, digits); MOVE_MP (i, t, digits); stack_pointer = pop_sp; return (r); } /** @brief Set "r" I "i" to asin ("r" I "i"). @param p Node in syntax tree. @param r Multiprecision real part. @param i Multiprecision imaginary part. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *casin_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); if (IS_ZERO_MP (im)) { (void) asin_mp (p, re, re, digits_g); } else { MP_T *c1, *u, *v, *a, *b; STACK_MP (c1, p, digits_g); (void) set_mp_short (c1, (MP_T) 1, 0, digits_g); STACK_MP (u, p, digits_g); STACK_MP (v, p, digits_g); STACK_MP (a, p, digits_g); STACK_MP (b, p, digits_g); /* u=sqrt((r+1)^2+i^2), v=sqrt((r-1)^2+i^2) */ (void) add_mp (p, a, re, c1, digits_g); (void) sub_mp (p, b, re, c1, digits_g); (void) hypot_mp (p, u, a, im, digits_g); (void) hypot_mp (p, v, b, im, digits_g); /* a=(u+v)/2, b=(u-v)/2 */ (void) add_mp (p, a, u, v, digits_g); (void) half_mp (p, a, a, digits_g); (void) sub_mp (p, b, u, v, digits_g); (void) half_mp (p, b, b, digits_g); /* r=asin(b), i=ln(a+sqrt(a^2-1)) */ (void) mul_mp (p, u, a, a, digits_g); (void) sub_mp (p, u, u, c1, digits_g); (void) sqrt_mp (p, u, u, digits_g); (void) add_mp (p, u, a, u, digits_g); (void) ln_mp (p, im, u, digits_g); (void) asin_mp (p, re, b, digits_g); } (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (re); } /** @brief Set "r" I "i" to acos ("r" I "i"). @param p Node in syntax tree. @param r Multiprecision real part. @param i Multiprecision imaginary part. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *cacos_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); if (IS_ZERO_MP (im)) { (void) acos_mp (p, re, re, digits_g); } else { MP_T *c1, *u, *v, *a, *b; STACK_MP (c1, p, digits_g); (void) set_mp_short (c1, (MP_T) 1, 0, digits_g); STACK_MP (u, p, digits_g); STACK_MP (v, p, digits_g); STACK_MP (a, p, digits_g); STACK_MP (b, p, digits_g); /* u=sqrt((r+1)^2+i^2), v=sqrt((r-1)^2+i^2) */ (void) add_mp (p, a, re, c1, digits_g); (void) sub_mp (p, b, re, c1, digits_g); (void) hypot_mp (p, u, a, im, digits_g); (void) hypot_mp (p, v, b, im, digits_g); /* a=(u+v)/2, b=(u-v)/2 */ (void) add_mp (p, a, u, v, digits_g); (void) half_mp (p, a, a, digits_g); (void) sub_mp (p, b, u, v, digits_g); (void) half_mp (p, b, b, digits_g); /* r=acos(b), i=-ln(a+sqrt(a^2-1)) */ (void) mul_mp (p, u, a, a, digits_g); (void) sub_mp (p, u, u, c1, digits_g); (void) sqrt_mp (p, u, u, digits_g); (void) add_mp (p, u, a, u, digits_g); (void) ln_mp (p, im, u, digits_g); MP_DIGIT (im, 1) = -MP_DIGIT (im, 1); (void) acos_mp (p, re, b, digits_g); } (void) shorten_mp (p, r, digits, re, digits_g); (void) shorten_mp (p, i, digits, im, digits_g); stack_pointer = pop_sp; return (re); } /** @brief Set "r" I "i" to atan ("r" I "i"). @param p Node in syntax tree. @param r Multiprecision real part. @param i Multiprecision imaginary part. @param digits Precision in mp-digits. @return Real part of result. **/ MP_T *catan_mp (NODE_T * p, MP_T * r, MP_T * i, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *re, *im, *u, *v; int digits_g = FUN_DIGITS (digits); STACK_MP (re, p, digits_g); STACK_MP (im, p, digits_g); (void) lengthen_mp (p, re, digits_g, r, digits); (void) lengthen_mp (p, im, digits_g, i, digits); STACK_MP (u, p, digits_g); STACK_MP (v, p, digits_g); if (IS_ZERO_MP (im)) { (void) atan_mp (p, u, re, digits_g); SET_MP_ZERO (v, digits_g); } else { MP_T *c1, *a, *b; STACK_MP (c1, p, digits_g); (void) set_mp_short (c1, (MP_T) 1, 0, digits_g); STACK_MP (a, p, digits_g); STACK_MP (b, p, digits_g); /* a=sqrt(r^2+(i+1)^2), b=sqrt(r^2+(i-1)^2) */ (void) add_mp (p, a, im, c1, digits_g); (void) sub_mp (p, b, im, c1, digits_g); (void) hypot_mp (p, u, re, a, digits_g); (void) hypot_mp (p, v, re, b, digits_g); /* im=ln(a/b)/4 */ (void) div_mp (p, u, u, v, digits_g); (void) ln_mp (p, u, u, digits_g); (void) half_mp (p, v, u, digits_g); /* re=atan(2r/(1-r^2-i^2)) */ (void) mul_mp (p, a, re, re, digits_g); (void) mul_mp (p, b, im, im, digits_g); (void) sub_mp (p, u, c1, a, digits_g); (void) sub_mp (p, b, u, b, digits_g); (void) add_mp (p, a, re, re, digits_g); (void) div_mp (p, a, a, b, digits_g); (void) atan_mp (p, u, a, digits_g); (void) half_mp (p, u, u, digits_g); } (void) shorten_mp (p, r, digits, u, digits_g); (void) shorten_mp (p, i, digits, v, digits_g); stack_pointer = pop_sp; return (re); } /** @brief Comparison of "x" and "y". @param p Node in syntax tree. @param z Comparison result. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Whether x = y. **/ void eq_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) == 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /** @brief Comparison of "x" and "y". @param p Node in syntax tree. @param z Comparison result. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Whether x != y. **/ void ne_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) != 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /** @brief Comparison of "x" and "y". @param p Node in syntax tree. @param z Comparison result. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Whether x < y. **/ void lt_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) < 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /** @brief Comparison of "x" and "y". @param p Node in syntax tree. @param z Comparison result. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Whether x <= y. **/ void le_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) <= 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /** @brief Comparison of "x" and "y". @param p Node in syntax tree. @param z Comparison result. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Whether x > y. **/ void gt_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) > 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /** @brief Comparison of "x" and "y". @param p Node in syntax tree. @param z Comparison result. @param x Multiprecision number. @param y Multiprecision number. @param digits Precision in mp-digits. @return Whether x >= y. **/ void ge_mp (NODE_T * p, A68_BOOL * z, MP_T * x, MP_T * y, int digits) { ADDR_T pop_sp = stack_pointer; MP_T *v; STACK_MP (v, p, digits); (void) sub_mp (p, v, x, y, digits); STATUS (z) = INIT_MASK; VALUE (z) = (MP_DIGIT (v, 1) >= 0 ? A68_TRUE : A68_FALSE); stack_pointer = pop_sp; } /** @brief Rounding. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Round (x). **/ MP_T *round_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { MP_T *y; STACK_MP (y, p, digits); (void) set_mp_short (y, (MP_T) (MP_RADIX / 2), -1, digits); if (MP_DIGIT (x, 1) >= 0) { (void) add_mp (p, z, x, y, digits); (void) trunc_mp (p, z, z, digits); } else { (void) sub_mp (p, z, x, y, digits); (void) trunc_mp (p, z, z, digits); } MP_STATUS (z) = (MP_T) INIT_MASK; return (z); } /** @brief Rounding. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return Entier (x). **/ MP_T *entier_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { if (MP_DIGIT (x, 1) >= 0) { (void) trunc_mp (p, z, x, digits); } else { MP_T *y; STACK_MP (y, p, digits); MOVE_MP (y, z, digits); (void) trunc_mp (p, z, x, digits); (void) sub_mp (p, y, y, z, digits); if (MP_DIGIT (y, 1) != 0) { (void) set_mp_short (y, (MP_T) 1, 0, digits); (void) sub_mp (p, z, z, y, digits); } } MP_STATUS (z) = (MP_T) INIT_MASK; return (z); } /** @brief Absolute value. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return |x| **/ MP_T *abs_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { (void) p; if (x != z) { MOVE_MP (z, x, digits); } MP_DIGIT (z, 1) = fabs (MP_DIGIT (z, 1)); MP_STATUS (z) = (MP_T) INIT_MASK; return (z); } /** @brief Change sign. @param p Node in syntax tree. @param z Multiprecision number. @param x Multiprecision number. @param digits Precision in mp-digits. @return -x **/ MP_T *minus_mp (NODE_T * p, MP_T * z, MP_T * x, int digits) { (void) p; if (x != z) { MOVE_MP (z, x, digits); } MP_DIGIT (z, 1) = -MP_DIGIT (z, 1); MP_STATUS (z) = (MP_T) INIT_MASK; return (z); } algol68g-2.8/source/a68g-config.h0000644000175000001440000002436712224301313013407 00000000000000/** @file a68g-config.h @author GNU autoheader @brief Configuration file generated by autoheader **/ /* source/a68g-config.h. Generated from a68g-config.h.in by configure. */ /* source/a68g-config.h.in. Generated from configure.ac by autoheader. */ /* Define to 1 if `TIOCGWINSZ' requires . */ #define GWINSZ_IN_SYS_IOCTL 1 /* Define to 1 if you have the header file. */ #define HAVE_ASSERT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_CTYPE_H 1 /* Define this if curses was detected */ #define HAVE_CURSES 1 /* Define to 1 if you have the header file. */ #define HAVE_CURSES_H 1 /* Define to 1 if you have the header file, and it defines `DIR'. */ #define HAVE_DIRENT_H 1 /* Define this if a good DL installation was detected */ #define HAVE_DL 1 /* Define to 1 if you have the header file. */ #define HAVE_DLFCN_H 1 /* Define to 1 if you have the header file. */ #define HAVE_ERRNO_H 1 /* Define to 1 if you have the `exit' function. */ #define HAVE_EXIT 1 /* Define this if EXPORT_DYNAMIC is recognised */ #define HAVE_EXPORT_DYNAMIC 1 /* Define to 1 if you have the header file. */ #define HAVE_FCNTL_H 1 /* Define to 1 if you have the header file. */ #define HAVE_FLOAT_H 1 /* Define to 1 if you have the `fprintf' function. */ #define HAVE_FPRINTF 1 /* Define to 1 if you have the `free' function. */ #define HAVE_FREE 1 /* Define this if FreeBSD was detected */ /* #undef HAVE_FREEBSD */ /* Define this if GCC was detected */ #define HAVE_GCC 1 /* Define this if a good GNU GSL installation was detected */ #define HAVE_GNU_GSL 1 /* Define this if a good GNU plotutils installation was detected */ #define HAVE_GNU_PLOTUTILS 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_BLAS_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_COMPLEX_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_COMPLEX_MATH_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_ERRNO_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_FFT_COMPLEX_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_INTEGRATION_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_LINALG_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_MATH_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_MATRIX_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_PERMUTATION_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_SF_H 1 /* Define to 1 if you have the header file. */ #define HAVE_GSL_GSL_VECTOR_H 1 /* Define this if IEEE_754 compliant */ #define HAVE_IEEE_754 1 /* Define to 1 if you have the header file. */ #define HAVE_INTTYPES_H 1 /* Define to 1 if you have the `dl' library (-ldl). */ #define HAVE_LIBDL 1 /* Define to 1 if you have the `gsl' library (-lgsl). */ #define HAVE_LIBGSL 1 /* Define to 1 if you have the `gslcblas' library (-lgslcblas). */ #define HAVE_LIBGSLCBLAS 1 /* Define to 1 if you have the `m' library (-lm). */ #define HAVE_LIBM 1 /* Define to 1 if you have the `ncurses' library (-lncurses). */ #define HAVE_LIBNCURSES 1 /* Define to 1 if you have the `plot' library (-lplot). */ #define HAVE_LIBPLOT 1 /* Define to 1 if you have the `pq' library (-lpq). */ #define HAVE_LIBPQ 1 /* Define to 1 if you have the header file. */ #define HAVE_LIBPQ_FE_H 1 /* Define to 1 if you have the `pthread' library (-lpthread). */ #define HAVE_LIBPTHREAD 1 /* Define to 1 if you have the `readline' library (-lreadline). */ #define HAVE_LIBREADLINE 1 /* Define to 1 if you have the header file. */ #define HAVE_LIMITS_H 1 /* Define this if LINUX was detected */ #define HAVE_LINUX 1 /* Define to 1 if you have the `longjmp' function. */ #define HAVE_LONGJMP 1 /* Define this if DARWIN was detected */ /* #undef HAVE_MAC_OS_X */ /* Define to 1 if you have the `malloc' function. */ #define HAVE_MALLOC 1 /* Define to 1 if you have the header file. */ #define HAVE_MATH_H 1 /* Define to 1 if you have the `memcpy' function. */ #define HAVE_MEMCPY 1 /* Define to 1 if you have the `memmove' function. */ #define HAVE_MEMMOVE 1 /* Define to 1 if you have the header file. */ #define HAVE_MEMORY_H 1 /* Define to 1 if you have the `memset' function. */ #define HAVE_MEMSET 1 /* Define to 1 if you have the header file. */ /* #undef HAVE_NCURSES_CURSES_H */ /* Define to 1 if you have the header file, and it defines `DIR'. */ /* #undef HAVE_NDIR_H */ /* Define this if NetBSD was detected */ /* #undef HAVE_NETBSD */ /* Define to 1 if you have the header file. */ #define HAVE_NETDB_H 1 /* Define to 1 if you have the header file. */ #define HAVE_NETINET_IN_H 1 /* Define this if OpenBSD was detected */ /* #undef HAVE_OPENBSD */ /* Define this if /opt/local/pgsql/include was detected */ /* #undef HAVE_OPT_LOCAL_PGSQL_INCLUDE */ /* Define this if a good pthread installation was detected */ #define HAVE_PARALLEL_CLAUSE 1 /* Define this as PIC option */ #define HAVE_PIC "-fPIC" /* Define to 1 if you have the header file. */ #define HAVE_PLOT_H 1 /* Define this if a good PostgreSQL installation was detected */ #define HAVE_POSTGRESQL 1 /* Define to 1 if you have the `printf' function. */ #define HAVE_PRINTF 1 /* Define to 1 if you have the header file. */ #define HAVE_PTHREAD_H 1 /* Define this if readline was detected */ #define HAVE_READLINE 1 /* Define to 1 if you have the header file. */ #define HAVE_READLINE_HISTORY_H 1 /* Define to 1 if you have the header file. */ #define HAVE_READLINE_READLINE_H 1 /* Define to 1 if you have the header file. */ #define HAVE_REGEX_H 1 /* Define to 1 if you have the `setjmp' function. */ #define HAVE_SETJMP 1 /* Define to 1 if you have the header file. */ #define HAVE_SETJMP_H 1 /* Define to 1 if you have the `signal' function. */ #define HAVE_SIGNAL 1 /* Define to 1 if you have the header file. */ #define HAVE_SIGNAL_H 1 /* Define to 1 if you have the `snprintf' function. */ #define HAVE_SNPRINTF 1 /* Define to 1 if you have the header file. */ #define HAVE_STDARG_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STDDEF_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STDINT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STDIO_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STDLIB_H 1 /* Define to 1 if you have the `strcmp' function. */ #define HAVE_STRCMP 1 /* Define to 1 if you have the header file. */ #define HAVE_STRINGS_H 1 /* Define to 1 if you have the header file. */ #define HAVE_STRING_H 1 /* Define to 1 if you have the `strncmp' function. */ #define HAVE_STRNCMP 1 /* Define to 1 if you have the `strncpy' function. */ #define HAVE_STRNCPY 1 /* Define to 1 if you have the header file, and it defines `DIR'. */ /* #undef HAVE_SYS_DIR_H */ /* Define to 1 if you have the header file. */ #define HAVE_SYS_IOCTL_H 1 /* Define to 1 if you have the header file, and it defines `DIR'. */ /* #undef HAVE_SYS_NDIR_H */ /* Define to 1 if you have the header file. */ #define HAVE_SYS_RESOURCE_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_SOCKET_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_STAT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_TIME_H 1 /* Define to 1 if you have the header file. */ #define HAVE_SYS_TYPES_H 1 /* Define to 1 if you have that is POSIX.1 compatible. */ #define HAVE_SYS_WAIT_H 1 /* Define to 1 if you have the header file. */ #define HAVE_TERMIOS_H 1 /* Define to 1 if you have the header file. */ #define HAVE_TIME_H 1 /* Define this if user wants to tune for a specific CPU */ /* #undef HAVE_TUNING */ /* Define to 1 if you have the header file. */ #define HAVE_UNISTD_H 1 /* Define this if untested OS was detected */ /* #undef HAVE_UNTESTED */ /* Define this if /usr/local/pgsql/include was detected */ #define HAVE_USR_LOCAL_PGSQL_INCLUDE 1 /* Define this if /usr/pkg/pgsql/include was detected */ /* #undef HAVE_USR_PKG_PGSQL_INCLUDE */ /* Define to 1 if assertions should be disabled. */ /* #undef NDEBUG */ /* Define to 1 if your C compiler doesn't accept -c and -o together. */ /* #undef NO_MINUS_C_MINUS_O */ /* Name of package */ #define PACKAGE "algol68g" /* Define to the address where bug reports for this package should be sent. */ #define PACKAGE_BUGREPORT "Marcel van der Veer " /* Define to the full name of this package. */ #define PACKAGE_NAME "algol68g" /* Define to the full name and version of this package. */ #define PACKAGE_STRING "algol68g 2.8" /* Define to the one symbol short name of this package. */ #define PACKAGE_TARNAME "algol68g" /* Define to the version of this package. */ #define PACKAGE_VERSION "2.8" /* Define to 1 if you have the ANSI C header files. */ #define STDC_HEADERS 1 /* Version number of package */ #define VERSION "2.8" /* Define to 1 if type `char' is unsigned and you are not using gcc. */ #ifndef __CHAR_UNSIGNED__ /* # undef __CHAR_UNSIGNED__ */ #endif /* Define this if we have no __mode_t */ /* #undef __mode_t */ /* Define this if we have no __off_t */ /* #undef __off_t */ /* Define this if we have no __pid_t */ /* #undef __pid_t */ /* Define to `int' if does not define. */ /* #undef mode_t */ /* Define to `unsigned int' if does not define. */ /* #undef size_t */ /* Define to `int' if does not define. */ /* #undef ssize_t */ /* Define to the type of an unsigned integer type of width exactly 16 bits if such a type exists and the standard includes do not define it. */ /* #undef uint16_t */ algol68g-2.8/source/gsl.c0000644000175000001440000022527312113475670012175 00000000000000/** @file gsl.c @author J. Marcel van der Veer. @brief Vector, matrix and FFT support through GSL. @section Copyright This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2013 J. Marcel van der Veer . @section Description 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 . **/ #include "a68g.h" #if defined HAVE_GNU_GSL static NODE_T *error_node = NO_NODE; #define VECTOR_OFFSET(a, t)\ ((LWB (t) * SPAN (t) - SHIFT (t) + SLICE_OFFSET (a)) * ELEM_SIZE (a) + FIELD_OFFSET (a)) #define MATRIX_OFFSET(a, t1, t2)\ ((LWB (t1) * SPAN (t1) - SHIFT (t1) + LWB (t2) * SPAN (t2) - SHIFT (t2) + SLICE_OFFSET (a)) * ELEM_SIZE (a) + FIELD_OFFSET (a)) /** @brief Set permutation vector element - function fails in gsl. @param p Permutation vector. @param i Element iindex. @param j Element value. **/ void gsl_permutation_set (const gsl_permutation * p, const size_t i, const size_t j) { DATA (p)[i] = j; } /** @brief Map GSL error handler onto a68g error handler. @param reason Error text. @param file Gsl file where error occured. @param line Line in above file. @param gsl_errno Gsl error number. **/ void torrix_error_handler (const char *reason, const char *file, int line, int gsl_errno) { if (line != 0) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s in line %d of file %s", reason, line, file) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s", reason) >= 0); } diagnostic_node (A68_RUNTIME_ERROR, error_node, ERROR_TORRIX, edit_line, gsl_strerror (gsl_errno)); exit_genie (error_node, A68_RUNTIME_ERROR); } /** @brief Detect math errors, mainly in BLAS functions. @param rc Return code from function. **/ static void torrix_test_error (int rc) { if (rc != 0) { torrix_error_handler ("math error", "", 0, rc); } } /** @brief Pop [] INT on the stack as gsl_permutation. @param p Node in syntax tree. @param get Whether to get elements from row in the stack. @return Gsl_permutation_complex. **/ static gsl_permutation *pop_permutation (NODE_T * p, BOOL_T get) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int len, inc, iindex, k; BYTE_T *base; gsl_permutation *v; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROW_INT)); GET_DESCRIPTOR (arr, tup, &desc); len = ROW_SIZE (tup); v = gsl_permutation_alloc ((size_t) len); if (get && len > 0) { base = DEREF (BYTE_T, &ARRAY (arr)); iindex = VECTOR_OFFSET (arr, tup); inc = SPAN (tup) * ELEM_SIZE (arr); for (k = 0; k < len; k++, iindex += inc) { A68_INT *x = (A68_INT *) (base + iindex); CHECK_INIT (p, INITIALISED (x), MODE (INT)); gsl_permutation_set (v, (size_t) k, (size_t) VALUE (x)); } } return (v); } /** @brief Push gsl_permutation on the stack as [] INT. @param p Node in syntax tree. @param v Permutation. **/ static void push_permutation (NODE_T * p, gsl_permutation * v) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int len, inc, iindex, k; BYTE_T *base; len = (int) (SIZE (v)); desc = heap_generator (p, MODE (ROW_INT), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_INT), len * SIZE (MODE (INT))); DIM (&arr) = 1; MOID (&arr) = MODE (INT); ELEM_SIZE (&arr) = SIZE (MODE (INT)); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SPAN (&tup) = 1; SHIFT (&tup) = LWB (&tup); K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_INT *x = (A68_INT *) (base + iindex); STATUS (x) = INIT_MASK; VALUE (x) = (int) gsl_permutation_get (v, (size_t) k); } PUSH_REF (p, desc); } /** @brief Pop [] REAL on the stack as gsl_vector. @param p Node in syntax tree. @param get Whether to get elements from row in the stack. @return Gsl_vector_complex. **/ static gsl_vector *pop_vector (NODE_T * p, BOOL_T get) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int len, inc, iindex, k; BYTE_T *base; gsl_vector *v; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROW_REAL)); GET_DESCRIPTOR (arr, tup, &desc); len = ROW_SIZE (tup); v = gsl_vector_alloc ((size_t) len); if (get && len > 0) { base = DEREF (BYTE_T, &ARRAY (arr)); iindex = VECTOR_OFFSET (arr, tup); inc = SPAN (tup) * ELEM_SIZE (arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *x = (A68_REAL *) (base + iindex); CHECK_INIT (p, INITIALISED (x), MODE (REAL)); gsl_vector_set (v, (size_t) k, VALUE (x)); } } return (v); } /** @brief Push gsl_vector on the stack as [] REAL. @param p Node in syntax tree. @param v Vector. **/ static void push_vector (NODE_T * p, gsl_vector * v) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int len, inc, iindex, k; BYTE_T *base; len = (int) (SIZE (v)); desc = heap_generator (p, MODE (ROW_REAL), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_REAL), len * SIZE (MODE (REAL))); DIM (&arr) = 1; MOID (&arr) = MODE (REAL); ELEM_SIZE (&arr) = SIZE (MODE (REAL)); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SPAN (&tup) = 1; SHIFT (&tup) = LWB (&tup); K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *x = (A68_REAL *) (base + iindex); STATUS (x) = INIT_MASK; VALUE (x) = gsl_vector_get (v, (size_t) k); CHECK_REAL_REPRESENTATION (p, VALUE (x)); } PUSH_REF (p, desc); } /** @brief Pop [,] REAL on the stack as gsl_matrix. @param p Node in syntax tree. @param get Whether to get elements from row in the stack. @return Gsl_matrix. **/ static gsl_matrix *pop_matrix (NODE_T * p, BOOL_T get) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup1, *tup2; int len1, len2, inc1, inc2, iindex1, iindex2, k1, k2; BYTE_T *base; gsl_matrix *a; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROWROW_REAL)); GET_DESCRIPTOR (arr, tup1, &desc); tup2 = &(tup1[1]); len1 = ROW_SIZE (tup1); len2 = ROW_SIZE (tup2); a = gsl_matrix_alloc ((size_t) len1, (size_t) len2); if (get && (len1 * len2 > 0)) { base = DEREF (BYTE_T, &ARRAY (arr)); iindex1 = MATRIX_OFFSET (arr, tup1, tup2); inc1 = SPAN (tup1) * ELEM_SIZE (arr); inc2 = SPAN (tup2) * ELEM_SIZE (arr); for (k1 = 0; k1 < len1; k1++, iindex1 += inc1) { for (k2 = 0, iindex2 = iindex1; k2 < len2; k2++, iindex2 += inc2) { A68_REAL *x = (A68_REAL *) (base + iindex2); CHECK_INIT (p, INITIALISED (x), MODE (REAL)); gsl_matrix_set (a, (size_t) k1, (size_t) k2, VALUE (x)); } } } return (a); } /** @brief Push gsl_matrix on the stack as [,] REAL. @param p Node in syntax tree. @param a Matrix. **/ static void push_matrix (NODE_T * p, gsl_matrix * a) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup1, tup2; int len1, len2, inc1, inc2, iindex1, iindex2, k1, k2; BYTE_T *base; len1 = (int) (SIZE1 (a)); len2 = (int) (SIZE2 (a)); desc = heap_generator (p, MODE (ROWROW_REAL), SIZE_AL (A68_ARRAY) + 2 * SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROWROW_REAL), len1 * len2 * SIZE (MODE (REAL))); DIM (&arr) = 2; MOID (&arr) = MODE (REAL); ELEM_SIZE (&arr) = SIZE (MODE (REAL)); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup1) = 1; UPB (&tup1) = len1; SPAN (&tup1) = 1; SHIFT (&tup1) = LWB (&tup1); K (&tup1) = 0; LWB (&tup2) = 1; UPB (&tup2) = len2; SPAN (&tup2) = ROW_SIZE (&tup1); SHIFT (&tup2) = LWB (&tup2) * SPAN (&tup2); K (&tup2) = 0; PUT_DESCRIPTOR2 (arr, tup1, tup2, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex1 = MATRIX_OFFSET (&arr, &tup1, &tup2); inc1 = SPAN (&tup1) * ELEM_SIZE (&arr); inc2 = SPAN (&tup2) * ELEM_SIZE (&arr); for (k1 = 0; k1 < len1; k1++, iindex1 += inc1) { for (k2 = 0, iindex2 = iindex1; k2 < len2; k2++, iindex2 += inc2) { A68_REAL *x = (A68_REAL *) (base + iindex2); STATUS (x) = INIT_MASK; VALUE (x) = gsl_matrix_get (a, (size_t) k1, (size_t) k2); CHECK_REAL_REPRESENTATION (p, VALUE (x)); } } PUSH_REF (p, desc); } /** @brief Pop [] COMPLEX on the stack as gsl_vector_complex. @param p Node in syntax tree. @param get Whether to get elements from row in the stack. @return Gsl_vector_complex. **/ static gsl_vector_complex *pop_vector_complex (NODE_T * p, BOOL_T get) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int len, inc, iindex, k; BYTE_T *base; gsl_vector_complex *v; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROW_COMPLEX)); GET_DESCRIPTOR (arr, tup, &desc); len = ROW_SIZE (tup); v = gsl_vector_complex_alloc ((size_t) len); if (get && len > 0) { base = DEREF (BYTE_T, &ARRAY (arr)); iindex = VECTOR_OFFSET (arr, tup); inc = SPAN (tup) * ELEM_SIZE (arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *re = (A68_REAL *) (base + iindex); A68_REAL *im = (A68_REAL *) (base + iindex + SIZE (MODE (REAL))); gsl_complex z; CHECK_INIT (p, INITIALISED (re), MODE (COMPLEX)); CHECK_INIT (p, INITIALISED (im), MODE (COMPLEX)); GSL_SET_COMPLEX (&z, VALUE (re), VALUE (im)); gsl_vector_complex_set (v, (size_t) k, z); } } return (v); } /** @brief Push gsl_vector_complex on the stack as [] COMPLEX. @param p Node in syntax tree. @param v Vector. **/ static void push_vector_complex (NODE_T * p, gsl_vector_complex * v) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int len, inc, iindex, k; BYTE_T *base; len = (int) (SIZE (v)); desc = heap_generator (p, MODE (ROW_COMPLEX), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_COMPLEX), len * 2 * SIZE (MODE (REAL))); DIM (&arr) = 1; MOID (&arr) = MODE (COMPLEX); ELEM_SIZE (&arr) = 2 * SIZE (MODE (REAL)); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SPAN (&tup) = 1; SHIFT (&tup) = LWB (&tup); K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *re = (A68_REAL *) (base + iindex); A68_REAL *im = (A68_REAL *) (base + iindex + SIZE (MODE (REAL))); gsl_complex z = gsl_vector_complex_get (v, (size_t) k); STATUS (re) = INIT_MASK; VALUE (re) = GSL_REAL (z); STATUS (im) = INIT_MASK; VALUE (im) = GSL_IMAG (z); CHECK_COMPLEX_REPRESENTATION (p, VALUE (re), VALUE (im)); } PUSH_REF (p, desc); } /** @brief Pop [,] COMPLEX on the stack as gsl_matrix_complex. @param p Node in syntax tree. @param get Whether to get elements from row in the stack. @return Gsl_matrix_complex. **/ static gsl_matrix_complex *pop_matrix_complex (NODE_T * p, BOOL_T get) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup1, *tup2; int len1, len2; gsl_matrix_complex *a; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROWROW_COMPLEX)); GET_DESCRIPTOR (arr, tup1, &desc); tup2 = &(tup1[1]); len1 = ROW_SIZE (tup1); len2 = ROW_SIZE (tup2); a = gsl_matrix_complex_alloc ((size_t) len1, (size_t) len2); if (get && (len1 * len2 > 0)) { BYTE_T *base = DEREF (BYTE_T, &ARRAY (arr)); int iindex1 = MATRIX_OFFSET (arr, tup1, tup2); int inc1 = SPAN (tup1) * ELEM_SIZE (arr), inc2 = SPAN (tup2) * ELEM_SIZE (arr), k1; for (k1 = 0; k1 < len1; k1++, iindex1 += inc1) { int iindex2, k2; for (k2 = 0, iindex2 = iindex1; k2 < len2; k2++, iindex2 += inc2) { A68_REAL *re = (A68_REAL *) (base + iindex2); A68_REAL *im = (A68_REAL *) (base + iindex2 + SIZE (MODE (REAL))); gsl_complex z; CHECK_INIT (p, INITIALISED (re), MODE (COMPLEX)); CHECK_INIT (p, INITIALISED (im), MODE (COMPLEX)); GSL_SET_COMPLEX (&z, VALUE (re), VALUE (im)); gsl_matrix_complex_set (a, (size_t) k1, (size_t) k2, z); } } } return (a); } /** @brief Push gsl_matrix_complex on the stack as [,] COMPLEX. @param p Node in syntax tree. @param a Matrix. **/ static void push_matrix_complex (NODE_T * p, gsl_matrix_complex * a) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup1, tup2; int len1, len2, inc1, inc2, iindex1, iindex2, k1, k2; BYTE_T *base; len1 = (int) (SIZE1 (a)); len2 = (int) (SIZE2 (a)); desc = heap_generator (p, MODE (ROWROW_COMPLEX), SIZE_AL (A68_ARRAY) + 2 * SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROWROW_COMPLEX), len1 * len2 * 2 * SIZE (MODE (REAL))); DIM (&arr) = 2; MOID (&arr) = MODE (COMPLEX); ELEM_SIZE (&arr) = 2 * SIZE (MODE (REAL)); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup1) = 1; UPB (&tup1) = len1; SPAN (&tup1) = 1; SHIFT (&tup1) = LWB (&tup1); K (&tup1) = 0; LWB (&tup2) = 1; UPB (&tup2) = len2; SPAN (&tup2) = ROW_SIZE (&tup1); SHIFT (&tup2) = LWB (&tup2) * SPAN (&tup2); K (&tup2) = 0; PUT_DESCRIPTOR2 (arr, tup1, tup2, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex1 = MATRIX_OFFSET (&arr, &tup1, &tup2); inc1 = SPAN (&tup1) * ELEM_SIZE (&arr); inc2 = SPAN (&tup2) * ELEM_SIZE (&arr); for (k1 = 0; k1 < len1; k1++, iindex1 += inc1) { for (k2 = 0, iindex2 = iindex1; k2 < len2; k2++, iindex2 += inc2) { A68_REAL *re = (A68_REAL *) (base + iindex2); A68_REAL *im = (A68_REAL *) (base + iindex2 + SIZE (MODE (REAL))); gsl_complex z = gsl_matrix_complex_get (a, (size_t) k1, (size_t) k2); STATUS (re) = INIT_MASK; VALUE (re) = GSL_REAL (z); STATUS (im) = INIT_MASK; VALUE (im) = GSL_IMAG (z); CHECK_COMPLEX_REPRESENTATION (p, VALUE (re), VALUE (im)); } } PUSH_REF (p, desc); } /** @brief Generically perform operation and assign result (+:=, -:=, ...) . @param p Node in syntax tree. @param m Mode of REF [...] M. @param n Mode of right operand M. @param op Operation to be performed. **/ static void op_ab (NODE_T * p, MOID_T * m, MOID_T * n, GPROC * op) { ADDR_T parm_size = SIZE (m) + SIZE (n); A68_REF dst, src, *save = (A68_REF *) STACK_OFFSET (-parm_size); error_node = p; dst = *save; CHECK_REF (p, dst, m); *save = *DEREF (A68_ROW, &dst); STATUS (&src) = (STATUS_MASK) (INIT_MASK | IN_STACK_MASK); OFFSET (&src) = stack_pointer - parm_size; (*op) (p); genie_store (p, n, &dst, &src); *save = dst; } /** @brief PROC vector echo = ([] REAL) [] REAL @param p Node in syntax tree. **/ void genie_vector_echo (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; error_node = p; u = pop_vector (p, A68_TRUE); push_vector (p, u); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief PROC matrix echo = ([,] REAL) [,] REAL @param p Node in syntax tree. **/ void genie_matrix_echo (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; error_node = p; a = pop_matrix (p, A68_TRUE); push_matrix (p, a); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } /** @brief PROC complex vector echo = ([] COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_echo (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; error_node = p; u = pop_vector_complex (p, A68_TRUE); push_vector_complex (p, u); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief PROC complex matrix echo = ([,] COMPLEX) [,] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_echo (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *a; error_node = p; a = pop_matrix_complex (p, A68_TRUE); push_matrix_complex (p, a); gsl_matrix_complex_free (a); (void) gsl_set_error_handler (save_handler); } /** @brief OP - = ([] REAL) [] REAL @param p Node in syntax tree. **/ void genie_vector_minus (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; int rc; error_node = p; u = pop_vector (p, A68_TRUE); rc = gsl_vector_scale (u, -1); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP - = ([,] REAL) [,] REAL @param p Node in syntax tree. **/ void genie_matrix_minus (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; int rc; error_node = p; a = pop_matrix (p, A68_TRUE); rc = gsl_matrix_scale (a, -1); torrix_test_error (rc); push_matrix (p, a); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } /** @brief OP T = ([,] REAL) [,] REAL @param p Node in syntax tree. **/ void genie_matrix_transpose (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; int rc; error_node = p; a = pop_matrix (p, A68_TRUE); rc = gsl_matrix_transpose (a); torrix_test_error (rc); push_matrix (p, a); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } /** @brief OP T = ([,] COMPLEX) [,] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_transpose (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *a; int rc; error_node = p; a = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_transpose (a); torrix_test_error (rc); push_matrix_complex (p, a); gsl_matrix_complex_free (a); (void) gsl_set_error_handler (save_handler); } /** @brief OP INV = ([,] REAL) [,] REAL @param p Node in syntax tree. **/ void genie_matrix_inv (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix *u, *inv; int rc, signum; error_node = p; u = pop_matrix (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_LU_decomp (u, q, &signum); torrix_test_error (rc); inv = gsl_matrix_alloc (SIZE1 (u), SIZE2 (u)); rc = gsl_linalg_LU_invert (u, q, inv); torrix_test_error (rc); push_matrix (p, inv); gsl_matrix_free (inv); gsl_matrix_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief OP INV = ([,] COMPLEX) [,] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_inv (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix_complex *u, *inv; int rc, signum; error_node = p; u = pop_matrix_complex (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_complex_LU_decomp (u, q, &signum); torrix_test_error (rc); inv = gsl_matrix_complex_alloc (SIZE1 (u), SIZE2 (u)); rc = gsl_linalg_complex_LU_invert (u, q, inv); torrix_test_error (rc); push_matrix_complex (p, inv); gsl_matrix_complex_free (inv); gsl_matrix_complex_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief OP DET = ([,] REAL) REAL @param p Node in syntax tree. **/ void genie_matrix_det (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix *u; int rc, signum; error_node = p; u = pop_matrix (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_LU_decomp (u, q, &signum); torrix_test_error (rc); PUSH_PRIMITIVE (p, gsl_linalg_LU_det (u, signum), A68_REAL); gsl_matrix_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief OP DET = ([,] COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_det (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix_complex *u; int rc, signum; gsl_complex det; error_node = p; u = pop_matrix_complex (p, A68_TRUE); q = gsl_permutation_alloc (SIZE1 (u)); rc = gsl_linalg_complex_LU_decomp (u, q, &signum); torrix_test_error (rc); det = gsl_linalg_complex_LU_det (u, signum); PUSH_PRIMITIVE (p, GSL_REAL (det), A68_REAL); PUSH_PRIMITIVE (p, GSL_IMAG (det), A68_REAL); gsl_matrix_complex_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief OP TRACE = ([,] REAL) REAL @param p Node in syntax tree. **/ void genie_matrix_trace (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; double sum; int len1, len2, k; error_node = p; a = pop_matrix (p, A68_TRUE); len1 = (int) (SIZE1 (a)); len2 = (int) (SIZE2 (a)); if (len1 != len2) { torrix_error_handler ("cannot calculate trace", __FILE__, __LINE__, GSL_ENOTSQR); } sum = 0.0; for (k = 0; k < len1; k++) { sum += gsl_matrix_get (a, (size_t) k, (size_t) k); } PUSH_PRIMITIVE (p, sum, A68_REAL); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } /** @brief OP TRACE = ([,] COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_trace (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *a; gsl_complex sum; int len1, len2, k; error_node = p; a = pop_matrix_complex (p, A68_TRUE); len1 = (int) (SIZE1 (a)); len2 = (int) (SIZE2 (a)); if (len1 != len2) { torrix_error_handler ("cannot calculate trace", __FILE__, __LINE__, GSL_ENOTSQR); } GSL_SET_COMPLEX (&sum, 0.0, 0.0); for (k = 0; k < len1; k++) { sum = gsl_complex_add (sum, gsl_matrix_complex_get (a, (size_t) k, (size_t) k)); } PUSH_PRIMITIVE (p, GSL_REAL (sum), A68_REAL); PUSH_PRIMITIVE (p, GSL_IMAG (sum), A68_REAL); gsl_matrix_complex_free (a); (void) gsl_set_error_handler (save_handler); } /** @brief OP - = ([] COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_minus (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; error_node = p; u = pop_vector_complex (p, A68_TRUE); gsl_blas_zdscal (-1, u); push_vector_complex (p, u); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP - = ([,] COMPLEX) [,] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_minus (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *a; gsl_complex one; int rc; error_node = p; GSL_SET_COMPLEX (&one, -1.0, 0.0); a = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_scale (a, one); torrix_test_error (rc); push_matrix_complex (p, a); gsl_matrix_complex_free (a); (void) gsl_set_error_handler (save_handler); } /** @brief OP + = ([] REAL, [] REAL) [] REAL @param p Node in syntax tree. **/ void genie_vector_add (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; int rc; error_node = p; v = pop_vector (p, A68_TRUE); u = pop_vector (p, A68_TRUE); rc = gsl_vector_add (u, v); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); gsl_vector_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP - = ([] REAL, [] REAL) [] REAL @param p Node in syntax tree. **/ void genie_vector_sub (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; int rc; error_node = p; v = pop_vector (p, A68_TRUE); u = pop_vector (p, A68_TRUE); rc = gsl_vector_sub (u, v); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); gsl_vector_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP = = ([] REAL, [] REAL) BOOL @param p Node in syntax tree. **/ void genie_vector_eq (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; int rc; error_node = p; v = pop_vector (p, A68_TRUE); u = pop_vector (p, A68_TRUE); rc = gsl_vector_sub (u, v); torrix_test_error (rc); PUSH_PRIMITIVE (p, (BOOL_T) (gsl_vector_isnull (u) ? A68_TRUE : A68_FALSE), A68_BOOL); gsl_vector_free (u); gsl_vector_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP /= = ([] REAL, [] REAL) BOOL @param p Node in syntax tree. **/ void genie_vector_ne (NODE_T * p) { genie_vector_eq (p); genie_not_bool (p); } /** @brief OP +:= = (REF [] REAL, [] REAL) REF [] REAL @param p Node in syntax tree. **/ void genie_vector_plusab (NODE_T * p) { op_ab (p, MODE (REF_ROW_REAL), MODE (ROW_REAL), genie_vector_add); } /** @brief OP -:= = (REF [] REAL, [] REAL) REF [] REAL @param p Node in syntax tree. **/ void genie_vector_minusab (NODE_T * p) { op_ab (p, MODE (REF_ROW_REAL), MODE (ROW_REAL), genie_vector_sub); } /** @brief OP + = ([, ] REAL, [, ] REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_add (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u, *v; int rc; error_node = p; v = pop_matrix (p, A68_TRUE); u = pop_matrix (p, A68_TRUE); rc = gsl_matrix_add (u, v); torrix_test_error (rc); push_matrix (p, u); gsl_matrix_free (u); gsl_matrix_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP - = ([, ] REAL, [, ] REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_sub (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u, *v; int rc; error_node = p; v = pop_matrix (p, A68_TRUE); u = pop_matrix (p, A68_TRUE); rc = gsl_matrix_sub (u, v); torrix_test_error (rc); push_matrix (p, u); gsl_matrix_free (u); gsl_matrix_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP = = ([, ] REAL, [, ] REAL) [, ] BOOL @param p Node in syntax tree. **/ void genie_matrix_eq (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u, *v; int rc; error_node = p; v = pop_matrix (p, A68_TRUE); u = pop_matrix (p, A68_TRUE); rc = gsl_matrix_sub (u, v); torrix_test_error (rc); PUSH_PRIMITIVE (p, (BOOL_T) (gsl_matrix_isnull (u) ? A68_TRUE : A68_FALSE), A68_BOOL); gsl_matrix_free (u); gsl_matrix_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP /= = ([, ] REAL, [, ] REAL) [, ] BOOL @param p Node in syntax tree. **/ void genie_matrix_ne (NODE_T * p) { genie_matrix_eq (p); genie_not_bool (p); } /** @brief OP +:= = (REF [, ] REAL, [, ] REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_plusab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_REAL), MODE (ROWROW_REAL), genie_matrix_add); } /** @brief OP -:= = (REF [, ] REAL, [, ] REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_minusab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_REAL), MODE (ROWROW_REAL), genie_matrix_sub); } /** @brief OP + = ([] COMPLEX, [] COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_add (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u, *v; gsl_complex one; int rc; error_node = p; GSL_SET_COMPLEX (&one, 1.0, 0.0); v = pop_vector_complex (p, A68_TRUE); u = pop_vector_complex (p, A68_TRUE); rc = gsl_blas_zaxpy (one, u, v); torrix_test_error (rc); push_vector_complex (p, v); gsl_vector_complex_free (u); gsl_vector_complex_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP - = ([] COMPLEX, [] COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_sub (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u, *v; gsl_complex one; int rc; error_node = p; GSL_SET_COMPLEX (&one, -1.0, 0.0); v = pop_vector_complex (p, A68_TRUE); u = pop_vector_complex (p, A68_TRUE); rc = gsl_blas_zaxpy (one, v, u); torrix_test_error (rc); push_vector_complex (p, u); gsl_vector_complex_free (u); gsl_vector_complex_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP = = ([] COMPLEX, [] COMPLEX) BOOL @param p Node in syntax tree. **/ void genie_vector_complex_eq (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u, *v; gsl_complex one; int rc; error_node = p; GSL_SET_COMPLEX (&one, -1.0, 0.0); v = pop_vector_complex (p, A68_TRUE); u = pop_vector_complex (p, A68_TRUE); rc = gsl_blas_zaxpy (one, v, u); torrix_test_error (rc); PUSH_PRIMITIVE (p, (BOOL_T) (gsl_vector_complex_isnull (u) ? A68_TRUE : A68_FALSE), A68_BOOL); gsl_vector_complex_free (u); gsl_vector_complex_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP /= = ([] COMPLEX, [] COMPLEX) BOOL @param p Node in syntax tree. **/ void genie_vector_complex_ne (NODE_T * p) { genie_vector_complex_eq (p); genie_not_bool (p); } /** @brief OP +:= = (REF [] COMPLEX, [] COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_plusab (NODE_T * p) { op_ab (p, MODE (REF_ROW_COMPLEX), MODE (ROW_COMPLEX), genie_vector_complex_add); } /** @brief OP -:= = (REF [] COMPLEX, [] COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_minusab (NODE_T * p) { op_ab (p, MODE (REF_ROW_COMPLEX), MODE (ROW_COMPLEX), genie_vector_complex_sub); } /** @brief OP + = ([, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_add (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u, *v; int rc; error_node = p; v = pop_matrix_complex (p, A68_TRUE); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_add (u, v); torrix_test_error (rc); push_matrix_complex (p, u); gsl_matrix_complex_free (u); gsl_matrix_complex_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP - = ([, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_sub (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u, *v; int rc; error_node = p; v = pop_matrix_complex (p, A68_TRUE); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_sub (u, v); torrix_test_error (rc); push_matrix_complex (p, u); gsl_matrix_complex_free (u); gsl_matrix_complex_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP = = ([, ] COMPLEX, [, ] COMPLEX) BOOL @param p Node in syntax tree. **/ void genie_matrix_complex_eq (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u, *v; int rc; error_node = p; v = pop_matrix_complex (p, A68_TRUE); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_sub (u, v); torrix_test_error (rc); PUSH_PRIMITIVE (p, (BOOL_T) (gsl_matrix_complex_isnull (u) ? A68_TRUE : A68_FALSE), A68_BOOL); gsl_matrix_complex_free (u); gsl_matrix_complex_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP /= = ([, ] COMPLEX, [, ] COMPLEX) BOOL @param p Node in syntax tree. **/ void genie_matrix_complex_ne (NODE_T * p) { genie_matrix_complex_eq (p); genie_not_bool (p); } /** @brief OP +:= = (REF [, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_plusab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), genie_matrix_complex_add); } /** @brief OP -:= = (REF [, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_minusab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_COMPLEX), MODE (ROWROW_COMPLEX), genie_matrix_complex_sub); } /** @brief OP * = ([] REAL, REAL) [] REAL @param p Node in syntax tree. **/ void genie_vector_scale_real (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; A68_REAL v; int rc; error_node = p; POP_OBJECT (p, &v, A68_REAL); u = pop_vector (p, A68_TRUE); rc = gsl_vector_scale (u, VALUE (&v)); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = (REAL, [] REAL) [] REAL @param p Node in syntax tree. **/ void genie_real_scale_vector (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; A68_REAL v; int rc; error_node = p; u = pop_vector (p, A68_TRUE); POP_OBJECT (p, &v, A68_REAL); rc = gsl_vector_scale (u, VALUE (&v)); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = ([, ] REAL, REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_scale_real (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u; A68_REAL v; int rc; error_node = p; POP_OBJECT (p, &v, A68_REAL); u = pop_matrix (p, A68_TRUE); rc = gsl_matrix_scale (u, VALUE (&v)); torrix_test_error (rc); push_matrix (p, u); gsl_matrix_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = (REAL, [, ] REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_real_scale_matrix (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u; A68_REAL v; int rc; error_node = p; u = pop_matrix (p, A68_TRUE); POP_OBJECT (p, &v, A68_REAL); rc = gsl_matrix_scale (u, VALUE (&v)); torrix_test_error (rc); push_matrix (p, u); gsl_matrix_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = ([] COMPLEX, COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_scale_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; A68_REAL re, im; gsl_complex v; error_node = p; POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); u = pop_vector_complex (p, A68_TRUE); gsl_blas_zscal (v, u); push_vector_complex (p, u); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = (COMPLEX, [] COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_complex_scale_vector_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; A68_REAL re, im; gsl_complex v; error_node = p; u = pop_vector_complex (p, A68_TRUE); POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); gsl_blas_zscal (v, u); push_vector_complex (p, u); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = ([, ] COMPLEX, COMPLEX) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_scale_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u; A68_REAL re, im; gsl_complex v; int rc; error_node = p; POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_scale (u, v); torrix_test_error (rc); push_matrix_complex (p, u); gsl_matrix_complex_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = (COMPLEX, [, ] COMPLEX) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_complex_scale_matrix_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u; A68_REAL re, im; gsl_complex v; int rc; error_node = p; u = pop_matrix_complex (p, A68_TRUE); POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); rc = gsl_matrix_complex_scale (u, v); torrix_test_error (rc); push_matrix_complex (p, u); gsl_matrix_complex_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP *:= (REF [] REAL, REAL) REF [] REAL @param p Node in syntax tree. **/ void genie_vector_scale_real_ab (NODE_T * p) { op_ab (p, MODE (REF_ROW_REAL), MODE (REAL), genie_vector_scale_real); } /** @brief OP *:= (REF [, ] REAL, REAL) REF [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_scale_real_ab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_REAL), MODE (REAL), genie_matrix_scale_real); } /** @brief OP *:= (REF [] COMPLEX, COMPLEX) REF [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_scale_complex_ab (NODE_T * p) { op_ab (p, MODE (REF_ROW_COMPLEX), MODE (COMPLEX), genie_vector_complex_scale_complex); } /** @brief OP *:= (REF [, ] COMPLEX, COMPLEX) REF [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_scale_complex_ab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_COMPLEX), MODE (COMPLEX), genie_matrix_complex_scale_complex); } /** @brief OP / = ([] REAL, REAL) [] REAL @param p Node in syntax tree. **/ void genie_vector_div_real (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; A68_REAL v; int rc; error_node = p; POP_OBJECT (p, &v, A68_REAL); if (VALUE (&v) == 0.0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, MODE (ROW_REAL)); exit_genie (p, A68_RUNTIME_ERROR); } u = pop_vector (p, A68_TRUE); rc = gsl_vector_scale (u, 1.0 / VALUE (&v)); torrix_test_error (rc); push_vector (p, u); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP / = ([, ] REAL, REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_div_real (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u; A68_REAL v; int rc; error_node = p; POP_OBJECT (p, &v, A68_REAL); if (VALUE (&v) == 0.0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, MODE (ROWROW_REAL)); exit_genie (p, A68_RUNTIME_ERROR); } u = pop_matrix (p, A68_TRUE); rc = gsl_matrix_scale (u, 1.0 / VALUE (&v)); torrix_test_error (rc); push_matrix (p, u); gsl_matrix_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP / = ([] COMPLEX, COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_div_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; A68_REAL re, im; gsl_complex v; error_node = p; POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); if (VALUE (&re) == 0.0 && VALUE (&im) == 0.0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, MODE (ROW_COMPLEX)); exit_genie (p, A68_RUNTIME_ERROR); } GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); u = pop_vector_complex (p, A68_TRUE); v = gsl_complex_inverse (v); gsl_blas_zscal (v, u); push_vector_complex (p, u); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP / = ([, ] COMPLEX, COMPLEX) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_div_complex (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *u; A68_REAL re, im; gsl_complex v; int rc; error_node = p; POP_OBJECT (p, &im, A68_REAL); POP_OBJECT (p, &re, A68_REAL); if (VALUE (&re) == 0.0 && VALUE (&im) == 0.0) { diagnostic_node (A68_RUNTIME_ERROR, p, ERROR_DIVISION_BY_ZERO, MODE (ROWROW_COMPLEX)); exit_genie (p, A68_RUNTIME_ERROR); } GSL_SET_COMPLEX (&v, VALUE (&re), VALUE (&im)); v = gsl_complex_inverse (v); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_scale (u, v); torrix_test_error (rc); push_matrix_complex (p, u); gsl_matrix_complex_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP /:= (REF [] REAL, REAL) REF [] REAL @param p Node in syntax tree. **/ void genie_vector_div_real_ab (NODE_T * p) { op_ab (p, MODE (REF_ROW_REAL), MODE (REAL), genie_vector_div_real); } /** @brief OP /:= (REF [, ] REAL, REAL) REF [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_div_real_ab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_REAL), MODE (REAL), genie_matrix_div_real); } /** @brief OP /:= (REF [] COMPLEX, COMPLEX) REF [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_div_complex_ab (NODE_T * p) { op_ab (p, MODE (REF_ROW_COMPLEX), MODE (COMPLEX), genie_vector_complex_div_complex); } /** @brief OP /:= (REF [, ] COMPLEX, COMPLEX) REF [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_div_complex_ab (NODE_T * p) { op_ab (p, MODE (REF_ROWROW_COMPLEX), MODE (COMPLEX), genie_matrix_complex_div_complex); } /** @brief OP * = ([] REAL, [] REAL) REAL @param p Node in syntax tree. **/ void genie_vector_dot (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; double w; int rc; error_node = p; v = pop_vector (p, A68_TRUE); u = pop_vector (p, A68_TRUE); rc = gsl_blas_ddot (u, v, &w); torrix_test_error (rc); PUSH_PRIMITIVE (p, w, A68_REAL); gsl_vector_free (u); gsl_vector_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = ([] COMPLEX, [] COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_dot (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u, *v; gsl_complex w; int rc; error_node = p; v = pop_vector_complex (p, A68_TRUE); u = pop_vector_complex (p, A68_TRUE); rc = gsl_blas_zdotc (u, v, &w); torrix_test_error (rc); PUSH_PRIMITIVE (p, GSL_REAL (w), A68_REAL); PUSH_PRIMITIVE (p, GSL_IMAG (w), A68_REAL); gsl_vector_complex_free (u); gsl_vector_complex_free (v); (void) gsl_set_error_handler (save_handler); } /** @brief OP NORM = ([] REAL) REAL @param p Node in syntax tree. **/ void genie_vector_norm (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u; error_node = p; u = pop_vector (p, A68_TRUE); PUSH_PRIMITIVE (p, gsl_blas_dnrm2 (u), A68_REAL); gsl_vector_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP NORM = ([] COMPLEX) COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_norm (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u; error_node = p; u = pop_vector_complex (p, A68_TRUE); PUSH_PRIMITIVE (p, gsl_blas_dznrm2 (u), A68_REAL); gsl_vector_complex_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief OP DYAD = ([] REAL, [] REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_vector_dyad (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector *u, *v; gsl_matrix *w; int len1, len2, j, k; error_node = p; v = pop_vector (p, A68_TRUE); u = pop_vector (p, A68_TRUE); len1 = (int) (SIZE (u)); len2 = (int) (SIZE (v)); w = gsl_matrix_alloc ((size_t) len1, (size_t) len2); for (j = 0; j < len1; j++) { double uj = gsl_vector_get (u, (size_t) j); for (k = 0; k < len2; k++) { double vk = gsl_vector_get (v, (size_t) k); gsl_matrix_set (w, (size_t) j, (size_t) k, uj * vk); } } push_matrix (p, w); gsl_vector_free (u); gsl_vector_free (v); gsl_matrix_free (w); (void) gsl_set_error_handler (save_handler); } /** @brief OP DYAD = ([] COMPLEX, [] COMPLEX) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_dyad (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_vector_complex *u, *v; gsl_matrix_complex *w; int len1, len2, j, k; error_node = p; v = pop_vector_complex (p, A68_TRUE); u = pop_vector_complex (p, A68_TRUE); len1 = (int) (SIZE (u)); len2 = (int) (SIZE (v)); w = gsl_matrix_complex_alloc ((size_t) len1, (size_t) len2); for (j = 0; j < len1; j++) { gsl_complex uj = gsl_vector_complex_get (u, (size_t) j); for (k = 0; k < len2; k++) { gsl_complex vk = gsl_vector_complex_get (u, (size_t) k); gsl_matrix_complex_set (w, (size_t) j, (size_t) k, gsl_complex_mul (uj, vk)); } } push_matrix_complex (p, w); gsl_vector_complex_free (u); gsl_vector_complex_free (v); gsl_matrix_complex_free (w); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = ([, ] REAL, [] REAL) [] REAL @param p Node in syntax tree. **/ void genie_matrix_times_vector (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len; int rc; gsl_vector *u, *v; gsl_matrix *w; error_node = p; u = pop_vector (p, A68_TRUE); w = pop_matrix (p, A68_TRUE); len = (int) (SIZE (u)); v = gsl_vector_alloc ((size_t) len); gsl_vector_set_zero (v); rc = gsl_blas_dgemv (CblasNoTrans, 1.0, w, u, 0.0, v); torrix_test_error (rc); push_vector (p, v); gsl_vector_free (u); gsl_vector_free (v); gsl_matrix_free (w); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = ([] REAL, [, ] REAL) [] REAL @param p Node in syntax tree. **/ void genie_vector_times_matrix (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len; int rc; gsl_vector *u, *v; gsl_matrix *w; error_node = p; w = pop_matrix (p, A68_TRUE); rc = gsl_matrix_transpose (w); torrix_test_error (rc); u = pop_vector (p, A68_TRUE); len = (int) (SIZE (u)); v = gsl_vector_alloc ((size_t) len); gsl_vector_set_zero (v); rc = gsl_blas_dgemv (CblasNoTrans, 1.0, w, u, 0.0, v); torrix_test_error (rc); push_vector (p, v); gsl_vector_free (u); gsl_vector_free (v); gsl_matrix_free (w); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = ([, ] REAL, [, ] REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_times_matrix (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len1, len2; int rc; gsl_matrix *u, *v, *w; error_node = p; v = pop_matrix (p, A68_TRUE); u = pop_matrix (p, A68_TRUE); len2 = (int) (SIZE2 (v)); len1 = (int) (SIZE1 (u)); w = gsl_matrix_alloc ((size_t) len1, (size_t) len2); gsl_matrix_set_zero (w); rc = gsl_blas_dgemm (CblasNoTrans, CblasNoTrans, 1.0, u, v, 0.0, w); torrix_test_error (rc); push_matrix (p, w); gsl_matrix_free (u); gsl_matrix_free (v); gsl_matrix_free (w); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = ([, ] COMPLEX, [] COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_times_vector (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len, rc; gsl_vector_complex *u, *v; gsl_matrix_complex *w; gsl_complex zero, one; error_node = p; GSL_SET_COMPLEX (&zero, 0.0, 0.0); GSL_SET_COMPLEX (&one, 1.0, 0.0); u = pop_vector_complex (p, A68_TRUE); w = pop_matrix_complex (p, A68_TRUE); len = (int) (SIZE (u)); v = gsl_vector_complex_alloc ((size_t) len); gsl_vector_complex_set_zero (v); rc = gsl_blas_zgemv (CblasNoTrans, one, w, u, zero, v); torrix_test_error (rc); push_vector_complex (p, v); gsl_vector_complex_free (u); gsl_vector_complex_free (v); gsl_matrix_complex_free (w); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = ([] COMPLEX, [, ] COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_vector_complex_times_matrix (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len, rc; gsl_vector_complex *u, *v; gsl_matrix_complex *w; gsl_complex zero, one; error_node = p; GSL_SET_COMPLEX (&zero, 0.0, 0.0); GSL_SET_COMPLEX (&one, 1.0, 0.0); w = pop_matrix_complex (p, A68_TRUE); rc = gsl_matrix_complex_transpose (w); torrix_test_error (rc); u = pop_vector_complex (p, A68_TRUE); len = (int) (SIZE (u)); v = gsl_vector_complex_alloc ((size_t) len); gsl_vector_complex_set_zero (v); rc = gsl_blas_zgemv (CblasNoTrans, one, w, u, zero, v); torrix_test_error (rc); push_vector_complex (p, v); gsl_vector_complex_free (u); gsl_vector_complex_free (v); gsl_matrix_complex_free (w); (void) gsl_set_error_handler (save_handler); } /** @brief OP * = ([, ] COMPLEX, [, ] COMPLEX) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_times_matrix (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); int len1, len2, rc; gsl_matrix_complex *u, *v, *w; gsl_complex zero, one; error_node = p; GSL_SET_COMPLEX (&zero, 0.0, 0.0); GSL_SET_COMPLEX (&one, 1.0, 0.0); v = pop_matrix_complex (p, A68_TRUE); u = pop_matrix_complex (p, A68_TRUE); len1 = (int) (SIZE2 (v)); len2 = (int) (SIZE1 (u)); w = gsl_matrix_complex_alloc ((size_t) len1, (size_t) len2); gsl_matrix_complex_set_zero (w); rc = gsl_blas_zgemm (CblasNoTrans, CblasNoTrans, one, u, v, zero, w); torrix_test_error (rc); push_matrix_complex (p, w); gsl_matrix_complex_free (u); gsl_matrix_complex_free (v); gsl_matrix_complex_free (w); (void) gsl_set_error_handler (save_handler); } /** @brief PROC lu decomp = ([, ] REAL, REF [] INT, REF INT) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_lu (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); A68_REF ref_signum, ref_q; gsl_permutation *q; gsl_matrix *u; int rc; A68_INT signum; error_node = p; POP_REF (p, &ref_signum); CHECK_REF (p, ref_signum, MODE (REF_INT)); POP_REF (p, &ref_q); CHECK_REF (p, ref_q, MODE (REF_ROW_INT)); PUSH_REF (p, *DEREF (A68_ROW, &ref_q)); q = pop_permutation (p, A68_FALSE); u = pop_matrix (p, A68_TRUE); rc = gsl_linalg_LU_decomp (u, q, &(VALUE (&signum))); torrix_test_error (rc); STATUS (&signum) = INIT_MASK; *DEREF (A68_INT, &ref_signum) = signum; push_permutation (p, q); POP_REF (p, DEREF (A68_ROW, &ref_q)); push_matrix (p, u); gsl_matrix_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief PROC lu det = ([, ] REAL, INT) REAL @param p Node in syntax tree. **/ void genie_matrix_lu_det (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *lu; A68_INT signum; error_node = p; POP_OBJECT (p, &signum, A68_INT); lu = pop_matrix (p, A68_TRUE); PUSH_PRIMITIVE (p, gsl_linalg_LU_det (lu, VALUE (&signum)), A68_REAL); gsl_matrix_free (lu); (void) gsl_set_error_handler (save_handler); } /** @brief PROC lu inv = ([, ] REAL, [] INT) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_lu_inv (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix *lu, *inv; int rc; error_node = p; q = pop_permutation (p, A68_TRUE); lu = pop_matrix (p, A68_TRUE); inv = gsl_matrix_alloc (SIZE1 (lu), SIZE2 (lu)); rc = gsl_linalg_LU_invert (lu, q, inv); torrix_test_error (rc); push_matrix (p, inv); gsl_matrix_free (lu); gsl_matrix_free (inv); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief PROC lu solve ([, ] REAL, [, ] REAL, [] INT, [] REAL) [] REAL @param p Node in syntax tree. **/ void genie_matrix_lu_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix *a, *lu; gsl_vector *b, *x, *r; int rc; error_node = p; b = pop_vector (p, A68_TRUE); q = pop_permutation (p, A68_TRUE); lu = pop_matrix (p, A68_TRUE); a = pop_matrix (p, A68_TRUE); x = gsl_vector_alloc (SIZE (b)); r = gsl_vector_alloc (SIZE (b)); rc = gsl_linalg_LU_solve (lu, q, b, x); torrix_test_error (rc); rc = gsl_linalg_LU_refine (a, lu, q, b, x, r); torrix_test_error (rc); push_vector (p, x); gsl_matrix_free (a); gsl_matrix_free (lu); gsl_vector_free (b); gsl_vector_free (r); gsl_vector_free (x); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief PROC complex lu decomp = ([, ] COMPLEX, REF [] INT, REF INT) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_lu (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); A68_REF ref_signum, ref_q; gsl_permutation *q; gsl_matrix_complex *u; int rc; A68_INT signum; error_node = p; POP_REF (p, &ref_signum); CHECK_REF (p, ref_signum, MODE (REF_INT)); POP_REF (p, &ref_q); CHECK_REF (p, ref_q, MODE (REF_ROW_INT)); PUSH_REF (p, *DEREF (A68_ROW, &ref_q)); q = pop_permutation (p, A68_FALSE); u = pop_matrix_complex (p, A68_TRUE); rc = gsl_linalg_complex_LU_decomp (u, q, &(VALUE (&signum))); torrix_test_error (rc); STATUS (&signum) = INIT_MASK; *DEREF (A68_INT, &ref_signum) = signum; push_permutation (p, q); POP_REF (p, DEREF (A68_ROW, &ref_q)); push_matrix_complex (p, u); gsl_matrix_complex_free (u); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief PROC complex lu det = ([, ] COMPLEX, INT) COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_lu_det (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix_complex *lu; A68_INT signum; gsl_complex det; error_node = p; POP_OBJECT (p, &signum, A68_INT); lu = pop_matrix_complex (p, A68_TRUE); det = gsl_linalg_complex_LU_det (lu, VALUE (&signum)); PUSH_PRIMITIVE (p, GSL_REAL (det), A68_REAL); PUSH_PRIMITIVE (p, GSL_IMAG (det), A68_REAL); gsl_matrix_complex_free (lu); (void) gsl_set_error_handler (save_handler); } /** @brief PROC complex lu inv = ([, ] COMPLEX, [] INT) [, ] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_lu_inv (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix_complex *lu, *inv; int rc; error_node = p; q = pop_permutation (p, A68_TRUE); lu = pop_matrix_complex (p, A68_TRUE); inv = gsl_matrix_complex_alloc (SIZE1 (lu), SIZE2 (lu)); rc = gsl_linalg_complex_LU_invert (lu, q, inv); torrix_test_error (rc); push_matrix_complex (p, inv); gsl_matrix_complex_free (lu); gsl_matrix_complex_free (inv); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief PROC complex lu solve ([, ] COMPLEX, [, ] COMPLEX, [] INT, [] COMPLEX) [] COMPLEX @param p Node in syntax tree. **/ void genie_matrix_complex_lu_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_permutation *q; gsl_matrix_complex *a, *lu; gsl_vector_complex *b, *x, *r; int rc; error_node = p; b = pop_vector_complex (p, A68_TRUE); q = pop_permutation (p, A68_TRUE); lu = pop_matrix_complex (p, A68_TRUE); a = pop_matrix_complex (p, A68_TRUE); x = gsl_vector_complex_alloc (SIZE (b)); r = gsl_vector_complex_alloc (SIZE (b)); rc = gsl_linalg_complex_LU_solve (lu, q, b, x); torrix_test_error (rc); rc = gsl_linalg_complex_LU_refine (a, lu, q, b, x, r); torrix_test_error (rc); push_vector_complex (p, x); gsl_matrix_complex_free (a); gsl_matrix_complex_free (lu); gsl_vector_complex_free (b); gsl_vector_complex_free (r); gsl_vector_complex_free (x); gsl_permutation_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief PROC svd decomp = ([, ] REAL, REF [, ] REAL, REF [] REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_svd (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a, *v; gsl_vector *s, *w; A68_REF ref_s, ref_v; int rc; error_node = p; POP_REF (p, &ref_s); CHECK_REF (p, ref_s, MODE (REF_ROW_REAL)); PUSH_REF (p, *DEREF (A68_ROW, &ref_s)); s = pop_vector (p, A68_FALSE); POP_REF (p, &ref_v); CHECK_REF (p, ref_v, MODE (REF_ROWROW_REAL)); PUSH_REF (p, *DEREF (A68_ROW, &ref_v)); v = pop_matrix (p, A68_FALSE); a = pop_matrix (p, A68_TRUE); w = gsl_vector_alloc (SIZE2 (v)); rc = gsl_linalg_SV_decomp (a, v, s, w); torrix_test_error (rc); push_vector (p, s); POP_REF (p, DEREF (A68_ROW, &ref_s)); push_matrix (p, v); POP_REF (p, DEREF (A68_ROW, &ref_v)); push_matrix (p, a); gsl_matrix_free (a); gsl_matrix_free (v); gsl_vector_free (s); gsl_vector_free (w); (void) gsl_set_error_handler (save_handler); } /** @brief PROC svd solve = ([, ] REAL, [, ] REAL, [] REAL, [] REAL) [] REAL @param p Node in syntax tree. **/ void genie_matrix_svd_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *u, *v; gsl_vector *s, *b, *x; int rc; error_node = p; b = pop_vector (p, A68_TRUE); s = pop_vector (p, A68_TRUE); v = pop_matrix (p, A68_TRUE); u = pop_matrix (p, A68_TRUE); x = gsl_vector_alloc (SIZE (b)); rc = gsl_linalg_SV_solve (u, v, s, b, x); push_vector (p, x); gsl_vector_free (x); gsl_vector_free (b); gsl_vector_free (s); gsl_matrix_free (v); gsl_matrix_free (u); (void) gsl_set_error_handler (save_handler); } /** @brief PROC qr decomp = ([, ] REAL, [] REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_qr (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; gsl_vector *t; A68_REF ref_t; int rc; error_node = p; POP_REF (p, &ref_t); CHECK_REF (p, ref_t, MODE (REF_ROW_REAL)); PUSH_REF (p, *DEREF (A68_ROW, &ref_t)); t = pop_vector (p, A68_FALSE); a = pop_matrix (p, A68_TRUE); rc = gsl_linalg_QR_decomp (a, t); torrix_test_error (rc); push_vector (p, t); POP_REF (p, DEREF (A68_ROW, &ref_t)); push_matrix (p, a); gsl_matrix_free (a); gsl_vector_free (t); (void) gsl_set_error_handler (save_handler); } /** @brief PROC qr solve = ([, ] REAL, [] REAL, [] REAL) [] REAL @param p Node in syntax tree. **/ void genie_matrix_qr_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *q; gsl_vector *t, *b, *x; int rc; error_node = p; b = pop_vector (p, A68_TRUE); t = pop_vector (p, A68_TRUE); q = pop_matrix (p, A68_TRUE); x = gsl_vector_alloc (SIZE (b)); rc = gsl_linalg_QR_solve (q, t, b, x); push_vector (p, x); gsl_vector_free (x); gsl_vector_free (b); gsl_vector_free (t); gsl_matrix_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief PROC qr ls solve = ([, ] REAL, [] REAL, [] REAL) [] REAL @param p Node in syntax tree. **/ void genie_matrix_qr_ls_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *q; gsl_vector *t, *b, *x, *r; int rc; error_node = p; b = pop_vector (p, A68_TRUE); t = pop_vector (p, A68_TRUE); q = pop_matrix (p, A68_TRUE); r = gsl_vector_alloc (SIZE (b)); x = gsl_vector_alloc (SIZE (b)); rc = gsl_linalg_QR_lssolve (q, t, b, x, r); push_vector (p, x); gsl_vector_free (x); gsl_vector_free (r); gsl_vector_free (b); gsl_vector_free (t); gsl_matrix_free (q); (void) gsl_set_error_handler (save_handler); } /** @brief PROC cholesky decomp = ([, ] REAL) [, ] REAL @param p Node in syntax tree. **/ void genie_matrix_ch (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *a; int rc; error_node = p; a = pop_matrix (p, A68_TRUE); rc = gsl_linalg_cholesky_decomp (a); torrix_test_error (rc); push_matrix (p, a); gsl_matrix_free (a); (void) gsl_set_error_handler (save_handler); } /** @brief PROC cholesky solve = ([, ] REAL, [] REAL) [] REAL @param p Node in syntax tree. **/ void genie_matrix_ch_solve (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (torrix_error_handler); gsl_matrix *c; gsl_vector *b, *x; int rc; error_node = p; b = pop_vector (p, A68_TRUE); c = pop_matrix (p, A68_TRUE); x = gsl_vector_alloc (SIZE (b)); rc = gsl_linalg_cholesky_solve (c, b, x); push_vector (p, x); gsl_vector_free (x); gsl_vector_free (b); gsl_matrix_free (c); (void) gsl_set_error_handler (save_handler); } /** @brief Map GSL error handler onto a68g error handler. @param reason Error text. @param file Gsl file where error occured. @param line Line in above file. @param gsl_errno Gsl error number. **/ void fft_error_handler (const char *reason, const char *file, int line, int gsl_errno) { if (line != 0) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s in line %d of file %s", reason, line, file) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s", reason) >= 0); } diagnostic_node (A68_RUNTIME_ERROR, error_node, ERROR_FFT, edit_line, gsl_strerror (gsl_errno)); exit_genie (error_node, A68_RUNTIME_ERROR); } /** @brief Detect math errors. @param rc Return code from function. **/ static void fft_test_error (int rc) { if (rc != 0) { fft_error_handler ("math error", "", 0, rc); } } /** @brief Pop [] REAL on the stack as complex double []. @param p Node in syntax tree. @param len Length of array. @return Double []. **/ static double *pop_array_real (NODE_T * p, int *len) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int inc, iindex, k; BYTE_T *base; double *v; error_node = p; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROW_REAL)); GET_DESCRIPTOR (arr, tup, &desc); *len = ROW_SIZE (tup); if ((*len) <= 0) { return (NO_REAL); } v = malloc (2 * (size_t) (*len) * sizeof (double)); fft_test_error (v == NO_REAL ? GSL_ENOMEM : GSL_SUCCESS); base = DEREF (BYTE_T, &ARRAY (arr)); iindex = VECTOR_OFFSET (arr, tup); inc = SPAN (tup) * ELEM_SIZE (arr); for (k = 0; k < (*len); k++, iindex += inc) { A68_REAL *x = (A68_REAL *) (base + iindex); CHECK_INIT (p, INITIALISED (x), MODE (REAL)); v[2 * k] = VALUE (x); v[2 * k + 1] = 0.0; } return (v); } /** @brief Push double [] on the stack as [] REAL. @param p Node in syntax tree. @param v First element. @param len Length of array. **/ static void push_array_real (NODE_T * p, double *v, int len) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int inc, iindex, k; BYTE_T *base; error_node = p; desc = heap_generator (p, MODE (ROW_REAL), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_REAL), len * SIZE (MODE (REAL))); DIM (&arr) = 1; MOID (&arr) = MODE (REAL); ELEM_SIZE (&arr) = SIZE (MODE (REAL)); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *x = (A68_REAL *) (base + iindex); STATUS (x) = INIT_MASK; VALUE (x) = v[2 * k]; CHECK_REAL_REPRESENTATION (p, VALUE (x)); } PUSH_REF (p, desc); } /** @brief Pop [] COMPLEX on the stack as double []. @param p Node in syntax tree. @param len Length or array. @return Double []. **/ static double *pop_array_complex (NODE_T * p, int *len) { A68_REF desc; A68_ARRAY *arr; A68_TUPLE *tup; int inc, iindex, k; BYTE_T *base; double *v; error_node = p; /* Pop arguments */ POP_REF (p, &desc); CHECK_REF (p, desc, MODE (ROW_COMPLEX)); GET_DESCRIPTOR (arr, tup, &desc); *len = ROW_SIZE (tup); if ((*len) <= 0) { return (NO_REAL); } v = malloc (2 * (size_t) (*len) * sizeof (double)); fft_test_error (v == NO_REAL ? GSL_ENOMEM : GSL_SUCCESS); base = DEREF (BYTE_T, &ARRAY (arr)); iindex = VECTOR_OFFSET (arr, tup); inc = SPAN (tup) * ELEM_SIZE (arr); for (k = 0; k < (*len); k++, iindex += inc) { A68_REAL *re = (A68_REAL *) (base + iindex); A68_REAL *im = (A68_REAL *) (base + iindex + SIZE (MODE (REAL))); CHECK_INIT (p, INITIALISED (re), MODE (COMPLEX)); CHECK_INIT (p, INITIALISED (im), MODE (COMPLEX)); v[2 * k] = VALUE (re); v[2 * k + 1] = VALUE (im); } return (v); } /** @brief Push double [] on the stack as [] COMPLEX. @param p Node in syntax tree. @param v First element. @param len Length of array. **/ static void push_array_complex (NODE_T * p, double *v, int len) { A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int inc, iindex, k; BYTE_T *base; error_node = p; desc = heap_generator (p, MODE (ROW_COMPLEX), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_COMPLEX), len * 2 * SIZE (MODE (REAL))); DIM (&arr) = 1; MOID (&arr) = MODE (COMPLEX); ELEM_SIZE (&arr) = 2 * SIZE (MODE (REAL)); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_REAL *re = (A68_REAL *) (base + iindex); A68_REAL *im = (A68_REAL *) (base + iindex + SIZE (MODE (REAL))); STATUS (re) = INIT_MASK; VALUE (re) = v[2 * k]; STATUS (im) = INIT_MASK; VALUE (im) = v[2 * k + 1]; CHECK_COMPLEX_REPRESENTATION (p, VALUE (re), VALUE (im)); } PUSH_REF (p, desc); } /** @brief Push prime factorisation on the stack as [] INT. @param p Node in syntax tree. **/ void genie_prime_factors (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); A68_INT n; A68_REF desc, row; A68_ARRAY arr; A68_TUPLE tup; int len, inc, iindex, k; BYTE_T *base; gsl_fft_complex_wavetable *wt; error_node = p; POP_OBJECT (p, &n, A68_INT); CHECK_INIT (p, INITIALISED (&n), MODE (INT)); wt = gsl_fft_complex_wavetable_alloc ((size_t) (VALUE (&n))); len = (int) (NF (wt)); desc = heap_generator (p, MODE (ROW_INT), SIZE_AL (A68_ARRAY) + SIZE_AL (A68_TUPLE)); row = heap_generator (p, MODE (ROW_INT), len * SIZE (MODE (INT))); DIM (&arr) = 1; MOID (&arr) = MODE (INT); ELEM_SIZE (&arr) = SIZE (MODE (INT)); SLICE_OFFSET (&arr) = FIELD_OFFSET (&arr) = 0; ARRAY (&arr) = row; LWB (&tup) = 1; UPB (&tup) = len; SHIFT (&tup) = LWB (&tup); SPAN (&tup) = 1; K (&tup) = 0; PUT_DESCRIPTOR (arr, tup, &desc); base = DEREF (BYTE_T, &ARRAY (&arr)); iindex = VECTOR_OFFSET (&arr, &tup); inc = SPAN (&tup) * ELEM_SIZE (&arr); for (k = 0; k < len; k++, iindex += inc) { A68_INT *x = (A68_INT *) (base + iindex); STATUS (x) = INIT_MASK; VALUE (x) = (int) ((FACTOR (wt))[k]); } gsl_fft_complex_wavetable_free (wt); PUSH_REF (p, desc); (void) gsl_set_error_handler (save_handler); } /** @brief PROC ([] COMPLEX) [] COMPLEX fft complex forward @param p Node in syntax tree. **/ void genie_fft_complex_forward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_complex (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_forward (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_complex (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /** @brief PROC ([] COMPLEX) [] COMPLEX fft complex backward @param p Node in syntax tree. **/ void genie_fft_complex_backward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_complex (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_backward (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_complex (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /** @brief PROC ([] COMPLEX) [] COMPLEX fft complex inverse @param p Node in syntax tree. **/ void genie_fft_complex_inverse (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_complex (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_inverse (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_complex (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /** @brief PROC ([] REAL) [] COMPLEX fft forward @param p Node in syntax tree. **/ void genie_fft_forward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_real (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_forward (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_complex (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /** @brief PROC ([] COMPLEX) [] REAL fft backward @param p Node in syntax tree. **/ void genie_fft_backward (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_complex (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_backward (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_real (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /** @brief PROC ([] COMPLEX) [] REAL fft inverse @param p Node in syntax tree. **/ void genie_fft_inverse (NODE_T * p) { gsl_error_handler_t *save_handler = gsl_set_error_handler (fft_error_handler); int len, rc; double *data; gsl_fft_complex_wavetable *wt; gsl_fft_complex_workspace *ws; error_node = p; data = pop_array_complex (p, &len); fft_test_error (len == 0 ? GSL_EDOM : GSL_SUCCESS); wt = gsl_fft_complex_wavetable_alloc ((size_t) len); ws = gsl_fft_complex_workspace_alloc ((size_t) len); rc = gsl_fft_complex_inverse (data, 1, (size_t) len, wt, ws); fft_test_error (rc); push_array_real (p, data, len); gsl_fft_complex_wavetable_free (wt); gsl_fft_complex_workspace_free (ws); if (data != NO_REAL) { free (data); } (void) gsl_set_error_handler (save_handler); } /** @brief Map GSL error handler onto a68g error handler. @param reason Error text. @param file Gsl file where error occured. @param line Line in above file. @param gsl_errno Gsl error number. **/ void laplace_error_handler (const char *reason, const char *file, int line, int gsl_errno) { if (line != 0) { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s in line %d of file %s", reason, line, file) >= 0); } else { ASSERT (snprintf (edit_line, SNPRINTF_SIZE, "%s", reason) >= 0); } diagnostic_node (A68_RUNTIME_ERROR, error_node, ERROR_LAPLACE, edit_line, gsl_strerror (gsl_errno)); exit_genie (error_node, A68_RUNTIME_ERROR); } /** @brief Detect math errors. @param rc Return code from function. **/ static void laplace_test_error (int rc) { if (rc != 0) { laplace_error_handler ("math error", "", 0, rc); } } /** @brief PROC (PROC (REAL) REAL, REAL, REF REAL) REAL laplace @param p Node in syntax tree. **/ #define LAPLACE_DIVISIONS 1024 typedef struct A68_LAPLACE A68_LAPLACE; struct A68_LAPLACE { NODE_T *p; A68_PROCEDURE f; double s; }; /** @brief Evaluate function for Laplace transform. @param t Argument. @param z LAPLACE value. **/ double laplace_f (double t, void *z) { A68_LAPLACE *l = (A68_LAPLACE *) z; ADDR_T pop_sp = stack_pointer, pop_fp = frame_pointer; MOID_T *u = MODE (PROC_REAL_REAL); A68_REAL *ft = (A68_REAL *) STACK_TOP; PUSH_PRIMITIVE (P (l), t, A68_REAL); genie_call_procedure (P (l), MOID (&(F (l))), u, u, &(F (l)), pop_sp, pop_fp); stack_pointer = pop_sp; return (VALUE (ft) * a68g_exp (-(S (l)) * t)); } /** @brief Calculate Laplace transform. @param p Node in syntax tree. **/ void genie_laplace (NODE_T * p) { A68_REF ref_error; A68_REAL s, *error; A68_PROCEDURE f; A68_LAPLACE l; gsl_function g; gsl_integration_workspace *w; double result, estimated_error; int rc; gsl_error_handler_t *save_handler = gsl_set_error_handler (laplace_error_handler); POP_REF (p, &ref_error); CHECK_REF (p, ref_error, MODE (REF_REAL)); error = (A68_REAL *) ADDRESS (&ref_error); POP_OBJECT (p, &s, A68_REAL); POP_PROCEDURE (p, &f); P (&l) = p; F (&l) = f; S (&l) = VALUE (&s); FUNCTION (&g) = &laplace_f; GSL_PARAMS (&g) = &l; w = gsl_integration_workspace_alloc (LAPLACE_DIVISIONS); if (VALUE (error) >= 0.0) { rc = gsl_integration_qagiu (&g, 0.0, VALUE (error), 0.0, LAPLACE_DIVISIONS, w, &result, &estimated_error); } else { rc = gsl_integration_qagiu (&g, 0.0, 0.0, -VALUE (error), LAPLACE_DIVISIONS, w, &result, &estimated_error); } laplace_test_error (rc); VALUE (error) = estimated_error; PUSH_PRIMITIVE (p, result, A68_REAL); gsl_integration_workspace_free (w); (void) gsl_set_error_handler (save_handler); } #endif /* defined HAVE_GNU_GSL */ algol68g-2.8/source/inet.c0000644000175000001440000004411612113475700012334 00000000000000/** @file inet.c @author J. Marcel van der Veer. @brief Internet TCP and HTTP support routines. @section Copyright This file is part of Algol68G - an Algol 68 interpreter. Copyright (C) 2001-2013 J. Marcel van der Veer . @section License 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 . **/ #include "a68g.h" #if defined HAVE_WINSOCK_H #include #endif #if defined HAVE_HTTP #if defined HAVE_WIN32 typedef int socklen_t; #endif /* defined HAVE_WIN32 */ #define PROTOCOL "tcp" #define SERVICE "http" #define CONTENT_BUFFER_SIZE (4 * KILOBYTE) #define TIMEOUT_INTERVAL 15 #if defined HAVE_WIN32 /** @brief Send GET request to server and yield answer (TCP/HTTP only). @param p Node in syntax tree. **/ void genie_http_content (NODE_T * p) { WSADATA wsa_data; A68_REF path_string, domain_string, content_string; A68_INT port_number; int socket_id, conn, k, rc, len, sent; struct servent *service_address; struct hostent *host_address; struct protoent *protocol; struct sockaddr_in socket_address; char buffer[CONTENT_BUFFER_SIZE]; char *str; RESET_ERRNO; /* Pop arguments */ POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), MODE (INT)); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), MODE (STRING)); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), MODE (STRING)); POP_REF (p, &content_string); CHECK_REF (p, content_string, MODE (REF_STRING)); * DEREF (A68_REF, &content_string) = empty_string (p); /* Reset buffers */ reset_transput_buffer (DOMAIN_BUFFER); reset_transput_buffer (PATH_BUFFER); reset_transput_buffer (REQUEST_BUFFER); reset_transput_buffer (CONTENT_BUFFER); add_a_string_transput_buffer (p, DOMAIN_BUFFER, (BYTE_T *) & domain_string); add_a_string_transput_buffer (p, PATH_BUFFER, (BYTE_T *) & path_string); /* Make request */ add_string_transput_buffer (p, REQUEST_BUFFER, "GET "); add_string_transput_buffer (p, REQUEST_BUFFER, get_transput_buffer (PATH_BUFFER)); add_string_transput_buffer (p, REQUEST_BUFFER, " HTTP/1.0\n\n"); /* Connect to host */ if (WSAStartup(MAKEWORD(1, 1), &wsa_data) != NO_ERROR) { PUSH_PRIMITIVE (p, 1, A68_INT); return; } FILL (&socket_address, 0, (int) sizeof (socket_address)); SIN_FAMILY (&socket_address) = AF_INET; service_address = getservbyname (SERVICE, PROTOCOL); if (service_address == NULL) { PUSH_PRIMITIVE (p, 1, A68_INT); WSACleanup (); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { /* Next line provokes inevitably: warning: conversion to 'short unsigned int' from 'int' may alter its value This warning can be safely ignored. */ SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } COPY (&SIN_ADDR (&socket_address), H_ADDR (host_address), H_LENGTH (host_address)); protocol = getprotobyname (PROTOCOL); if (protocol == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) SIZE_AL (socket_address)); if (conn < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } /* Send request to host */ str = get_transput_buffer (REQUEST_BUFFER); len = (int) strlen (str); sent = 0; while (sent < len) { rc = send (socket_id, &str[sent], len - sent, 0); if (rc == SOCKET_ERROR) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); } sent += rc; } /* Receive data from host */ while ((k = (int) recv (socket_id, (char *) &buffer, (CONTENT_BUFFER_SIZE - 1), 0)) > 0) { buffer[k] = NULL_CHAR; add_string_transput_buffer (p, CONTENT_BUFFER, buffer); } if (k < 0 || errno != 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } /* Convert string */ * DEREF (A68_REF, &content_string) = c_to_a_string (p, get_transput_buffer (CONTENT_BUFFER), get_transput_buffer_index (CONTENT_BUFFER)); if (k != 0) { /* Not gracefully closed by recv () */ ASSERT (close (socket_id) == 0); } PUSH_PRIMITIVE (p, errno, A68_INT); WSACleanup (); } /** @brief Send request to server and yield answer (TCP only). @param p Node in syntax tree. **/ void genie_tcp_request (NODE_T * p) { WSADATA wsa_data; A68_REF path_string, domain_string, content_string; A68_INT port_number; int socket_id, conn, k, rc, len, sent; struct servent *service_address; struct hostent *host_address; struct protoent *protocol; struct sockaddr_in socket_address; char buffer[CONTENT_BUFFER_SIZE]; char *str; RESET_ERRNO; /* Pop arguments */ POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), MODE (INT)); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), MODE (STRING)); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), MODE (STRING)); POP_REF (p, &content_string); CHECK_REF (p, content_string, MODE (REF_STRING)); * DEREF (A68_REF, &content_string) = empty_string (p); /* Reset buffers */ reset_transput_buffer (DOMAIN_BUFFER); reset_transput_buffer (PATH_BUFFER); reset_transput_buffer (REQUEST_BUFFER); reset_transput_buffer (CONTENT_BUFFER); add_a_string_transput_buffer (p, DOMAIN_BUFFER, (BYTE_T *) & domain_string); add_a_string_transput_buffer (p, PATH_BUFFER, (BYTE_T *) & path_string); /* Make request */ add_string_transput_buffer (p, REQUEST_BUFFER, get_transput_buffer (PATH_BUFFER)); /* Connect to host */ if (WSAStartup(MAKEWORD(1, 1), &wsa_data) != NO_ERROR) { PUSH_PRIMITIVE (p, 1, A68_INT); return; } FILL (&socket_address, 0, (int) sizeof (socket_address)); SIN_FAMILY (&socket_address) = AF_INET; service_address = getservbyname (SERVICE, PROTOCOL); if (service_address == NULL) { PUSH_PRIMITIVE (p, 1, A68_INT); WSACleanup (); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { /* Next line provokes inevitably: warning: conversion to 'short unsigned int' from 'int' may alter its value This warning can be safely ignored. */ SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } COPY (&SIN_ADDR (&socket_address), H_ADDR (host_address), H_LENGTH (host_address)); protocol = getprotobyname (PROTOCOL); if (protocol == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) SIZE_AL (socket_address)); if (conn < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } /* Send request to host */ str = get_transput_buffer (REQUEST_BUFFER); len = (int) strlen (str); sent = 0; while (sent < len) { rc = send (socket_id, &str[sent], len - sent, 0); if (rc == SOCKET_ERROR) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); } sent += rc; } /* Receive data from host */ while ((k = (int) recv (socket_id, (char *) &buffer, (CONTENT_BUFFER_SIZE - 1), 0)) > 0) { buffer[k] = NULL_CHAR; add_string_transput_buffer (p, CONTENT_BUFFER, buffer); } if (k < 0 || errno != 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); WSACleanup (); return; } /* Convert string */ * DEREF (A68_REF, &content_string) = c_to_a_string (p, get_transput_buffer (CONTENT_BUFFER), get_transput_buffer_index (CONTENT_BUFFER)); if (k != 0) { /* Not gracefully closed by recv () */ ASSERT (close (socket_id) == 0); } PUSH_PRIMITIVE (p, errno, A68_INT); WSACleanup (); } #else /* ! defined HAVE_WIN32 */ /** @brief Send GET request to server and yield answer (TCP/HTTP only). @param p Node in syntax tree. **/ void genie_http_content (NODE_T * p) { A68_REF path_string, domain_string, content_string; A68_INT port_number; int socket_id, conn, k; fd_set set; struct timeval a68g_timeout; struct servent *service_address; struct hostent *host_address; struct protoent *protocol; struct sockaddr_in socket_address; char buffer[CONTENT_BUFFER_SIZE]; RESET_ERRNO; /* Pop arguments */ POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), MODE (INT)); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), MODE (STRING)); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), MODE (STRING)); POP_REF (p, &content_string); CHECK_REF (p, content_string, MODE (REF_STRING)); * DEREF (A68_REF, &content_string) = empty_string (p); /* Reset buffers */ reset_transput_buffer (DOMAIN_BUFFER); reset_transput_buffer (PATH_BUFFER); reset_transput_buffer (REQUEST_BUFFER); reset_transput_buffer (CONTENT_BUFFER); add_a_string_transput_buffer (p, DOMAIN_BUFFER, (BYTE_T *) & domain_string); add_a_string_transput_buffer (p, PATH_BUFFER, (BYTE_T *) & path_string); /* Make request */ add_string_transput_buffer (p, REQUEST_BUFFER, "GET "); add_string_transput_buffer (p, REQUEST_BUFFER, get_transput_buffer (PATH_BUFFER)); add_string_transput_buffer (p, REQUEST_BUFFER, " HTTP/1.0\n\n"); /* Connect to host */ FILL (&socket_address, 0, (int) sizeof (socket_address)); SIN_FAMILY (&socket_address) = AF_INET; service_address = getservbyname (SERVICE, PROTOCOL); if (service_address == NULL) { PUSH_PRIMITIVE (p, 1, A68_INT); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { /* Next line provokes inevitably: warning: conversion to 'short unsigned int' from 'int' may alter its value This warning can be safely ignored. */ SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } COPY (&SIN_ADDR (&socket_address), H_ADDR (host_address), H_LENGTH (host_address)); protocol = getprotobyname (PROTOCOL); if (protocol == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) SIZE_AL (socket_address)); if (conn < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); ASSERT (close (socket_id) == 0); return; } /* Read from host */ WRITE (socket_id, get_transput_buffer (REQUEST_BUFFER)); if (errno != 0) { PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } /* Initialise file descriptor set */ FD_ZERO (&set); FD_SET (socket_id, &set); /* Initialise the a68g_timeout data structure */ TV_SEC (&a68g_timeout) = TIMEOUT_INTERVAL; TV_USEC (&a68g_timeout) = 0; /* Block until server replies or a68g_timeout blows up */ switch (select (FD_SETSIZE, &set, NULL, NULL, &a68g_timeout)) { case 0: { errno = ETIMEDOUT; PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case -1: { PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case 1: { break; } default: { ABEND (A68_TRUE, "unexpected result from select", NO_TEXT); } } while ((k = (int) io_read (socket_id, &buffer, (CONTENT_BUFFER_SIZE - 1))) > 0) { buffer[k] = NULL_CHAR; add_string_transput_buffer (p, CONTENT_BUFFER, buffer); } if (k < 0 || errno != 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); ASSERT (close (socket_id) == 0); return; } /* Convert string */ * DEREF (A68_REF, &content_string) = c_to_a_string (p, get_transput_buffer (CONTENT_BUFFER), get_transput_buffer_index (CONTENT_BUFFER)); ASSERT (close (socket_id) == 0); PUSH_PRIMITIVE (p, errno, A68_INT); } /** @brief Send request to server and yield answer (TCP only). @param p Node in syntax tree. **/ void genie_tcp_request (NODE_T * p) { A68_REF path_string, domain_string, content_string; A68_INT port_number; int socket_id, conn, k; fd_set set; struct timeval a68g_timeout; struct servent *service_address; struct hostent *host_address; struct protoent *protocol; struct sockaddr_in socket_address; char buffer[CONTENT_BUFFER_SIZE]; RESET_ERRNO; /* Pop arguments */ POP_OBJECT (p, &port_number, A68_INT); CHECK_INIT (p, INITIALISED (&port_number), MODE (INT)); POP_REF (p, &path_string); CHECK_INIT (p, INITIALISED (&path_string), MODE (STRING)); POP_REF (p, &domain_string); CHECK_INIT (p, INITIALISED (&domain_string), MODE (STRING)); POP_REF (p, &content_string); CHECK_REF (p, content_string, MODE (REF_STRING)); * DEREF (A68_REF, &content_string) = empty_string (p); /* Reset buffers */ reset_transput_buffer (DOMAIN_BUFFER); reset_transput_buffer (PATH_BUFFER); reset_transput_buffer (REQUEST_BUFFER); reset_transput_buffer (CONTENT_BUFFER); add_a_string_transput_buffer (p, DOMAIN_BUFFER, (BYTE_T *) & domain_string); add_a_string_transput_buffer (p, PATH_BUFFER, (BYTE_T *) & path_string); /* Make request */ add_string_transput_buffer (p, REQUEST_BUFFER, get_transput_buffer (PATH_BUFFER)); /* Connect to host */ FILL (&socket_address, 0, (int) sizeof (socket_address)); SIN_FAMILY (&socket_address) = AF_INET; service_address = getservbyname (SERVICE, PROTOCOL); if (service_address == NULL) { PUSH_PRIMITIVE (p, 1, A68_INT); return; } if (VALUE (&port_number) == 0) { SIN_PORT (&socket_address) = (uint16_t) (S_PORT (service_address)); } else { /* Next line provokes inevitably: warning: conversion to 'short unsigned int' from 'int' may alter its value This warning can be safely ignored. */ SIN_PORT (&socket_address) = (uint16_t) (htons ((uint16_t) (VALUE (&port_number)))); if (SIN_PORT (&socket_address) == 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } } host_address = gethostbyname (get_transput_buffer (DOMAIN_BUFFER)); if (host_address == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } COPY (&SIN_ADDR (&socket_address), H_ADDR (host_address), H_LENGTH (host_address)); protocol = getprotobyname (PROTOCOL); if (protocol == NULL) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } socket_id = socket (PF_INET, SOCK_STREAM, P_PROTO (protocol)); if (socket_id < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); return; } conn = connect (socket_id, (const struct sockaddr *) &socket_address, (socklen_t) SIZE_AL (socket_address)); if (conn < 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); ASSERT (close (socket_id) == 0); return; } /* Read from host */ WRITE (socket_id, get_transput_buffer (REQUEST_BUFFER)); if (errno != 0) { PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } /* Initialise file descriptor set */ FD_ZERO (&set); FD_SET (socket_id, &set); /* Initialise the a68g_timeout data structure */ TV_SEC (&a68g_timeout) = TIMEOUT_INTERVAL; TV_USEC (&a68g_timeout) = 0; /* Block until server replies or a68g_timeout blows up */ switch (select (FD_SETSIZE, &set, NULL, NULL, &a68g_timeout)) { case 0: { errno = ETIMEDOUT; PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case -1: { PUSH_PRIMITIVE (p, errno, A68_INT); ASSERT (close (socket_id) == 0); return; } case 1: { break; } default: { ABEND (A68_TRUE, "unexpected result from select", NO_TEXT); } } while ((k = (int) io_read (socket_id, &buffer, (CONTENT_BUFFER_SIZE - 1))) > 0) { buffer[k] = NULL_CHAR; add_string_transput_buffer (p, CONTENT_BUFFER, buffer); } if (k < 0 || errno != 0) { PUSH_PRIMITIVE (p, (errno == 0 ? 1 : errno), A68_INT); ASSERT (close (socket_id) == 0); return; } /* Convert string */ * DEREF (A68_REF, &content_string) = c_to_a_string (p, get_transput_buffer (CONTENT_BUFFER), get_transput_buffer_index (CONTENT_BUFFER)); ASSERT (close (socket_id) == 0); PUSH_PRIMITIVE (p, errno, A68_INT); } #endif /* defined HAVE_WIN32 */ #endif /* HAVE_HTTP */ algol68g-2.8/AUTHORS0000644000175000001440000000013311755213124010771 00000000000000Author and copyright holder of Algol 68 Genie is Marcel van der Veer . algol68g-2.8/config.sub0000644000175000001440000010457111755213125011715 00000000000000#! /bin/sh # Configuration validation subroutine script. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, # 2011 Free Software Foundation, Inc. timestamp='2011-06-03' # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software # can handle that machine. It does not imply ALL GNU software can. # # This file 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 2 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, write to the Free Software # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA # 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Please send patches to . Submit a context # diff and a properly formatted GNU ChangeLog entry. # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. # Each package is responsible for reporting which valid configurations # it does not support. The user should be able to distinguish # a failure to support a valid configuration from a meaningless # configuration. # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM # or in some cases, the newer four-part form: # CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS $0 [OPTION] ALIAS Canonicalize a configuration name. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.sub ($timestamp) Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" exit 1 ;; *local*) # First pass through any local machine types. echo $1 exit ;; * ) break ;; esac done case $# in 0) echo "$me: missing argument$help" >&2 exit 1;; 1) ;; *) echo "$me: too many arguments$help" >&2 exit 1;; esac # Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). # Here we must recognize all the valid KERNEL-OS combinations. maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \ linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \ knetbsd*-gnu* | netbsd*-gnu* | \ kopensolaris*-gnu* | \ storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; *) basic_machine=`echo $1 | sed 's/-[^-]*$//'` if [ $basic_machine != $1 ] then os=`echo $1 | sed 's/.*-/-/'` else os=; fi ;; esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also ### recognize some manufacturers as not being operating systems, so we ### can provide default operating systems below. case $os in -sun*os*) # Prevent following clause from handling this invalid input. ;; -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ -apple | -axis | -knuth | -cray | -microblaze) os= basic_machine=$1 ;; -bluegene*) os=-cnk ;; -sim | -cisco | -oki | -wec | -winbond) os= basic_machine=$1 ;; -scout) ;; -wrs) os=-vxworks basic_machine=$1 ;; -chorusos*) os=-chorusos basic_machine=$1 ;; -chorusrdb) os=-chorusrdb basic_machine=$1 ;; -hiux*) os=-hiuxwe2 ;; -sco6) os=-sco5v6 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5) os=-sco3.2v5 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5v6*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -udk*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -lynx*) os=-lynxos ;; -ptx*) basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` ;; -windowsnt*) os=`echo $os | sed -e 's/windowsnt/winnt/'` ;; -psos*) os=-psos ;; -mint | -mint[0-9]*) basic_machine=m68k-atari os=-mint ;; esac # Decode aliases for certain CPU-COMPANY combinations. case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. 1750a | 580 \ | a29k \ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \ | bfin \ | c4x | clipper \ | d10v | d30v | dlx | dsp16xx \ | fido | fr30 | frv \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | i370 | i860 | i960 | ia64 \ | ip2k | iq2000 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ | maxq | mb | microblaze | mcore | mep | metag \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ | mips64octeon | mips64octeonel \ | mips64orion | mips64orionel \ | mips64r5900 | mips64r5900el \ | mips64vr | mips64vrel \ | mips64vr4100 | mips64vr4100el \ | mips64vr4300 | mips64vr4300el \ | mips64vr5000 | mips64vr5000el \ | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ | moxie \ | mt \ | msp430 \ | nds32 | nds32le | nds32be \ | nios | nios2 \ | ns16k | ns32k \ | open8 \ | or32 \ | pdp10 | pdp11 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle \ | pyramid \ | rx \ | score \ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ | spu \ | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \ | ubicom32 \ | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \ | we32k \ | x86 | xc16x | xstormy16 | xtensa \ | z8k | z80) basic_machine=$basic_machine-unknown ;; c54x) basic_machine=tic54x-unknown ;; c55x) basic_machine=tic55x-unknown ;; c6x) basic_machine=tic6x-unknown ;; m6811 | m68hc11 | m6812 | m68hc12 | picochip) # Motorola 68HC11/12. basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) ;; ms1) basic_machine=mt-unknown ;; strongarm | thumb | xscale) basic_machine=arm-unknown ;; xscaleeb) basic_machine=armeb-unknown ;; xscaleel) basic_machine=armel-unknown ;; # We use `pc' rather than `unknown' # because (1) that's what they normally are, and # (2) the word "unknown" tends to confuse beginning users. i*86 | x86_64) basic_machine=$basic_machine-pc ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. 580-* \ | a29k-* \ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* | avr32-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* \ | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | elxsi-* \ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | i*86-* | i860-* | i960-* | ia64-* \ | ip2k-* | iq2000-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ | mips16-* \ | mips64-* | mips64el-* \ | mips64octeon-* | mips64octeonel-* \ | mips64orion-* | mips64orionel-* \ | mips64r5900-* | mips64r5900el-* \ | mips64vr-* | mips64vrel-* \ | mips64vr4100-* | mips64vr4100el-* \ | mips64vr4300-* | mips64vr4300el-* \ | mips64vr5000-* | mips64vr5000el-* \ | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipstx39-* | mipstx39el-* \ | mmix-* \ | mt-* \ | msp430-* \ | nds32-* | nds32le-* | nds32be-* \ | nios-* | nios2-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | open8-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \ | pyramid-* \ | romp-* | rs6000-* | rx-* \ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ | sparclite-* \ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \ | tahoe-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ | tile*-* \ | tron-* \ | ubicom32-* \ | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \ | vax-* \ | we32k-* \ | x86-* | x86_64-* | xc16x-* | xps100-* \ | xstormy16-* | xtensa*-* \ | ymp-* \ | z8k-* | z80-*) ;; # Recognize the basic CPU types without company name, with glob match. xtensa*) basic_machine=$basic_machine-unknown ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 386bsd) basic_machine=i386-unknown os=-bsd ;; 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) basic_machine=m68000-att ;; 3b*) basic_machine=we32k-att ;; a29khif) basic_machine=a29k-amd os=-udi ;; abacus) basic_machine=abacus-unknown ;; adobe68k) basic_machine=m68010-adobe os=-scout ;; alliant | fx80) basic_machine=fx80-alliant ;; altos | altos3068) basic_machine=m68k-altos ;; am29k) basic_machine=a29k-none os=-bsd ;; amd64) basic_machine=x86_64-pc ;; amd64-*) basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; amdahl) basic_machine=580-amdahl os=-sysv ;; amiga | amiga-*) basic_machine=m68k-unknown ;; amigaos | amigados) basic_machine=m68k-unknown os=-amigaos ;; amigaunix | amix) basic_machine=m68k-unknown os=-sysv4 ;; apollo68) basic_machine=m68k-apollo os=-sysv ;; apollo68bsd) basic_machine=m68k-apollo os=-bsd ;; aros) basic_machine=i386-pc os=-aros ;; aux) basic_machine=m68k-apple os=-aux ;; balance) basic_machine=ns32k-sequent os=-dynix ;; blackfin) basic_machine=bfin-unknown os=-linux ;; blackfin-*) basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; bluegene*) basic_machine=powerpc-ibm os=-cnk ;; c54x-*) basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c55x-*) basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c6x-*) basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'` ;; c90) basic_machine=c90-cray os=-unicos ;; cegcc) basic_machine=arm-unknown os=-cegcc ;; convex-c1) basic_machine=c1-convex os=-bsd ;; convex-c2) basic_machine=c2-convex os=-bsd ;; convex-c32) basic_machine=c32-convex os=-bsd ;; convex-c34) basic_machine=c34-convex os=-bsd ;; convex-c38) basic_machine=c38-convex os=-bsd ;; cray | j90) basic_machine=j90-cray os=-unicos ;; craynv) basic_machine=craynv-cray os=-unicosmp ;; cr16 | cr16-*) basic_machine=cr16-unknown os=-elf ;; crds | unos) basic_machine=m68k-crds ;; crisv32 | crisv32-* | etraxfs*) basic_machine=crisv32-axis ;; cris | cris-* | etrax*) basic_machine=cris-axis ;; crx) basic_machine=crx-unknown os=-elf ;; da30 | da30-*) basic_machine=m68k-da30 ;; decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) basic_machine=mips-dec ;; decsystem10* | dec10*) basic_machine=pdp10-dec os=-tops10 ;; decsystem20* | dec20*) basic_machine=pdp10-dec os=-tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) basic_machine=m68k-motorola ;; delta88) basic_machine=m88k-motorola os=-sysv3 ;; dicos) basic_machine=i686-pc os=-dicos ;; djgpp) basic_machine=i586-pc os=-msdosdjgpp ;; dpx20 | dpx20-*) basic_machine=rs6000-bull os=-bosx ;; dpx2* | dpx2*-bull) basic_machine=m68k-bull os=-sysv3 ;; ebmon29k) basic_machine=a29k-amd os=-ebmon ;; elxsi) basic_machine=elxsi-elxsi os=-bsd ;; encore | umax | mmax) basic_machine=ns32k-encore ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson os=-ose ;; fx2800) basic_machine=i860-alliant ;; genix) basic_machine=ns32k-ns ;; gmicro) basic_machine=tron-gmicro os=-sysv ;; go32) basic_machine=i386-pc os=-go32 ;; h3050r* | hiux*) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; h8300hms) basic_machine=h8300-hitachi os=-hms ;; h8300xray) basic_machine=h8300-hitachi os=-xray ;; h8500hms) basic_machine=h8500-hitachi os=-hms ;; harris) basic_machine=m88k-harris os=-sysv3 ;; hp300-*) basic_machine=m68k-hp ;; hp300bsd) basic_machine=m68k-hp os=-bsd ;; hp300hpux) basic_machine=m68k-hp os=-hpux ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) basic_machine=m68000-hp ;; hp9k3[2-9][0-9]) basic_machine=m68k-hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) basic_machine=hppa1.1-hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) basic_machine=hppa1.1-hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; hppa-next) os=-nextstep3 ;; hppaosf) basic_machine=hppa1.1-hp os=-osf ;; hppro) basic_machine=hppa1.1-hp os=-proelf ;; i370-ibm* | ibm*) basic_machine=i370-ibm ;; # I'm not sure what "Sysv32" means. Should this be sysv3.2? i*86v32) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; i*86v4*) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; i*86v) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv ;; i*86sol2) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; i386mach) basic_machine=i386-mach os=-mach ;; i386-vsta | vsta) basic_machine=i386-unknown os=-vsta ;; iris | iris4d) basic_machine=mips-sgi case $os in -irix*) ;; *) os=-irix4 ;; esac ;; isi68 | isi) basic_machine=m68k-isi os=-sysv ;; m68knommu) basic_machine=m68k-unknown os=-linux ;; m68knommu-*) basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; m88k-omron*) basic_machine=m88k-omron ;; magnum | m3230) basic_machine=mips-mips os=-sysv ;; merlin) basic_machine=ns32k-utek os=-sysv ;; microblaze) basic_machine=microblaze-xilinx ;; mingw32) basic_machine=i386-pc os=-mingw32 ;; mingw32ce) basic_machine=arm-unknown os=-mingw32ce ;; miniframe) basic_machine=m68000-convergent ;; *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) basic_machine=m68k-atari os=-mint ;; mips3*-*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` ;; mips3*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown ;; monitor) basic_machine=m68k-rom68k os=-coff ;; morphos) basic_machine=powerpc-unknown os=-morphos ;; msdos) basic_machine=i386-pc os=-msdos ;; ms1-*) basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` ;; mvs) basic_machine=i370-ibm os=-mvs ;; ncr3000) basic_machine=i486-ncr os=-sysv4 ;; netbsd386) basic_machine=i386-unknown os=-netbsd ;; netwinder) basic_machine=armv4l-rebel os=-linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony os=-newsos ;; news1000) basic_machine=m68030-sony os=-newsos ;; news-3600 | risc-news) basic_machine=mips-sony os=-newsos ;; necv70) basic_machine=v70-nec os=-sysv ;; next | m*-next ) basic_machine=m68k-next case $os in -nextstep* ) ;; -ns2*) os=-nextstep2 ;; *) os=-nextstep3 ;; esac ;; nh3000) basic_machine=m68k-harris os=-cxux ;; nh[45]000) basic_machine=m88k-harris os=-cxux ;; nindy960) basic_machine=i960-intel os=-nindy ;; mon960) basic_machine=i960-intel os=-mon960 ;; nonstopux) basic_machine=mips-compaq os=-nonstopux ;; np1) basic_machine=np1-gould ;; neo-tandem) basic_machine=neo-tandem ;; nse-tandem) basic_machine=nse-tandem ;; nsr-tandem) basic_machine=nsr-tandem ;; op50n-* | op60c-*) basic_machine=hppa1.1-oki os=-proelf ;; openrisc | openrisc-*) basic_machine=or32-unknown ;; os400) basic_machine=powerpc-ibm os=-os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson os=-ose ;; os68k) basic_machine=m68k-none os=-os68k ;; pa-hitachi) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; paragon) basic_machine=i860-intel os=-osf ;; parisc) basic_machine=hppa-unknown os=-linux ;; parisc-*) basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; pbd) basic_machine=sparc-tti ;; pbb) basic_machine=m68k-tti ;; pc532 | pc532-*) basic_machine=ns32k-pc532 ;; pc98) basic_machine=i386-pc ;; pc98-*) basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; pentiumpro | p6 | 6x86 | athlon | athlon_*) basic_machine=i686-pc ;; pentiumii | pentium2 | pentiumiii | pentium3) basic_machine=i686-pc ;; pentium4) basic_machine=i786-pc ;; pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumpro-* | p6-* | 6x86-* | athlon-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium4-*) basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould ;; power) basic_machine=power-ibm ;; ppc | ppcbe) basic_machine=powerpc-unknown ;; ppc-* | ppcbe-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppcle | powerpclittle | ppc-le | powerpc-little) basic_machine=powerpcle-unknown ;; ppcle-* | powerpclittle-*) basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64) basic_machine=powerpc64-unknown ;; ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64le | powerpc64little | ppc64-le | powerpc64-little) basic_machine=powerpc64le-unknown ;; ppc64le-* | powerpc64little-*) basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ps2) basic_machine=i386-ibm ;; pw32) basic_machine=i586-unknown os=-pw32 ;; rdos) basic_machine=i386-pc os=-rdos ;; rom68k) basic_machine=m68k-rom68k os=-coff ;; rm[46]00) basic_machine=mips-siemens ;; rtpc | rtpc-*) basic_machine=romp-ibm ;; s390 | s390-*) basic_machine=s390-ibm ;; s390x | s390x-*) basic_machine=s390x-ibm ;; sa29200) basic_machine=a29k-amd os=-udi ;; sb1) basic_machine=mipsisa64sb1-unknown ;; sb1el) basic_machine=mipsisa64sb1el-unknown ;; sde) basic_machine=mipsisa32-sde os=-elf ;; sei) basic_machine=mips-sei os=-seiux ;; sequent) basic_machine=i386-sequent ;; sh) basic_machine=sh-hitachi os=-hms ;; sh5el) basic_machine=sh5le-unknown ;; sh64) basic_machine=sh64-unknown ;; sparclite-wrs | simso-wrs) basic_machine=sparclite-wrs os=-vxworks ;; sps7) basic_machine=m68k-bull os=-sysv2 ;; spur) basic_machine=spur-unknown ;; st2000) basic_machine=m68k-tandem ;; stratus) basic_machine=i860-stratus os=-sysv4 ;; strongarm-* | thumb-*) basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'` ;; sun2) basic_machine=m68000-sun ;; sun2os3) basic_machine=m68000-sun os=-sunos3 ;; sun2os4) basic_machine=m68000-sun os=-sunos4 ;; sun3os3) basic_machine=m68k-sun os=-sunos3 ;; sun3os4) basic_machine=m68k-sun os=-sunos4 ;; sun4os3) basic_machine=sparc-sun os=-sunos3 ;; sun4os4) basic_machine=sparc-sun os=-sunos4 ;; sun4sol2) basic_machine=sparc-sun os=-solaris2 ;; sun3 | sun3-*) basic_machine=m68k-sun ;; sun4) basic_machine=sparc-sun ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun ;; sv1) basic_machine=sv1-cray os=-unicos ;; symmetry) basic_machine=i386-sequent os=-dynix ;; t3e) basic_machine=alphaev5-cray os=-unicos ;; t90) basic_machine=t90-cray os=-unicos ;; tile*) basic_machine=$basic_machine-unknown os=-linux-gnu ;; tx39) basic_machine=mipstx39-unknown ;; tx39el) basic_machine=mipstx39el-unknown ;; toad1) basic_machine=pdp10-xkl os=-tops20 ;; tower | tower-32) basic_machine=m68k-ncr ;; tpf) basic_machine=s390x-ibm os=-tpf ;; udi29k) basic_machine=a29k-amd os=-udi ;; ultra3) basic_machine=a29k-nyu os=-sym1 ;; v810 | necv810) basic_machine=v810-nec os=-none ;; vaxv) basic_machine=vax-dec os=-sysv ;; vms) basic_machine=vax-dec os=-vms ;; vpp*|vx|vx-*) basic_machine=f301-fujitsu ;; vxworks960) basic_machine=i960-wrs os=-vxworks ;; vxworks68) basic_machine=m68k-wrs os=-vxworks ;; vxworks29k) basic_machine=a29k-wrs os=-vxworks ;; w65*) basic_machine=w65-wdc os=-none ;; w89k-*) basic_machine=hppa1.1-winbond os=-proelf ;; xbox) basic_machine=i686-pc os=-mingw32 ;; xps | xps100) basic_machine=xps100-honeywell ;; xscale-* | xscalee[bl]-*) basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'` ;; ymp) basic_machine=ymp-cray os=-unicos ;; z8k-*-coff) basic_machine=z8k-unknown os=-sim ;; z80-*-coff) basic_machine=z80-unknown os=-sim ;; none) basic_machine=none-none os=-none ;; # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. w89k) basic_machine=hppa1.1-winbond ;; op50n) basic_machine=hppa1.1-oki ;; op60c) basic_machine=hppa1.1-oki ;; romp) basic_machine=romp-ibm ;; mmix) basic_machine=mmix-knuth ;; rs6000) basic_machine=rs6000-ibm ;; vax) basic_machine=vax-dec ;; pdp10) # there are many clones, so DEC is not a safe bet basic_machine=pdp10-unknown ;; pdp11) basic_machine=pdp11-dec ;; we32k) basic_machine=we32k-att ;; sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) basic_machine=sparc-sun ;; cydra) basic_machine=cydra-cydrome ;; orion) basic_machine=orion-highlevel ;; orion105) basic_machine=clipper-highlevel ;; mac | mpw | mac-mpw) basic_machine=m68k-apple ;; pmac | pmac-mpw) basic_machine=powerpc-apple ;; *-unknown) # Make sure to match an already-canonicalized machine name. ;; *) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; esac # Here we canonicalize certain aliases for manufacturers. case $basic_machine in *-digital*) basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` ;; *-commodore*) basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if [ x"$os" != x"" ] then case $os in # First match some system type aliases # that might get confused with valid system types. # -solaris* is a basic system type, with this one exception. -auroraux) os=-auroraux ;; -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` ;; -solaris) os=-solaris2 ;; -svr4*) os=-sysv4 ;; -unixware*) os=-sysv4.2uw ;; -gnu/linux*) os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # First accept the basic system types. # The portable systems comes first. # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ | -sym* | -kopensolaris* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ | -aos* | -aros* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ | -openbsd* | -solidbsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ | -chorusos* | -chorusrdb* | -cegcc* \ | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -mingw32* | -linux-gnu* | -linux-android* \ | -linux-newlib* | -linux-uclibc* \ | -uxpv* | -beos* | -mpeix* | -udk* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) case $basic_machine in x86-* | i*86-*) ;; *) os=-nto$os ;; esac ;; -nto-qnx*) ;; -nto*) os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) ;; -mac*) os=`echo $os | sed -e 's|mac|macos|'` ;; -linux-dietlibc) os=-linux-dietlibc ;; -linux*) os=`echo $os | sed -e 's|linux|linux-gnu|'` ;; -sunos5*) os=`echo $os | sed -e 's|sunos5|solaris2|'` ;; -sunos6*) os=`echo $os | sed -e 's|sunos6|solaris3|'` ;; -opened*) os=-openedition ;; -os400*) os=-os400 ;; -wince*) os=-wince ;; -osfrose*) os=-osfrose ;; -osf*) os=-osf ;; -utek*) os=-bsd ;; -dynix*) os=-bsd ;; -acis*) os=-aos ;; -atheos*) os=-atheos ;; -syllable*) os=-syllable ;; -386bsd) os=-bsd ;; -ctix* | -uts*) os=-sysv ;; -nova*) os=-rtmk-nova ;; -ns2 ) os=-nextstep2 ;; -nsk*) os=-nsk ;; # Preserve the version number of sinix5. -sinix5.*) os=`echo $os | sed -e 's|sinix|sysv|'` ;; -sinix*) os=-sysv4 ;; -tpf*) os=-tpf ;; -triton*) os=-sysv3 ;; -oss*) os=-sysv3 ;; -svr4) os=-sysv4 ;; -svr3) os=-sysv3 ;; -sysvr4) os=-sysv4 ;; # This must come after -sysvr4. -sysv*) ;; -ose*) os=-ose ;; -es1800*) os=-ose ;; -xenix) os=-xenix ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) os=-mint ;; -aros*) os=-aros ;; -kaos*) os=-kaos ;; -zvmoe) os=-zvmoe ;; -dicos*) os=-dicos ;; -nacl*) ;; -none) ;; *) # Get rid of the `-' at the beginning of $os. os=`echo $os | sed 's/[^-]*-//'` echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 exit 1 ;; esac else # Here we handle the default operating systems that come with various machines. # The value should be what the vendor currently ships out the door with their # machine or put another way, the most popular os provided with the machine. # Note that if you're going to try to match "-MANUFACTURER" here (say, # "-sun"), then you have to tell the case statement up towards the top # that MANUFACTURER isn't an operating system. Otherwise, code above # will signal an error saying that MANUFACTURER isn't an operating # system, and we'll never get to this point. case $basic_machine in score-*) os=-elf ;; spu-*) os=-elf ;; *-acorn) os=-riscix1.2 ;; arm*-rebel) os=-linux ;; arm*-semi) os=-aout ;; c4x-* | tic4x-*) os=-coff ;; tic54x-*) os=-coff ;; tic55x-*) os=-coff ;; tic6x-*) os=-coff ;; # This must come before the *-dec entry. pdp10-*) os=-tops20 ;; pdp11-*) os=-none ;; *-dec | vax-*) os=-ultrix4.2 ;; m68*-apollo) os=-domain ;; i386-sun) os=-sunos4.0.2 ;; m68000-sun) os=-sunos3 # This also exists in the configure program, but was not the # default. # os=-sunos4 ;; m68*-cisco) os=-aout ;; mep-*) os=-elf ;; mips*-cisco) os=-elf ;; mips*-*) os=-elf ;; or32-*) os=-coff ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; sparc-* | *-sun) os=-sunos4.1.1 ;; *-be) os=-beos ;; *-haiku) os=-haiku ;; *-ibm) os=-aix ;; *-knuth) os=-mmixware ;; *-wec) os=-proelf ;; *-winbond) os=-proelf ;; *-oki) os=-proelf ;; *-hp) os=-hpux ;; *-hitachi) os=-hiux ;; i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) os=-sysv ;; *-cbm) os=-amigaos ;; *-dg) os=-dgux ;; *-dolphin) os=-sysv3 ;; m68k-ccur) os=-rtu ;; m88k-omron*) os=-luna ;; *-next ) os=-nextstep ;; *-sequent) os=-ptx ;; *-crds) os=-unos ;; *-ns) os=-genix ;; i370-*) os=-mvs ;; *-next) os=-nextstep3 ;; *-gould) os=-sysv ;; *-highlevel) os=-bsd ;; *-encore) os=-bsd ;; *-sgi) os=-irix ;; *-siemens) os=-sysv4 ;; *-masscomp) os=-rtu ;; f30[01]-fujitsu | f700-fujitsu) os=-uxpv ;; *-rom68k) os=-coff ;; *-*bug) os=-coff ;; *-apple) os=-macos ;; *-atari*) os=-mint ;; *) os=-none ;; esac fi # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. vendor=unknown case $basic_machine in *-unknown) case $os in -riscix*) vendor=acorn ;; -sunos*) vendor=sun ;; -cnk*|-aix*) vendor=ibm ;; -beos*) vendor=be ;; -hpux*) vendor=hp ;; -mpeix*) vendor=hp ;; -hiux*) vendor=hitachi ;; -unos*) vendor=crds ;; -dgux*) vendor=dg ;; -luna*) vendor=omron ;; -genix*) vendor=ns ;; -mvs* | -opened*) vendor=ibm ;; -os400*) vendor=ibm ;; -ptx*) vendor=sequent ;; -tpf*) vendor=ibm ;; -vxsim* | -vxworks* | -windiss*) vendor=wrs ;; -aux*) vendor=apple ;; -hms*) vendor=hitachi ;; -mpw* | -macos*) vendor=apple ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) vendor=atari ;; -vos*) vendor=stratus ;; esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; esac echo $basic_machine$os exit # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: algol68g-2.8/install-sh0000755000175000001440000003246411551405127011741 00000000000000#!/bin/sh # install - install a program, script, or datafile scriptversion=2006-12-25.00 # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN # AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- # TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # # Except as contained in this notice, the name of the X Consortium shall not # be used in advertising or otherwise to promote the sale, use or other deal- # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent # `make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. nl=' ' IFS=" "" $nl" # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit=${DOITPROG-} if test -z "$doit"; then doit_exec=exec else doit_exec=$doit fi # Put in absolute file names if you don't have them in your path; # or use environment vars. chgrpprog=${CHGRPPROG-chgrp} chmodprog=${CHMODPROG-chmod} chownprog=${CHOWNPROG-chown} cmpprog=${CMPPROG-cmp} cpprog=${CPPROG-cp} mkdirprog=${MKDIRPROG-mkdir} mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} posix_glob='?' initialize_posix_glob=' test "$posix_glob" != "?" || { if (set -f) 2>/dev/null; then posix_glob= else posix_glob=: fi } ' posix_mkdir= # Desired mode of installed file. mode=0755 chgrpcmd= chmodcmd=$chmodprog chowncmd= mvcmd=$mvprog rmcmd="$rmprog -f" stripcmd= src= dst= dir_arg= dst_arg= copy_on_change=false no_target_directory= usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE or: $0 [OPTION]... SRCFILES... DIRECTORY or: $0 [OPTION]... -t DIRECTORY SRCFILES... or: $0 [OPTION]... -d DIRECTORIES... In the 1st form, copy SRCFILE to DSTFILE. In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. In the 4th, create DIRECTORIES. Options: --help display this help and exit. --version display version info and exit. -c (ignored) -C install only if different (preserve the last data modification time) -d create directories instead of installing files. -g GROUP $chgrpprog installed files to GROUP. -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -s $stripprog installed files. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. Environment variables override the default commands: CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG " while test $# -ne 0; do case $1 in -c) ;; -C) copy_on_change=true;; -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 case $mode in *' '* | *' '* | *' '* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac shift;; -o) chowncmd="$chownprog $2" shift;; -s) stripcmd=$stripprog;; -t) dst_arg=$2 shift;; -T) no_target_directory=true;; --version) echo "$0 $scriptversion"; exit $?;; --) shift break;; -*) echo "$0: invalid option: $1" >&2 exit 1;; *) break;; esac shift done if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. for arg do if test -n "$dst_arg"; then # $@ is not empty: it contains at least $arg. set fnord "$@" "$dst_arg" shift # fnord fi shift # arg dst_arg=$arg done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi # It's OK to call `install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then trap '(exit $?); exit' 1 2 13 15 # Set umask so as not to create temps with too-generous modes. # However, 'strip' requires both read and write access to temps. case $mode in # Optimize common cases. *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do # Protect names starting with `-'. case $src in -*) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? else # Waiting for this to be detected by the "$cpprog $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if test ! -f "$src" && test ! -d "$src"; then echo "$0: $src does not exist." >&2 exit 1 fi if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi dst=$dst_arg # Protect names starting with `-'. case $dst in -*) dst=./$dst;; esac # If destination is a directory, append the input filename; won't work # if double slashes aren't ignored. if test -d "$dst"; then if test -n "$no_target_directory"; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi dstdir=$dst dst=$dstdir/`basename "$src"` dstdir_status=0 else # Prefer dirname, but fall back on a substitute if dirname fails. dstdir=` (dirname "$dst") 2>/dev/null || expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$dst" : 'X\(//\)[^/]' \| \ X"$dst" : 'X\(//\)$' \| \ X"$dst" : 'X\(/\)' \| . 2>/dev/null || echo X"$dst" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q' ` test -d "$dstdir" dstdir_status=$? fi fi obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') # Create intermediate dirs using mode 755 as modified by the umask. # This is like FreeBSD 'install' as of 1997-10-28. umask=`umask` case $stripcmd.$umask in # Optimize common cases. *[2367][2367]) mkdir_umask=$umask;; .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; *[0-7]) mkdir_umask=`expr $umask + 22 \ - $umask % 100 % 40 + $umask % 20 \ - $umask % 10 % 4 + $umask % 2 `;; *) mkdir_umask=$umask,go-w;; esac # With -d, create the new directory with the user-specified mode. # Otherwise, rely on $mkdir_umask. if test -n "$dir_arg"; then mkdir_mode=-m$mode else mkdir_mode= fi posix_mkdir=false case $umask in *[123567][0-7][0-7]) # POSIX mkdir -p sets u+wx bits regardless of umask, which # is incompatible with FreeBSD 'install' when (umask & 300) != 0. ;; *) tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 if (umask $mkdir_umask && exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 then if test -z "$dir_arg" || { # Check for POSIX incompatibilities with -m. # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or # other-writeable bit of parent directory when it shouldn't. # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. ls_ld_tmpdir=`ls -ld "$tmpdir"` case $ls_ld_tmpdir in d????-?r-*) different_mode=700;; d????-?--*) different_mode=755;; *) false;; esac && $mkdirprog -m$different_mode -p -- "$tmpdir" && { ls_ld_tmpdir_1=`ls -ld "$tmpdir"` test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" } } then posix_mkdir=: fi rmdir "$tmpdir/d" "$tmpdir" else # Remove any dirs left behind by ancient mkdir implementations. rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null fi trap '' 0;; esac;; esac if $posix_mkdir && ( umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else # The umask is ridiculous, or mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in /*) prefix='/';; -*) prefix='./';; *) prefix='';; esac eval "$initialize_posix_glob" oIFS=$IFS IFS=/ $posix_glob set -f set fnord $dstdir shift $posix_glob set +f IFS=$oIFS prefixes= for d do test -z "$d" && continue prefix=$prefix$d if test -d "$prefix"; then prefixes= else if $posix_mkdir; then (umask=$mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break # Don't fail if two instances are running concurrently. test -d "$prefix" || exit 1 else case $prefix in *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; *) qprefix=$prefix;; esac prefixes="$prefixes '$qprefix'" fi fi prefix=$prefix/ done if test -n "$prefixes"; then # Don't fail if two instances are running concurrently. (umask $mkdir_umask && eval "\$doit_exec \$mkdirprog $prefixes") || test -d "$dstdir" || exit 1 obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. dsttmp=$dstdir/_inst.$$_ rmtmp=$dstdir/_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $cpprog $src $dsttmp" command. # { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && eval "$initialize_posix_glob" && $posix_glob set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && $posix_glob set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else # Rename the file to the real destination. $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || # The rename failed, perhaps because mv can't rename something else # to itself, or perhaps because mv is so ancient that it does not # support -f. { # Now remove or move aside any old file at destination location. # We try this two ways since rm can't unlink itself on some # systems and the destination file might be busy for other # reasons. In this case, the final cleanup might fail but the new # file should still install successfully. { test ! -f "$dst" || $doit $rmcmd -f "$dst" 2>/dev/null || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } } || { echo "$0: cannot unlink or rename $dst" >&2 (exit 1); exit 1 } } && # Now rename the file to the real destination. $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 trap '' 0 fi done # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-end: "$" # End: algol68g-2.8/README0000644000175000001440000001067012040771430010605 00000000000000ALGOL68G - ALGOL 68 GENIE Algol68G is an implementation of Algol 68 as defined by the Revised Report. It ranks among the most complete implementations of the language. Algol68G is free software, you can redistribute it and/or modify it under the terms of the GNU General Public License. This software 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. The author of this software does not accept responsibility to anyone for the consequences of using it or for whether it serves any particular purpose or works at all. See the GNU General Public License for more details. The GNU General Public License does not permit this software to be redistributed in proprietary programs. THE ALGOL 68 GENIE PROJECT The development of Algol played an important role in establishing computer science as an academic discipline. The Algol 68 Genie project preserves and promotes Algol 68 out of educational as well as scientific-historical interest, by making available a recent checkout compiler-interpreter written from scratch by Marcel van der Veer. Algol 68 Genie is a fast compiler-interpreter which ranks among the most complete implementations of the language; it supports for instance * partial parametrisation, * parallel processing, * formatted transput and a * refinement preprocessor. A detailed description of Algol 68 is in the book Learning Algol 68 Genie which contains an informal introduction to the language, a manual for Algol 68 Genie, and the Revised Report on Algol 68. Algol 68 is a secure, expression-oriented programming language with which you elegantly code algorithms without having to bother too much about irrelevant technical details and limitations inherent to many other languages. Algol 68 Genie offers for example: * many runtime checks facilitating debugging and improving the reliability of your programs, * native support for arbitrary precision arithmetic including complex numbers, * syntactic constructions to support linear algebra, * a gdb-style debugger and a pretty-printer to beautify source code, * optional linkage to GNU plotutils, the GNU scientific library or PostgreSQL, * extensions as UNIX pipes, regular expression matching, and web page content fetching. Author of Algol68G is Marcel van der Veer . Web pages for Algol68G are at . Documentation is available from the web pages for Algol68G. INSTALLATION 1) WIN32 BINARY PACKAGE Unpack the distribution and start command shell cmd.exe. From this shell, enter algol68g-VERSION's directory and start a68g.exe. 2) LINUX, UNIX, BSD, MACOS X Please refer to file INSTALL or the manual for detailed instructions. Since Algol 68 Genie complies with the GNU build system, a reasonably experienced user can execute: tar -xzvf algol68g-VERSION.tgz cd algol68g-VERSION ./configure make make check [su] make install TEST SET The Algol 68 Genie distribution has circa 200 programs in the 'test-set' directory. This test set is very similar to the test set used in the 1980's to validate the ALGOL68RS compilers [Algol Bulletin 49.2]. The test set contains programs from the "Revised Mathematisch Centrum Algol 68 Test Set" [1979] and synthetic programs from the "Rennes test set" [1975]. The "Rennes test-set" programs are automatically generated from the Algol 68 grammar using a formalism from Bernard Houssais (Universite de Rennes). Especially the "Rennes test set" has proven very effective in exposing problems in Algol 68 implementations. The "Revised Mathematisch Centrum test set" programs are not synthetic like those in the "Rennes test set", but are selected programmer-made applications that are distributed with Algol 68 Genie with kind permission of the author of this test set, Dick Grune. All programs are converted to upper-stropping and reformatted for lay-out. Some programs have minor modifications to make them run as batch jobs. Note that circa one-third of the programs in this test set will fail; most due to intentional (syntactic or runtime) errors and a few due to differences between Algol 68 Genie and revised Algol 68. These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68 The complete test set for regression-testing Algol 68 Genie comprises almost 1600 programs. algol68g-2.8/INSTALL0000644000175000001440000002245011551405127010760 00000000000000Installation Instructions ************************* Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. This file is free documentation; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. Basic Installation ================== Briefly, the shell commands `./configure; make; make install' should configure, build, and install this package. The following more-detailed instructions are generic; see the `README' file for instructions specific to this package. The `configure' shell script attempts to guess correct values for various system-dependent variables used during compilation. It uses those values to create a `Makefile' in each directory of the package. It may also create one or more `.h' files containing system-dependent definitions. Finally, it creates a shell script `config.status' that you can run in the future to recreate the current configuration, and a file `config.log' containing compiler output (useful mainly for debugging `configure'). It can also use an optional file (typically called `config.cache' and enabled with `--cache-file=config.cache' or simply `-C') that saves the results of its tests to speed up reconfiguring. Caching is disabled by default to prevent problems with accidental use of stale cache files. If you need to do unusual things to compile the package, please try to figure out how `configure' could check whether to do them, and mail diffs or instructions to the address given in the `README' so they can be considered for the next release. If you are using the cache, and at some point `config.cache' contains results you don't want to keep, you may remove or edit it. The file `configure.ac' (or `configure.in') is used to create `configure' by a program called `autoconf'. You need `configure.ac' if you want to change it or regenerate `configure' using a newer version of `autoconf'. The simplest way to compile this package is: 1. `cd' to the directory containing the package's source code and type `./configure' to configure the package for your system. Running `configure' might take a while. While running, it prints some messages telling which features it is checking for. 2. Type `make' to compile the package. 3. Optionally, type `make check' to run any self-tests that come with the package. 4. Type `make install' to install the programs and any data files and documentation. 5. You can remove the program binaries and object files from the source code directory by typing `make clean'. To also remove the files that `configure' created (so you can compile the package for a different kind of computer), type `make distclean'. There is also a `make maintainer-clean' target, but that is intended mainly for the package's developers. If you use it, you may have to get all sorts of other programs in order to regenerate files that came with the distribution. 6. Often, you can also type `make uninstall' to remove the installed files again. Compilers and Options ===================== Some systems require unusual options for compilation or linking that the `configure' script does not know about. Run `./configure --help' for details on some of the pertinent environment variables. You can give `configure' initial values for configuration parameters by setting variables in the command line or in the environment. Here is an example: ./configure CC=c99 CFLAGS=-g LIBS=-lposix *Note Defining Variables::, for more details. Compiling For Multiple Architectures ==================================== You can compile the package for more than one kind of computer at the same time, by placing the object files for each architecture in their own directory. To do this, you can use GNU `make'. `cd' to the directory where you want the object files and executables to go and run the `configure' script. `configure' automatically checks for the source code in the directory that `configure' is in and in `..'. With a non-GNU `make', it is safer to compile the package for one architecture at a time in the source code directory. After you have installed the package for one architecture, use `make distclean' before reconfiguring for another architecture. Installation Names ================== By default, `make install' installs the package's commands under `/usr/local/bin', include files under `/usr/local/include', etc. You can specify an installation prefix other than `/usr/local' by giving `configure' the option `--prefix=PREFIX'. You can specify separate installation prefixes for architecture-specific files and architecture-independent files. If you pass the option `--exec-prefix=PREFIX' to `configure', the package uses PREFIX as the prefix for installing programs and libraries. Documentation and other data files still use the regular prefix. In addition, if you use an unusual directory layout you can give options like `--bindir=DIR' to specify different values for particular kinds of files. Run `configure --help' for a list of the directories you can set and what kinds of files go in them. If the package supports it, you can cause programs to be installed with an extra prefix or suffix on their names by giving `configure' the option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. Optional Features ================= Some packages pay attention to `--enable-FEATURE' options to `configure', where FEATURE indicates an optional part of the package. They may also pay attention to `--with-PACKAGE' options, where PACKAGE is something like `gnu-as' or `x' (for the X Window System). The `README' should mention any `--enable-' and `--with-' options that the package recognizes. For packages that use the X Window System, `configure' can usually find the X include and library files automatically, but if it doesn't, you can use the `configure' options `--x-includes=DIR' and `--x-libraries=DIR' to specify their locations. Specifying the System Type ========================== There may be some features `configure' cannot figure out automatically, but needs to determine by the type of machine the package will run on. Usually, assuming the package is built to be run on the _same_ architectures, `configure' can figure that out, but if it prints a message saying it cannot guess the machine type, give it the `--build=TYPE' option. TYPE can either be a short name for the system type, such as `sun4', or a canonical name which has the form: CPU-COMPANY-SYSTEM where SYSTEM can have one of these forms: OS KERNEL-OS See the file `config.sub' for the possible values of each field. If `config.sub' isn't included in this package, then this package doesn't need to know the machine type. If you are _building_ compiler tools for cross-compiling, you should use the option `--target=TYPE' to select the type of system they will produce code for. If you want to _use_ a cross compiler, that generates code for a platform different from the build platform, you should specify the "host" platform (i.e., that on which the generated programs will eventually be run) with `--host=TYPE'. Sharing Defaults ================ If you want to set default values for `configure' scripts to share, you can create a site shell script called `config.site' that gives default values for variables like `CC', `cache_file', and `prefix'. `configure' looks for `PREFIX/share/config.site' if it exists, then `PREFIX/etc/config.site' if it exists. Or, you can set the `CONFIG_SITE' environment variable to the location of the site script. A warning: not all `configure' scripts look for a site script. Defining Variables ================== Variables not defined in a site shell script can be set in the environment passed to `configure'. However, some packages may run configure again during the build, and the customized values of these variables may be lost. In order to avoid this problem, you should set them in the `configure' command line, using `VAR=value'. For example: ./configure CC=/usr/local2/bin/gcc causes the specified `gcc' to be used as the C compiler (unless it is overridden in the site shell script). Unfortunately, this technique does not work for `CONFIG_SHELL' due to an Autoconf bug. Until the bug is fixed you can use this workaround: CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash `configure' Invocation ====================== `configure' recognizes the following options to control how it operates. `--help' `-h' Print a summary of the options to `configure', and exit. `--version' `-V' Print the version of Autoconf used to generate the `configure' script, and exit. `--cache-file=FILE' Enable the cache: use and save the results of the tests in FILE, traditionally `config.cache'. FILE defaults to `/dev/null' to disable caching. `--config-cache' `-C' Alias for `--cache-file=config.cache'. `--quiet' `--silent' `-q' Do not print messages saying which checks are being made. To suppress all normal output, redirect it to `/dev/null' (any error messages will still be shown). `--srcdir=DIR' Look for the package's source code in directory DIR. Usually `configure' can determine that directory automatically. `configure' also accepts some other, not widely useful, options. Run `configure --help' for more details. algol68g-2.8/NEWS0000644000175000001440000002241112224300137010414 00000000000000Version 2.8 October 2013 * Fixes build issue on ARM. * Fixes reported bugs in version 2.7. Version 2.7, June 2013 * Larger test set. * Fixes reported bugs in version 2.6. Version 2.6, November 2012 * Larger test set. * Hyperlinked manual. * Fixes reported bugs in version 2.5. Version 2.5, October 2012 * FHS 2.3 compliant. * Larger test set. * Fixes minor issues. * Adds routine "abend" (exits with runtime error). Version 2.4.1, June 2012 * Fixes issue in transput library. * Fixes issue in garbage collector. * Documentation updates. * Better distribution lay-out. Version 2.4, June 2012 * Adds pretty-printer. * Simplified garbage collector. * Adds procedure "read line" (calls GNU readline). * Adds procedure "on gc event". * Adds option --storage [=] n. * Fixes error in option --handles. * Removed the field-selector extension. Version 2.3.9, April 2012 * Fixes curses build issue. * Documentation updates. Version 2.3.8, April 2012 * Fixes build issues on Solaris and Cygwin. * Adds procedures "rows" and "columns". * Documentation updates. Version 2.3.7, February 2012 * Fixes build issue occuring on some platforms. Version 2.3.6, February 2012 * Source code maintenance. * Documentation updates. Version 2.3.5, December 2011 * Fixes issues in 2.3.4. * Source code maintenance. * Documentation updates. Version 2.3.4, November 2011 * Fixes issues in 2.3.3. * Source code maintenance. * Documentation updates. Version 2.3.3, October 2011 * Adds code clause. * Fixes issues in 2.3.2. * Source code maintenance. * Documentation updates. Version 2.3.2, October 2011 * Fixes issues in 2.3.1. * Source code maintenance. * Documentation updates. Version 2.3.1, September 2011 * Adds building on NetBSD. * Fixes minor issues in 2.3.0. * Lint-free source code. Version 2.3.0, September 2011 * Implements ghost elements for empty rows. * Implements non-local environs. * Fixes issues in 2.2.0. * Updates documentation. Version 2.2.0, July 2011 * Improves the parser. * Improves handling of unclosed files. * Adds compilation of uniting. * Adds routine grep in substring. * Fixes minor issues in 2.1.2. * Updates documentation. Version 2.1.2, January 2011 * Updates documentation. * Fixes reported problem in version 2.1.1. Version 2.1.1, January 2011 * Adds configuration options to configure script. * Updates the documentation. * Fixes reported problems in version 2.1.0. * Improves error messages for options to a68g. Version 2.1.0, January 2011 * Upgrades to the GNU build system using autoconf and automake. * Updates the memory management system. * Adds compilation of basic integer-case-clauses. * Adds compilation of LONG INT and LONG REAL units. * Adds optimisation options -O0, -O1, -O2 and -O3. * Adds option --clock. * Fixes reported problems in version 2.0.3. Version 2.0.3, November 2010 * Adds compilation of basic loops; complex loops are interpreted. * Fixes reported build problem on platforms without the GNU Scientific Library. Version 2.0.2, November 2010 * Adds option --script. * Adds Algol 68 comment syntax for shell interpreter call. * Updates documentation. * Regression fixes: 1. A buffering problem could occur when using routines --set or --backspace 2. Some minor errors in the compiler Version 2.0.1, September 2010 * Fix minor inconsistencies between source code and documentation. Version 2.0.0, September 2010 * Adds compiler for units to speed execution. * Adds options --optimise and --no-optimise. * Adds options --compile and --no-compile. * Adds options --object and --no-object. * Adds option --strict. * Improves parser. * Improves diagnostics. * Updates documentation. * Regression fixes: 1. Zero-suppression sometimes failed in formatted transput. 2. The default draw fill style was 1, not 0 as stated in the manual. Version 1.18.0, August 2009 * Regression fixes: 1. Rowing failed for some flexible rows. 2. Generator failed for some structures. 3. Garbage collector could crash under rare circumstances. 4. Some flexible mode declarations were not accepted. 5. Some modes were incorrectly marked as equivalent. 6. Unnecessary size limitations in some matrix operations. 7. Build error on Mac OS X. 8. Alignment error on AMD64. * Adds field-selections as an alternative to selections. * Adds NEW as alternative to HEAP. * More efficient use of memory during compilation. * Documentation updates. * Upon request, re-post the HTML translation of the Revised Report. * Change to a common Linux-style version numbering (former Mark j will now read Version 1.j.0, and former Mark j.k will now read Version 1.j.k) Version 1.17.0, May 2009 * Adds C-style placeholders in formats. * Adds warnings when tags hide declarations with larger reach. * Regression fixes: 1. The while-part range was not visible from deeper ranges in case a loop-clause was the sole unit of a routine-text. 2. SKIP did not generate a value for some modes. * Lint-free source code. * Documentation updates. Version 1.16.0, April 2009 * Regression fixes. * Documentation updates: 1. Adds Revised Report to the LaTeX documentation. 2. Discontinues HTML translation of the Revised Report. Version 1.15.1, January 2009 * Adds Laplace transform. * Regression fixes and documentation updates. Version 1.15.0, December 2008 * Regression fixes and documentation updates. * Improves diagnostics. Version 1.14.1, November 2008 * Implements zero replicators as required by the Revised Report. * Decommissions (undocumented) VMS option syntax. Version 1.14.0, October 2008 * Adds first edition of the Algol 68 Genie User Manual. * Adds Revised Report (HTML translation 1.2) to the documentation. * Adds option --link to the monitor. Version 1.13.0, June 2008 * Adds procedures to interrogate files and directories. * Adds various operators and procedures. * Adds --apropos to command line options and monitor options. Version 1.12.0, May 2008 * Improves code for the parallel clause. * Improves interpreter efficiency. * Improves breakpoint commands in the monitor. * Adds options UNTIL, FINISH and OUT to the monitor. * Adds Revised Report (HTML translation 1.1) to the documentation. Version 1.11.1, March 2008 * Adds options RERUN, RESET and RESTART to monitor. * Adds Revised Report (HTML translation 1.0) to the documentation. Version 1.11.0, November 2007 * Adds support for sound. * Adds Fourier transforms. * Adds pseudo operator DIAG. * Adds pseudo operator TRNSP. * Adds pseudo operator COL. * Adds pseudo operator ROW. * Improves diagnostics in formatted transput. * Improves monitor. Version 1.10.2, April 2007 * Adds procedure "real". * Adds format pattern 'h'. * Adds operator OP SET = (INT, L BITS) L BITS. * Adds operator OP CLEAR = (INT, L BITS) L BITS. Version 1.10.1, December 2006 * Improves interpreter efficiency. Version 1.10.0, August 2006 * Adds basic linear algebra. * Adds procedures "arctan2", "long arctan2" and "long long arctan2". * Adds procedure "execve output". * Improves diagnostics. * Adds option --no-backtrace. Version 1.9.2, July 2006 * Adds typographical display features. Version 1.9.1, May 2006 * 64-bit safe interpreter. * Improves monitor/debugger. * Adds option --monitor (or --debug). * Adds procedure "monitor". Version 1.9.0, March 2006 * Adds basic PostgreSQL support. * Adds procedure "utc time" (UNIX). * Adds procedure "local time" (UNIX). * Improves diagnostic messages. Version 1.8.1, November 2005 * Adds procedure "sub in string" (UNIX). * Adds option --portcheck cf. standard hardware representation. * Adds option --pedantic. Version 1.8.0, July 2005 * Adds procedure "http content" (UNIX). * Adds procedure "tcp request" (UNIX). * Adds procedure "grep in string" (UNIX). * Adds procedure "last char in string". * Adds procedure "string in string". * Adds keyword UNTIL to implement post checked loop. * Adds keyword DOWNTO to complement TO. * Adds keyword ANDTH as alternative for ANDF and keyword OREL as alternative for ORF. * Makes ~ a SKIP when used as a unit (cf. RR). Version 1.7.0, May 2005 * Adds partial parameterisation following C. H. Lindsey's proposal. * Adds elementary and trigonometric functions for complex numbers, independent of GSL. Version 1.6.0, March 2005 * Adds parallel clause on platforms that support POSIX threads. Version 1.5.0, October 2004 * Improves interpreter efficiency. * Adds transput on STRING as well as FILE and PIPE. * Adds dynamic scope checking. * Adds basic preprocessor. * Adds curses support. Version 1.4.0, June 2004 * Adds more GSL support. * Adds modes LONG BITS and LONG LONG BITS. * Makes parser accept ( .. ) as alternative for [ .. ]. * Makes parser optionally treat { .. }, [ .. ] and ( .. ) as equivalent. * Makes parser accept loop clause as encloses clause. * Makes mode checker accept UNION with components relates through deflexing. * Changes to thread safe plotutils interface. Version 1.3.2, March 2004 * Adds overflow checks for primitive modes. Version 1.3.1, January 2004 * Adds optional system stack overflow handling to interpreter. * Improves multiprecision library. Version 1.3.0, September 2003 * Adds formatted transput. * Improves speed of multiprecision library. Version 1.2.0, March 2003 * Adds mode BYTES and LONG BYTES. * Adds mode FORMAT and parsing of FORMAT texts. * Adds straightening in unformatted transput. * Adds mode PIPE and UNIX support. * Changes to UNIX system level IO. Version 1.1.0, November 2002 Version 1.0.0, September 2002 Beta releases from November 2001 onward. algol68g-2.8/COPYING0000644000175000001440000010451311551405127010763 00000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 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 . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . algol68g-2.8/Makefile.in0000644000175000001440000016262412224300602011772 00000000000000# Makefile.in generated by automake 1.10.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, # 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ pkgdatadir = $(datadir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : build_triplet = @build@ host_triplet = @host@ target_triplet = @target@ bin_PROGRAMS = a68g$(EXEEXT) subdir = . DIST_COMMON = README $(am__configure_deps) $(pkginclude_HEADERS) \ $(srcdir)/Makefile.am $(srcdir)/Makefile.in \ $(top_srcdir)/configure $(top_srcdir)/source/a68g-config.h.in \ AUTHORS COPYING ChangeLog INSTALL NEWS compile config.guess \ config.sub depcomp install-sh missing ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ configure.lineno config.status.lineno mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/source/a68g-config.h CONFIG_CLEAN_FILES = am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(man1dir)" \ "$(DESTDIR)$(docdir)" "$(DESTDIR)$(pkgincludedir)" binPROGRAMS_INSTALL = $(INSTALL_PROGRAM) PROGRAMS = $(bin_PROGRAMS) am__dirstamp = $(am__leading_dot)dirstamp am_a68g_OBJECTS = source/a68g-a68g.$(OBJEXT) \ source/a68g-code.$(OBJEXT) source/a68g-environ.$(OBJEXT) \ source/a68g-genie.$(OBJEXT) source/a68g-gsl.$(OBJEXT) \ source/a68g-inet.$(OBJEXT) source/a68g-monitor.$(OBJEXT) \ source/a68g-mp.$(OBJEXT) source/a68g-plotutils.$(OBJEXT) \ source/a68g-postgresql.$(OBJEXT) source/a68g-pretty.$(OBJEXT) \ source/a68g-syntax.$(OBJEXT) a68g_OBJECTS = $(am_a68g_OBJECTS) a68g_LDADD = $(LDADD) a68g_LINK = $(CCLD) $(a68g_CFLAGS) $(CFLAGS) $(a68g_LDFLAGS) \ $(LDFLAGS) -o $@ DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir)/source depcomp = $(SHELL) $(top_srcdir)/depcomp am__depfiles_maybe = depfiles COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) CCLD = $(CC) LINK = $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@ SOURCES = $(a68g_SOURCES) DIST_SOURCES = $(a68g_SOURCES) man1dir = $(mandir)/man1 NROFF = nroff MANS = $(man_MANS) am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; am__vpath_adj = case $$p in \ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ *) f=$$p;; \ esac; am__strip_dir = `echo $$p | sed -e 's|^.*/||'`; docDATA_INSTALL = $(INSTALL_DATA) DATA = $(doc_DATA) pkgincludeHEADERS_INSTALL = $(INSTALL_HEADER) HEADERS = $(pkginclude_HEADERS) ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) distdir = $(PACKAGE)-$(VERSION) top_distdir = $(distdir) am__remove_distdir = \ { test ! -d $(distdir) \ || { find $(distdir) -type d ! -perm -200 -exec chmod u+w {} ';' \ && rm -fr $(distdir); }; } DIST_ARCHIVES = $(distdir).tar.gz GZIP_ENV = --best distuninstallcheck_listfiles = find . -type f -print distcleancheck_listfiles = find . -type f -print ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LTLIBOBJS = @LTLIBOBJS@ MAKEINFO = @MAKEINFO@ MKDIR_P = @MKDIR_P@ OBJEXT = @OBJEXT@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ STRIP = @STRIP@ VERSION = @VERSION@ a68g_exists = @a68g_exists@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_CC = @ac_ct_CC@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build = @build@ build_alias = @build_alias@ build_cpu = @build_cpu@ build_os = @build_os@ build_vendor = @build_vendor@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host = @host@ host_alias = @host_alias@ host_cpu = @host_cpu@ host_os = @host_os@ host_vendor = @host_vendor@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target = @target@ target_alias = @target_alias@ target_cpu = @target_cpu@ target_os = @target_os@ target_vendor = @target_vendor@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ CYGWIN_RELEASE = 0 a68g_SOURCES = source/a68g.c source/code.c source/environ.c source/genie.c source/gsl.c source/inet.c source/monitor.c source/mp.c source/plotutils.c source/postgresql.c source/pretty.c source/syntax.c a68g_CFLAGS = -DBINDIR='"$(bindir)"' -DINCLUDEDIR='"$(includedir)"' TESTS_ENVIRONMENT = ./a68g XFAIL_TESTS = \ test-set/a68g.mc.008.appl08.a68\ test-set/a68g.mc.011.appl11.a68\ test-set/a68g.mc.015.appl15.a68\ test-set/a68g.mc.018.appl18.a68\ test-set/a68g.mc.019.appl19.a68\ test-set/a68g.mc.021.clau02.a68\ test-set/a68g.mc.022.clau03.a68\ test-set/a68g.mc.023.clau04.a68\ test-set/a68g.mc.025.clau06.a68\ test-set/a68g.mc.030.coer02.a68\ test-set/a68g.mc.032.coer04.a68\ test-set/a68g.mc.033.coer05.a68\ test-set/a68g.mc.034.coer06.a68\ test-set/a68g.mc.042.decl01.a68\ test-set/a68g.mc.043.decl02.a68\ test-set/a68g.mc.047.decl06.a68\ test-set/a68g.mc.048.decl07.a68\ test-set/a68g.mc.049.flex01.a68\ test-set/a68g.mc.050.flex02.a68\ test-set/a68g.mc.051.flex03.a68\ test-set/a68g.mc.052.flex04.a68\ test-set/a68g.mc.061.idef05.a68\ test-set/a68g.mc.066.idef10.a68\ test-set/a68g.mc.068.idef12.a68\ test-set/a68g.mc.070.idrl02.a68\ test-set/a68g.mc.072.jump02.a68\ test-set/a68g.mc.076.mdeq01.a68\ test-set/a68g.mc.078.mdeq03.a68\ test-set/a68g.mc.080.mdeq05.a68\ test-set/a68g.mc.081.mdeq06.a68\ test-set/a68g.mc.082.misc01.a68\ test-set/a68g.mc.083.misc02.a68\ test-set/a68g.mc.084.misc03.a68\ test-set/a68g.mc.085.misc04.a68\ test-set/a68g.mc.087.misc06.a68\ test-set/a68g.mc.109.numr13.a68\ test-set/a68g.mc.113.oper04.a68\ test-set/a68g.mc.114.oper05.a68\ test-set/a68g.mc.115.oper06.a68\ test-set/a68g.mc.121.oper12.a68\ test-set/a68g.mc.122.oper13.a68\ test-set/a68g.mc.124.oper15.a68\ test-set/a68g.mc.125.oper16.a68\ test-set/a68g.mc.126.scop01.a68\ test-set/a68g.mc.127.scop02.a68\ test-set/a68g.mc.128.scop03.a68\ test-set/a68g.mc.129.scop04.a68\ test-set/a68g.mc.133.scop08.a68\ test-set/a68g.mc.134.scop09.a68\ test-set/a68g.mc.147.simp12.a68\ test-set/a68g.mc.149.simp15.a68\ test-set/a68g.mc.151.smio01.a68\ test-set/a68g.mc.153.smio03.a68\ test-set/a68g.mc.154.smio04.a68\ test-set/a68g.mc.155.smio05.a68\ test-set/a68g.mc.156.smio06.a68\ test-set/a68g.mc.158.smio09.a68\ test-set/a68g.mc.162.stan02.a68\ test-set/a68g.mc.163.stan03.a68\ test-set/a68g.mc.165.stow02.a68\ test-set/a68g.mc.166.stow03.a68\ test-set/a68g.mc.167.stow04.a68\ test-set/a68g.mc.168.stow05.a68\ test-set/a68g.mc.172.synt01.a68\ test-set/a68g.mc.173.synt02.a68\ test-set/a68g.mc.174.synt03.a68\ test-set/a68g.mc.175.synt04.a68\ test-set/a68g.mc.177.synt06.a68\ test-set/a68g.mc.178.synt07.a68\ test-set/a68g.mc.179.synt08.a68 TESTS = \ test-set/a68g.mc.001.appl01.a68\ test-set/a68g.mc.002.appl02.a68\ test-set/a68g.mc.003.appl03.a68\ test-set/a68g.mc.004.appl04.a68\ test-set/a68g.mc.005.appl05.a68\ test-set/a68g.mc.006.appl06.a68\ test-set/a68g.mc.007.appl07.a68\ test-set/a68g.mc.008.appl08.a68\ test-set/a68g.mc.009.appl09.a68\ test-set/a68g.mc.010.appl10.a68\ test-set/a68g.mc.011.appl11.a68\ test-set/a68g.mc.012.appl12.a68\ test-set/a68g.mc.013.appl13.a68\ test-set/a68g.mc.014.appl14.a68\ test-set/a68g.mc.015.appl15.a68\ test-set/a68g.mc.016.appl16.a68\ test-set/a68g.mc.017.appl17.a68\ test-set/a68g.mc.018.appl18.a68\ test-set/a68g.mc.019.appl19.a68\ test-set/a68g.mc.020.clau01.a68\ test-set/a68g.mc.021.clau02.a68\ test-set/a68g.mc.022.clau03.a68\ test-set/a68g.mc.023.clau04.a68\ test-set/a68g.mc.024.clau05.a68\ test-set/a68g.mc.025.clau06.a68\ test-set/a68g.mc.026.clau07.a68\ test-set/a68g.mc.027.clau08.a68\ test-set/a68g.mc.028.clau09.a68\ test-set/a68g.mc.029.coer01.a68\ test-set/a68g.mc.030.coer02.a68\ test-set/a68g.mc.031.coer03.a68\ test-set/a68g.mc.032.coer04.a68\ test-set/a68g.mc.033.coer05.a68\ test-set/a68g.mc.034.coer06.a68\ test-set/a68g.mc.035.coer07.a68\ test-set/a68g.mc.036.coer08.a68\ test-set/a68g.mc.037.coer09.a68\ test-set/a68g.mc.038.coer10.a68\ test-set/a68g.mc.039.coer11.a68\ test-set/a68g.mc.040.coer13.a68\ test-set/a68g.mc.041.coer14.a68\ test-set/a68g.mc.042.decl01.a68\ test-set/a68g.mc.043.decl02.a68\ test-set/a68g.mc.044.decl03.a68\ test-set/a68g.mc.045.decl04.a68\ test-set/a68g.mc.046.decl05.a68\ test-set/a68g.mc.047.decl06.a68\ test-set/a68g.mc.048.decl07.a68\ test-set/a68g.mc.049.flex01.a68\ test-set/a68g.mc.050.flex02.a68\ test-set/a68g.mc.051.flex03.a68\ test-set/a68g.mc.052.flex04.a68\ test-set/a68g.mc.053.garb01.a68\ test-set/a68g.mc.054.garb02.a68\ test-set/a68g.mc.055.garb03.a68\ test-set/a68g.mc.056.garb04.a68\ test-set/a68g.mc.057.idef01.a68\ test-set/a68g.mc.058.idef02.a68\ test-set/a68g.mc.059.idef03.a68\ test-set/a68g.mc.060.idef04.a68\ test-set/a68g.mc.061.idef05.a68\ test-set/a68g.mc.062.idef06.a68\ test-set/a68g.mc.063.idef07.a68\ test-set/a68g.mc.064.idef08.a68\ test-set/a68g.mc.065.idef09.a68\ test-set/a68g.mc.066.idef10.a68\ test-set/a68g.mc.067.idef11.a68\ test-set/a68g.mc.068.idef12.a68\ test-set/a68g.mc.069.idrl01.a68\ test-set/a68g.mc.070.idrl02.a68\ test-set/a68g.mc.071.jump01.a68\ test-set/a68g.mc.072.jump02.a68\ test-set/a68g.mc.073.jump03.a68\ test-set/a68g.mc.074.jump04.a68\ test-set/a68g.mc.075.jump05.a68\ test-set/a68g.mc.076.mdeq01.a68\ test-set/a68g.mc.077.mdeq02.a68\ test-set/a68g.mc.078.mdeq03.a68\ test-set/a68g.mc.079.mdeq04.a68\ test-set/a68g.mc.080.mdeq05.a68\ test-set/a68g.mc.081.mdeq06.a68\ test-set/a68g.mc.082.misc01.a68\ test-set/a68g.mc.083.misc02.a68\ test-set/a68g.mc.084.misc03.a68\ test-set/a68g.mc.085.misc04.a68\ test-set/a68g.mc.086.misc05.a68\ test-set/a68g.mc.087.misc06.a68\ test-set/a68g.mc.088.misc07.a68\ test-set/a68g.mc.089.null01.a68\ test-set/a68g.mc.090.null02.a68\ test-set/a68g.mc.091.null03.a68\ test-set/a68g.mc.092.null04.a68\ test-set/a68g.mc.093.null06.a68\ test-set/a68g.mc.094.null07.a68\ test-set/a68g.mc.095.null08.a68\ test-set/a68g.mc.096.null09.a68\ test-set/a68g.mc.097.numr01.a68\ test-set/a68g.mc.098.numr02.a68\ test-set/a68g.mc.099.numr03.a68\ test-set/a68g.mc.100.numr04.a68\ test-set/a68g.mc.101.numr05.a68\ test-set/a68g.mc.102.numr06.a68\ test-set/a68g.mc.103.numr07.a68\ test-set/a68g.mc.104.numr08.a68\ test-set/a68g.mc.105.numr09.a68\ test-set/a68g.mc.106.numr10.a68\ test-set/a68g.mc.107.numr11.a68\ test-set/a68g.mc.108.numr12.a68\ test-set/a68g.mc.109.numr13.a68\ test-set/a68g.mc.110.oper01.a68\ test-set/a68g.mc.111.oper02.a68\ test-set/a68g.mc.112.oper03.a68\ test-set/a68g.mc.113.oper04.a68\ test-set/a68g.mc.114.oper05.a68\ test-set/a68g.mc.115.oper06.a68\ test-set/a68g.mc.116.oper07.a68\ test-set/a68g.mc.117.oper08.a68\ test-set/a68g.mc.118.oper09.a68\ test-set/a68g.mc.119.oper10.a68\ test-set/a68g.mc.120.oper11.a68\ test-set/a68g.mc.121.oper12.a68\ test-set/a68g.mc.122.oper13.a68\ test-set/a68g.mc.123.oper14.a68\ test-set/a68g.mc.124.oper15.a68\ test-set/a68g.mc.125.oper16.a68\ test-set/a68g.mc.126.scop01.a68\ test-set/a68g.mc.127.scop02.a68\ test-set/a68g.mc.128.scop03.a68\ test-set/a68g.mc.129.scop04.a68\ test-set/a68g.mc.130.scop05.a68\ test-set/a68g.mc.131.scop06.a68\ test-set/a68g.mc.132.scop07.a68\ test-set/a68g.mc.133.scop08.a68\ test-set/a68g.mc.134.scop09.a68\ test-set/a68g.mc.135.scop10.a68\ test-set/a68g.mc.136.simp01.a68\ test-set/a68g.mc.137.simp02.a68\ test-set/a68g.mc.138.simp03.a68\ test-set/a68g.mc.139.simp04.a68\ test-set/a68g.mc.140.simp05.a68\ test-set/a68g.mc.141.simp06.a68\ test-set/a68g.mc.142.simp07.a68\ test-set/a68g.mc.143.simp08.a68\ test-set/a68g.mc.144.simp09.a68\ test-set/a68g.mc.145.simp10.a68\ test-set/a68g.mc.146.simp11.a68\ test-set/a68g.mc.147.simp12.a68\ test-set/a68g.mc.148.simp13.a68\ test-set/a68g.mc.149.simp15.a68\ test-set/a68g.mc.150.simp16.a68\ test-set/a68g.mc.151.smio01.a68\ test-set/a68g.mc.152.smio02.a68\ test-set/a68g.mc.153.smio03.a68\ test-set/a68g.mc.154.smio04.a68\ test-set/a68g.mc.155.smio05.a68\ test-set/a68g.mc.156.smio06.a68\ test-set/a68g.mc.157.smio08.a68\ test-set/a68g.mc.158.smio09.a68\ test-set/a68g.mc.159.smio10.a68\ test-set/a68g.mc.160.smio11.a68\ test-set/a68g.mc.161.smio12.a68\ test-set/a68g.mc.162.stan02.a68\ test-set/a68g.mc.163.stan03.a68\ test-set/a68g.mc.164.stow01.a68\ test-set/a68g.mc.165.stow02.a68\ test-set/a68g.mc.166.stow03.a68\ test-set/a68g.mc.167.stow04.a68\ test-set/a68g.mc.168.stow05.a68\ test-set/a68g.mc.169.stow06.a68\ test-set/a68g.mc.170.stow07.a68\ test-set/a68g.mc.171.stow08.a68\ test-set/a68g.mc.172.synt01.a68\ test-set/a68g.mc.173.synt02.a68\ test-set/a68g.mc.174.synt03.a68\ test-set/a68g.mc.175.synt04.a68\ test-set/a68g.mc.176.synt05.a68\ test-set/a68g.mc.177.synt06.a68\ test-set/a68g.mc.178.synt07.a68\ test-set/a68g.mc.179.synt08.a68\ test-set/a68g.ur.180.r31.a68\ test-set/a68g.ur.181.r33d.a68\ test-set/a68g.ur.182.r34a.a68\ test-set/a68g.ur.183.r541a.a68\ test-set/a68g.ur.184.r541b.a68\ test-set/a68g.ur.185.r541c.a68\ test-set/a68g.ur.186.r542a.a68\ test-set/a68g.ur.187.r542b.a68\ test-set/a68g.ur.188.r542c.a68\ test-set/a68g.ur.189.r6b.a68\ test-set/a68g.ur.190.r6d.a68\ test-set/a68g.ur.191.r6e.a68\ test-set/a68g.ur.192.r71a.a68\ test-set/a68g.ur.193.r71b.a68\ test-set/a68g.ur.194.r72a.a68\ test-set/a68g.ur.195.r8.a68\ test-set/a68g.ur.196.r811.a68\ test-set/a68g.ur.197.r812.a68\ test-set/a68g.ur.198.r9.a68 @EXPORT_DYNAMIC_FALSE@a68g_LDFLAGS = @EXPORT_DYNAMIC_TRUE@a68g_LDFLAGS = -Wl,--export-dynamic pkginclude_HEADERS = source/a68g.h source/a68g-config.h man_MANS = doc/a68g.1 doc_DATA = AUTHORS COPYING NEWS README EXTRA_DIST = $(man_MANS)\ $(TESTS)\ ./ISSUES all: all-am .SUFFIXES: .SUFFIXES: .c .o .obj am--refresh: @: $(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ echo ' cd $(srcdir) && $(AUTOMAKE) --gnu '; \ cd $(srcdir) && $(AUTOMAKE) --gnu \ && exit 0; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu Makefile'; \ cd $(top_srcdir) && \ $(AUTOMAKE) --gnu Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ echo ' $(SHELL) ./config.status'; \ $(SHELL) ./config.status;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) $(SHELL) ./config.status --recheck $(top_srcdir)/configure: $(am__configure_deps) cd $(srcdir) && $(AUTOCONF) $(ACLOCAL_M4): $(am__aclocal_m4_deps) cd $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) source/a68g-config.h: source/stamp-h1 @if test ! -f $@; then \ rm -f source/stamp-h1; \ $(MAKE) $(AM_MAKEFLAGS) source/stamp-h1; \ else :; fi source/stamp-h1: $(top_srcdir)/source/a68g-config.h.in $(top_builddir)/config.status @rm -f source/stamp-h1 cd $(top_builddir) && $(SHELL) ./config.status source/a68g-config.h $(top_srcdir)/source/a68g-config.h.in: $(am__configure_deps) cd $(top_srcdir) && $(AUTOHEADER) rm -f source/stamp-h1 touch $@ distclean-hdr: -rm -f source/a68g-config.h source/stamp-h1 install-binPROGRAMS: $(bin_PROGRAMS) @$(NORMAL_INSTALL) test -z "$(bindir)" || $(MKDIR_P) "$(DESTDIR)$(bindir)" @list='$(bin_PROGRAMS)'; for p in $$list; do \ p1=`echo $$p|sed 's/$(EXEEXT)$$//'`; \ if test -f $$p \ ; then \ f=`echo "$$p1" | sed 's,^.*/,,;$(transform);s/$$/$(EXEEXT)/'`; \ echo " $(INSTALL_PROGRAM_ENV) $(binPROGRAMS_INSTALL) '$$p' '$(DESTDIR)$(bindir)/$$f'"; \ $(INSTALL_PROGRAM_ENV) $(binPROGRAMS_INSTALL) "$$p" "$(DESTDIR)$(bindir)/$$f" || exit 1; \ else :; fi; \ done uninstall-binPROGRAMS: @$(NORMAL_UNINSTALL) @list='$(bin_PROGRAMS)'; for p in $$list; do \ f=`echo "$$p" | sed 's,^.*/,,;s/$(EXEEXT)$$//;$(transform);s/$$/$(EXEEXT)/'`; \ echo " rm -f '$(DESTDIR)$(bindir)/$$f'"; \ rm -f "$(DESTDIR)$(bindir)/$$f"; \ done clean-binPROGRAMS: -test -z "$(bin_PROGRAMS)" || rm -f $(bin_PROGRAMS) source/$(am__dirstamp): @$(MKDIR_P) source @: > source/$(am__dirstamp) source/$(DEPDIR)/$(am__dirstamp): @$(MKDIR_P) source/$(DEPDIR) @: > source/$(DEPDIR)/$(am__dirstamp) source/a68g-a68g.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-code.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-environ.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-genie.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-gsl.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-inet.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-monitor.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-mp.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-plotutils.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-postgresql.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-pretty.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) source/a68g-syntax.$(OBJEXT): source/$(am__dirstamp) \ source/$(DEPDIR)/$(am__dirstamp) a68g$(EXEEXT): $(a68g_OBJECTS) $(a68g_DEPENDENCIES) @rm -f a68g$(EXEEXT) $(a68g_LINK) $(a68g_OBJECTS) $(a68g_LDADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) -rm -f source/a68g-a68g.$(OBJEXT) -rm -f source/a68g-code.$(OBJEXT) -rm -f source/a68g-environ.$(OBJEXT) -rm -f source/a68g-genie.$(OBJEXT) -rm -f source/a68g-gsl.$(OBJEXT) -rm -f source/a68g-inet.$(OBJEXT) -rm -f source/a68g-monitor.$(OBJEXT) -rm -f source/a68g-mp.$(OBJEXT) -rm -f source/a68g-plotutils.$(OBJEXT) -rm -f source/a68g-postgresql.$(OBJEXT) -rm -f source/a68g-pretty.$(OBJEXT) -rm -f source/a68g-syntax.$(OBJEXT) distclean-compile: -rm -f *.tab.c @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-a68g.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-code.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-environ.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-genie.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-gsl.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-inet.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-monitor.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-mp.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-plotutils.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-postgresql.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-pretty.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@source/$(DEPDIR)/a68g-syntax.Po@am__quote@ .c.o: @am__fastdepCC_TRUE@ depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.o$$||'`;\ @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ $< &&\ @am__fastdepCC_TRUE@ mv -f $$depbase.Tpo $$depbase.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(COMPILE) -c -o $@ $< .c.obj: @am__fastdepCC_TRUE@ depbase=`echo $@ | sed 's|[^/]*$$|$(DEPDIR)/&|;s|\.obj$$||'`;\ @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $$depbase.Tpo -c -o $@ `$(CYGPATH_W) '$<'` &&\ @am__fastdepCC_TRUE@ mv -f $$depbase.Tpo $$depbase.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` source/a68g-a68g.o: source/a68g.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-a68g.o -MD -MP -MF source/$(DEPDIR)/a68g-a68g.Tpo -c -o source/a68g-a68g.o `test -f 'source/a68g.c' || echo '$(srcdir)/'`source/a68g.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-a68g.Tpo source/$(DEPDIR)/a68g-a68g.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/a68g.c' object='source/a68g-a68g.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-a68g.o `test -f 'source/a68g.c' || echo '$(srcdir)/'`source/a68g.c source/a68g-a68g.obj: source/a68g.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-a68g.obj -MD -MP -MF source/$(DEPDIR)/a68g-a68g.Tpo -c -o source/a68g-a68g.obj `if test -f 'source/a68g.c'; then $(CYGPATH_W) 'source/a68g.c'; else $(CYGPATH_W) '$(srcdir)/source/a68g.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-a68g.Tpo source/$(DEPDIR)/a68g-a68g.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/a68g.c' object='source/a68g-a68g.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-a68g.obj `if test -f 'source/a68g.c'; then $(CYGPATH_W) 'source/a68g.c'; else $(CYGPATH_W) '$(srcdir)/source/a68g.c'; fi` source/a68g-code.o: source/code.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-code.o -MD -MP -MF source/$(DEPDIR)/a68g-code.Tpo -c -o source/a68g-code.o `test -f 'source/code.c' || echo '$(srcdir)/'`source/code.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-code.Tpo source/$(DEPDIR)/a68g-code.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/code.c' object='source/a68g-code.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-code.o `test -f 'source/code.c' || echo '$(srcdir)/'`source/code.c source/a68g-code.obj: source/code.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-code.obj -MD -MP -MF source/$(DEPDIR)/a68g-code.Tpo -c -o source/a68g-code.obj `if test -f 'source/code.c'; then $(CYGPATH_W) 'source/code.c'; else $(CYGPATH_W) '$(srcdir)/source/code.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-code.Tpo source/$(DEPDIR)/a68g-code.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/code.c' object='source/a68g-code.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-code.obj `if test -f 'source/code.c'; then $(CYGPATH_W) 'source/code.c'; else $(CYGPATH_W) '$(srcdir)/source/code.c'; fi` source/a68g-environ.o: source/environ.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-environ.o -MD -MP -MF source/$(DEPDIR)/a68g-environ.Tpo -c -o source/a68g-environ.o `test -f 'source/environ.c' || echo '$(srcdir)/'`source/environ.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-environ.Tpo source/$(DEPDIR)/a68g-environ.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/environ.c' object='source/a68g-environ.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-environ.o `test -f 'source/environ.c' || echo '$(srcdir)/'`source/environ.c source/a68g-environ.obj: source/environ.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-environ.obj -MD -MP -MF source/$(DEPDIR)/a68g-environ.Tpo -c -o source/a68g-environ.obj `if test -f 'source/environ.c'; then $(CYGPATH_W) 'source/environ.c'; else $(CYGPATH_W) '$(srcdir)/source/environ.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-environ.Tpo source/$(DEPDIR)/a68g-environ.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/environ.c' object='source/a68g-environ.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-environ.obj `if test -f 'source/environ.c'; then $(CYGPATH_W) 'source/environ.c'; else $(CYGPATH_W) '$(srcdir)/source/environ.c'; fi` source/a68g-genie.o: source/genie.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-genie.o -MD -MP -MF source/$(DEPDIR)/a68g-genie.Tpo -c -o source/a68g-genie.o `test -f 'source/genie.c' || echo '$(srcdir)/'`source/genie.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-genie.Tpo source/$(DEPDIR)/a68g-genie.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/genie.c' object='source/a68g-genie.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-genie.o `test -f 'source/genie.c' || echo '$(srcdir)/'`source/genie.c source/a68g-genie.obj: source/genie.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-genie.obj -MD -MP -MF source/$(DEPDIR)/a68g-genie.Tpo -c -o source/a68g-genie.obj `if test -f 'source/genie.c'; then $(CYGPATH_W) 'source/genie.c'; else $(CYGPATH_W) '$(srcdir)/source/genie.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-genie.Tpo source/$(DEPDIR)/a68g-genie.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/genie.c' object='source/a68g-genie.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-genie.obj `if test -f 'source/genie.c'; then $(CYGPATH_W) 'source/genie.c'; else $(CYGPATH_W) '$(srcdir)/source/genie.c'; fi` source/a68g-gsl.o: source/gsl.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-gsl.o -MD -MP -MF source/$(DEPDIR)/a68g-gsl.Tpo -c -o source/a68g-gsl.o `test -f 'source/gsl.c' || echo '$(srcdir)/'`source/gsl.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-gsl.Tpo source/$(DEPDIR)/a68g-gsl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/gsl.c' object='source/a68g-gsl.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-gsl.o `test -f 'source/gsl.c' || echo '$(srcdir)/'`source/gsl.c source/a68g-gsl.obj: source/gsl.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-gsl.obj -MD -MP -MF source/$(DEPDIR)/a68g-gsl.Tpo -c -o source/a68g-gsl.obj `if test -f 'source/gsl.c'; then $(CYGPATH_W) 'source/gsl.c'; else $(CYGPATH_W) '$(srcdir)/source/gsl.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-gsl.Tpo source/$(DEPDIR)/a68g-gsl.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/gsl.c' object='source/a68g-gsl.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-gsl.obj `if test -f 'source/gsl.c'; then $(CYGPATH_W) 'source/gsl.c'; else $(CYGPATH_W) '$(srcdir)/source/gsl.c'; fi` source/a68g-inet.o: source/inet.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-inet.o -MD -MP -MF source/$(DEPDIR)/a68g-inet.Tpo -c -o source/a68g-inet.o `test -f 'source/inet.c' || echo '$(srcdir)/'`source/inet.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-inet.Tpo source/$(DEPDIR)/a68g-inet.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/inet.c' object='source/a68g-inet.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-inet.o `test -f 'source/inet.c' || echo '$(srcdir)/'`source/inet.c source/a68g-inet.obj: source/inet.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-inet.obj -MD -MP -MF source/$(DEPDIR)/a68g-inet.Tpo -c -o source/a68g-inet.obj `if test -f 'source/inet.c'; then $(CYGPATH_W) 'source/inet.c'; else $(CYGPATH_W) '$(srcdir)/source/inet.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-inet.Tpo source/$(DEPDIR)/a68g-inet.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/inet.c' object='source/a68g-inet.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-inet.obj `if test -f 'source/inet.c'; then $(CYGPATH_W) 'source/inet.c'; else $(CYGPATH_W) '$(srcdir)/source/inet.c'; fi` source/a68g-monitor.o: source/monitor.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-monitor.o -MD -MP -MF source/$(DEPDIR)/a68g-monitor.Tpo -c -o source/a68g-monitor.o `test -f 'source/monitor.c' || echo '$(srcdir)/'`source/monitor.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-monitor.Tpo source/$(DEPDIR)/a68g-monitor.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/monitor.c' object='source/a68g-monitor.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-monitor.o `test -f 'source/monitor.c' || echo '$(srcdir)/'`source/monitor.c source/a68g-monitor.obj: source/monitor.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-monitor.obj -MD -MP -MF source/$(DEPDIR)/a68g-monitor.Tpo -c -o source/a68g-monitor.obj `if test -f 'source/monitor.c'; then $(CYGPATH_W) 'source/monitor.c'; else $(CYGPATH_W) '$(srcdir)/source/monitor.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-monitor.Tpo source/$(DEPDIR)/a68g-monitor.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/monitor.c' object='source/a68g-monitor.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-monitor.obj `if test -f 'source/monitor.c'; then $(CYGPATH_W) 'source/monitor.c'; else $(CYGPATH_W) '$(srcdir)/source/monitor.c'; fi` source/a68g-mp.o: source/mp.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-mp.o -MD -MP -MF source/$(DEPDIR)/a68g-mp.Tpo -c -o source/a68g-mp.o `test -f 'source/mp.c' || echo '$(srcdir)/'`source/mp.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-mp.Tpo source/$(DEPDIR)/a68g-mp.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/mp.c' object='source/a68g-mp.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-mp.o `test -f 'source/mp.c' || echo '$(srcdir)/'`source/mp.c source/a68g-mp.obj: source/mp.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-mp.obj -MD -MP -MF source/$(DEPDIR)/a68g-mp.Tpo -c -o source/a68g-mp.obj `if test -f 'source/mp.c'; then $(CYGPATH_W) 'source/mp.c'; else $(CYGPATH_W) '$(srcdir)/source/mp.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-mp.Tpo source/$(DEPDIR)/a68g-mp.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/mp.c' object='source/a68g-mp.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-mp.obj `if test -f 'source/mp.c'; then $(CYGPATH_W) 'source/mp.c'; else $(CYGPATH_W) '$(srcdir)/source/mp.c'; fi` source/a68g-plotutils.o: source/plotutils.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-plotutils.o -MD -MP -MF source/$(DEPDIR)/a68g-plotutils.Tpo -c -o source/a68g-plotutils.o `test -f 'source/plotutils.c' || echo '$(srcdir)/'`source/plotutils.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-plotutils.Tpo source/$(DEPDIR)/a68g-plotutils.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/plotutils.c' object='source/a68g-plotutils.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-plotutils.o `test -f 'source/plotutils.c' || echo '$(srcdir)/'`source/plotutils.c source/a68g-plotutils.obj: source/plotutils.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-plotutils.obj -MD -MP -MF source/$(DEPDIR)/a68g-plotutils.Tpo -c -o source/a68g-plotutils.obj `if test -f 'source/plotutils.c'; then $(CYGPATH_W) 'source/plotutils.c'; else $(CYGPATH_W) '$(srcdir)/source/plotutils.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-plotutils.Tpo source/$(DEPDIR)/a68g-plotutils.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/plotutils.c' object='source/a68g-plotutils.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-plotutils.obj `if test -f 'source/plotutils.c'; then $(CYGPATH_W) 'source/plotutils.c'; else $(CYGPATH_W) '$(srcdir)/source/plotutils.c'; fi` source/a68g-postgresql.o: source/postgresql.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-postgresql.o -MD -MP -MF source/$(DEPDIR)/a68g-postgresql.Tpo -c -o source/a68g-postgresql.o `test -f 'source/postgresql.c' || echo '$(srcdir)/'`source/postgresql.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-postgresql.Tpo source/$(DEPDIR)/a68g-postgresql.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/postgresql.c' object='source/a68g-postgresql.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-postgresql.o `test -f 'source/postgresql.c' || echo '$(srcdir)/'`source/postgresql.c source/a68g-postgresql.obj: source/postgresql.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-postgresql.obj -MD -MP -MF source/$(DEPDIR)/a68g-postgresql.Tpo -c -o source/a68g-postgresql.obj `if test -f 'source/postgresql.c'; then $(CYGPATH_W) 'source/postgresql.c'; else $(CYGPATH_W) '$(srcdir)/source/postgresql.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-postgresql.Tpo source/$(DEPDIR)/a68g-postgresql.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/postgresql.c' object='source/a68g-postgresql.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-postgresql.obj `if test -f 'source/postgresql.c'; then $(CYGPATH_W) 'source/postgresql.c'; else $(CYGPATH_W) '$(srcdir)/source/postgresql.c'; fi` source/a68g-pretty.o: source/pretty.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-pretty.o -MD -MP -MF source/$(DEPDIR)/a68g-pretty.Tpo -c -o source/a68g-pretty.o `test -f 'source/pretty.c' || echo '$(srcdir)/'`source/pretty.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-pretty.Tpo source/$(DEPDIR)/a68g-pretty.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/pretty.c' object='source/a68g-pretty.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-pretty.o `test -f 'source/pretty.c' || echo '$(srcdir)/'`source/pretty.c source/a68g-pretty.obj: source/pretty.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-pretty.obj -MD -MP -MF source/$(DEPDIR)/a68g-pretty.Tpo -c -o source/a68g-pretty.obj `if test -f 'source/pretty.c'; then $(CYGPATH_W) 'source/pretty.c'; else $(CYGPATH_W) '$(srcdir)/source/pretty.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-pretty.Tpo source/$(DEPDIR)/a68g-pretty.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/pretty.c' object='source/a68g-pretty.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-pretty.obj `if test -f 'source/pretty.c'; then $(CYGPATH_W) 'source/pretty.c'; else $(CYGPATH_W) '$(srcdir)/source/pretty.c'; fi` source/a68g-syntax.o: source/syntax.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-syntax.o -MD -MP -MF source/$(DEPDIR)/a68g-syntax.Tpo -c -o source/a68g-syntax.o `test -f 'source/syntax.c' || echo '$(srcdir)/'`source/syntax.c @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-syntax.Tpo source/$(DEPDIR)/a68g-syntax.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/syntax.c' object='source/a68g-syntax.o' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-syntax.o `test -f 'source/syntax.c' || echo '$(srcdir)/'`source/syntax.c source/a68g-syntax.obj: source/syntax.c @am__fastdepCC_TRUE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -MT source/a68g-syntax.obj -MD -MP -MF source/$(DEPDIR)/a68g-syntax.Tpo -c -o source/a68g-syntax.obj `if test -f 'source/syntax.c'; then $(CYGPATH_W) 'source/syntax.c'; else $(CYGPATH_W) '$(srcdir)/source/syntax.c'; fi` @am__fastdepCC_TRUE@ mv -f source/$(DEPDIR)/a68g-syntax.Tpo source/$(DEPDIR)/a68g-syntax.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='source/syntax.c' object='source/a68g-syntax.obj' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(a68g_CFLAGS) $(CFLAGS) -c -o source/a68g-syntax.obj `if test -f 'source/syntax.c'; then $(CYGPATH_W) 'source/syntax.c'; else $(CYGPATH_W) '$(srcdir)/source/syntax.c'; fi` install-man1: $(man1_MANS) $(man_MANS) @$(NORMAL_INSTALL) test -z "$(man1dir)" || $(MKDIR_P) "$(DESTDIR)$(man1dir)" @list='$(man1_MANS) $(dist_man1_MANS) $(nodist_man1_MANS)'; \ l2='$(man_MANS) $(dist_man_MANS) $(nodist_man_MANS)'; \ for i in $$l2; do \ case "$$i" in \ *.1*) list="$$list $$i" ;; \ esac; \ done; \ for i in $$list; do \ if test -f $(srcdir)/$$i; then file=$(srcdir)/$$i; \ else file=$$i; fi; \ ext=`echo $$i | sed -e 's/^.*\\.//'`; \ case "$$ext" in \ 1*) ;; \ *) ext='1' ;; \ esac; \ inst=`echo $$i | sed -e 's/\\.[0-9a-z]*$$//'`; \ inst=`echo $$inst | sed -e 's/^.*\///'`; \ inst=`echo $$inst | sed '$(transform)'`.$$ext; \ echo " $(INSTALL_DATA) '$$file' '$(DESTDIR)$(man1dir)/$$inst'"; \ $(INSTALL_DATA) "$$file" "$(DESTDIR)$(man1dir)/$$inst"; \ done uninstall-man1: @$(NORMAL_UNINSTALL) @list='$(man1_MANS) $(dist_man1_MANS) $(nodist_man1_MANS)'; \ l2='$(man_MANS) $(dist_man_MANS) $(nodist_man_MANS)'; \ for i in $$l2; do \ case "$$i" in \ *.1*) list="$$list $$i" ;; \ esac; \ done; \ for i in $$list; do \ ext=`echo $$i | sed -e 's/^.*\\.//'`; \ case "$$ext" in \ 1*) ;; \ *) ext='1' ;; \ esac; \ inst=`echo $$i | sed -e 's/\\.[0-9a-z]*$$//'`; \ inst=`echo $$inst | sed -e 's/^.*\///'`; \ inst=`echo $$inst | sed '$(transform)'`.$$ext; \ echo " rm -f '$(DESTDIR)$(man1dir)/$$inst'"; \ rm -f "$(DESTDIR)$(man1dir)/$$inst"; \ done install-docDATA: $(doc_DATA) @$(NORMAL_INSTALL) test -z "$(docdir)" || $(MKDIR_P) "$(DESTDIR)$(docdir)" @list='$(doc_DATA)'; for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ f=$(am__strip_dir) \ echo " $(docDATA_INSTALL) '$$d$$p' '$(DESTDIR)$(docdir)/$$f'"; \ $(docDATA_INSTALL) "$$d$$p" "$(DESTDIR)$(docdir)/$$f"; \ done uninstall-docDATA: @$(NORMAL_UNINSTALL) @list='$(doc_DATA)'; for p in $$list; do \ f=$(am__strip_dir) \ echo " rm -f '$(DESTDIR)$(docdir)/$$f'"; \ rm -f "$(DESTDIR)$(docdir)/$$f"; \ done install-pkgincludeHEADERS: $(pkginclude_HEADERS) @$(NORMAL_INSTALL) test -z "$(pkgincludedir)" || $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)" @list='$(pkginclude_HEADERS)'; for p in $$list; do \ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \ f=$(am__strip_dir) \ echo " $(pkgincludeHEADERS_INSTALL) '$$d$$p' '$(DESTDIR)$(pkgincludedir)/$$f'"; \ $(pkgincludeHEADERS_INSTALL) "$$d$$p" "$(DESTDIR)$(pkgincludedir)/$$f"; \ done uninstall-pkgincludeHEADERS: @$(NORMAL_UNINSTALL) @list='$(pkginclude_HEADERS)'; for p in $$list; do \ f=$(am__strip_dir) \ echo " rm -f '$(DESTDIR)$(pkgincludedir)/$$f'"; \ rm -f "$(DESTDIR)$(pkgincludedir)/$$f"; \ done ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonemtpy = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ mkid -fID $$unique tags: TAGS TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) tags=; \ here=`pwd`; \ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ if test -z "$(ETAGS_ARGS)$$tags$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$tags $$unique; \ fi ctags: CTAGS CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) tags=; \ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ test -z "$(CTAGS_ARGS)$$tags$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$tags $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && cd $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) $$here distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags check-TESTS: $(TESTS) @failed=0; all=0; xfail=0; xpass=0; skip=0; ws='[ ]'; \ srcdir=$(srcdir); export srcdir; \ list=' $(TESTS) '; \ if test -n "$$list"; then \ for tst in $$list; do \ if test -f ./$$tst; then dir=./; \ elif test -f $$tst; then dir=; \ else dir="$(srcdir)/"; fi; \ if $(TESTS_ENVIRONMENT) $${dir}$$tst; then \ all=`expr $$all + 1`; \ case " $(XFAIL_TESTS) " in \ *$$ws$$tst$$ws*) \ xpass=`expr $$xpass + 1`; \ failed=`expr $$failed + 1`; \ echo "XPASS: $$tst"; \ ;; \ *) \ echo "PASS: $$tst"; \ ;; \ esac; \ elif test $$? -ne 77; then \ all=`expr $$all + 1`; \ case " $(XFAIL_TESTS) " in \ *$$ws$$tst$$ws*) \ xfail=`expr $$xfail + 1`; \ echo "XFAIL: $$tst"; \ ;; \ *) \ failed=`expr $$failed + 1`; \ echo "FAIL: $$tst"; \ ;; \ esac; \ else \ skip=`expr $$skip + 1`; \ echo "SKIP: $$tst"; \ fi; \ done; \ if test "$$failed" -eq 0; then \ if test "$$xfail" -eq 0; then \ banner="All $$all tests passed"; \ else \ banner="All $$all tests behaved as expected ($$xfail expected failures)"; \ fi; \ else \ if test "$$xpass" -eq 0; then \ banner="$$failed of $$all tests failed"; \ else \ banner="$$failed of $$all tests did not behave as expected ($$xpass unexpected passes)"; \ fi; \ fi; \ dashes="$$banner"; \ skipped=""; \ if test "$$skip" -ne 0; then \ skipped="($$skip tests were not run)"; \ test `echo "$$skipped" | wc -c` -le `echo "$$banner" | wc -c` || \ dashes="$$skipped"; \ fi; \ report=""; \ if test "$$failed" -ne 0 && test -n "$(PACKAGE_BUGREPORT)"; then \ report="Please report to $(PACKAGE_BUGREPORT)"; \ test `echo "$$report" | wc -c` -le `echo "$$banner" | wc -c` || \ dashes="$$report"; \ fi; \ dashes=`echo "$$dashes" | sed s/./=/g`; \ echo "$$dashes"; \ echo "$$banner"; \ test -z "$$skipped" || echo "$$skipped"; \ test -z "$$report" || echo "$$report"; \ echo "$$dashes"; \ test "$$failed" -eq 0; \ else :; fi distdir: $(DISTFILES) $(am__remove_distdir) test -d $(distdir) || mkdir $(distdir) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -pR $(srcdir)/$$file $(distdir)$$dir || exit 1; \ fi; \ cp -pR $$d/$$file $(distdir)$$dir || exit 1; \ else \ test -f $(distdir)/$$file \ || cp -p $$d/$$file $(distdir)/$$file \ || exit 1; \ fi; \ done -find $(distdir) -type d ! -perm -777 -exec chmod a+rwx {} \; -o \ ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \ ! -type d ! -perm -400 -exec chmod a+r {} \; -o \ ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ || chmod -R a+r $(distdir) dist-gzip: distdir tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz $(am__remove_distdir) dist-bzip2: distdir tardir=$(distdir) && $(am__tar) | bzip2 -9 -c >$(distdir).tar.bz2 $(am__remove_distdir) dist-lzma: distdir tardir=$(distdir) && $(am__tar) | lzma -9 -c >$(distdir).tar.lzma $(am__remove_distdir) dist-tarZ: distdir tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z $(am__remove_distdir) dist-shar: distdir shar $(distdir) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).shar.gz $(am__remove_distdir) dist-zip: distdir -rm -f $(distdir).zip zip -rq $(distdir).zip $(distdir) $(am__remove_distdir) dist dist-all: distdir tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz $(am__remove_distdir) # This target untars the dist file and tries a VPATH configuration. Then # it guarantees that the distribution is self-contained by making another # tarfile. distcheck: dist case '$(DIST_ARCHIVES)' in \ *.tar.gz*) \ GZIP=$(GZIP_ENV) gunzip -c $(distdir).tar.gz | $(am__untar) ;;\ *.tar.bz2*) \ bunzip2 -c $(distdir).tar.bz2 | $(am__untar) ;;\ *.tar.lzma*) \ unlzma -c $(distdir).tar.lzma | $(am__untar) ;;\ *.tar.Z*) \ uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ *.shar.gz*) \ GZIP=$(GZIP_ENV) gunzip -c $(distdir).shar.gz | unshar ;;\ *.zip*) \ unzip $(distdir).zip ;;\ esac chmod -R a-w $(distdir); chmod a+w $(distdir) mkdir $(distdir)/_build mkdir $(distdir)/_inst chmod a-w $(distdir) dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ && cd $(distdir)/_build \ && ../configure --srcdir=.. --prefix="$$dc_install_base" \ $(DISTCHECK_CONFIGURE_FLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) dvi \ && $(MAKE) $(AM_MAKEFLAGS) check \ && $(MAKE) $(AM_MAKEFLAGS) install \ && $(MAKE) $(AM_MAKEFLAGS) installcheck \ && $(MAKE) $(AM_MAKEFLAGS) uninstall \ && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \ distuninstallcheck \ && chmod -R a-w "$$dc_install_base" \ && ({ \ (cd ../.. && umask 077 && mkdir "$$dc_destdir") \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \ distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \ } || { rm -rf "$$dc_destdir"; exit 1; }) \ && rm -rf "$$dc_destdir" \ && $(MAKE) $(AM_MAKEFLAGS) dist \ && rm -rf $(DIST_ARCHIVES) \ && $(MAKE) $(AM_MAKEFLAGS) distcleancheck $(am__remove_distdir) @(echo "$(distdir) archives ready for distribution: "; \ list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \ sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x' distuninstallcheck: @cd $(distuninstallcheck_dir) \ && test `$(distuninstallcheck_listfiles) | wc -l` -le 1 \ || { echo "ERROR: files left after uninstall:" ; \ if test -n "$(DESTDIR)"; then \ echo " (check DESTDIR support)"; \ fi ; \ $(distuninstallcheck_listfiles) ; \ exit 1; } >&2 distcleancheck: distclean @if test '$(srcdir)' = . ; then \ echo "ERROR: distcleancheck can only run from a VPATH build" ; \ exit 1 ; \ fi @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \ || { echo "ERROR: files left in build directory after distclean:" ; \ $(distcleancheck_listfiles) ; \ exit 1; } >&2 check-am: all-am $(MAKE) $(AM_MAKEFLAGS) check-TESTS check: check-am all-am: Makefile $(PROGRAMS) $(MANS) $(DATA) $(HEADERS) installdirs: for dir in "$(DESTDIR)$(bindir)" "$(DESTDIR)$(man1dir)" "$(DESTDIR)$(docdir)" "$(DESTDIR)$(pkgincludedir)"; do \ test -z "$$dir" || $(MKDIR_P) "$$dir"; \ done install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ `test -z '$(STRIP)' || \ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -rm -f source/$(DEPDIR)/$(am__dirstamp) -rm -f source/$(am__dirstamp) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-binPROGRAMS clean-generic mostlyclean-am distclean: distclean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf source/$(DEPDIR) -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-hdr distclean-tags dvi: dvi-am dvi-am: html: html-am info: info-am info-am: install-data-am: install-docDATA install-man install-pkgincludeHEADERS install-dvi: install-dvi-am install-exec-am: install-binPROGRAMS install-html: install-html-am install-info: install-info-am install-man: install-man1 install-pdf: install-pdf-am install-ps: install-ps-am installcheck-am: maintainer-clean: maintainer-clean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf $(top_srcdir)/autom4te.cache -rm -rf source/$(DEPDIR) -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-compile mostlyclean-generic pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: uninstall-binPROGRAMS uninstall-docDATA uninstall-man \ uninstall-pkgincludeHEADERS uninstall-man: uninstall-man1 .MAKE: install-am install-strip .PHONY: CTAGS GTAGS all all-am am--refresh check check-TESTS check-am \ clean clean-binPROGRAMS clean-generic ctags dist dist-all \ dist-bzip2 dist-gzip dist-lzma dist-shar dist-tarZ dist-zip \ distcheck distclean distclean-compile distclean-generic \ distclean-hdr distclean-tags distcleancheck distdir \ distuninstallcheck dvi dvi-am html html-am info info-am \ install install-am install-binPROGRAMS install-data \ install-data-am install-docDATA install-dvi install-dvi-am \ install-exec install-exec-am install-html install-html-am \ install-info install-info-am install-man install-man1 \ install-pdf install-pdf-am install-pkgincludeHEADERS \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-compile \ mostlyclean-generic pdf pdf-am ps ps-am tags uninstall \ uninstall-am uninstall-binPROGRAMS uninstall-docDATA \ uninstall-man uninstall-man1 uninstall-pkgincludeHEADERS cygwin: rm -fvr release/cygwin make install prefix=release/cygwin/usr cd release/cygwin/usr; mv -v doc share/; rm -fvr include cd release/cygwin/usr/share/doc; mv -v * $(PACKAGE_TARNAME) cd release/cygwin; tar -cf $(PACKAGE_TARNAME)-$(PACKAGE_VERSION)-$(CYGWIN_RELEASE).tar usr cd release/cygwin; bzip2 $(PACKAGE_TARNAME)-$(PACKAGE_VERSION)-$(CYGWIN_RELEASE).tar gunzip -c ../$(PACKAGE_TARNAME)-$(PACKAGE_VERSION).tar.gz | bzip2 -c > release/cygwin/$(PACKAGE_TARNAME)-$(PACKAGE_VERSION)-$(CYGWIN_RELEASE)-src.tar.bz2 # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: algol68g-2.8/Makefile.am0000644000175000001440000002375212224300564011766 00000000000000CYGWIN_RELEASE = 0 bin_PROGRAMS =a68g a68g_SOURCES = source/a68g.c source/code.c source/environ.c source/genie.c source/gsl.c source/inet.c source/monitor.c source/mp.c source/plotutils.c source/postgresql.c source/pretty.c source/syntax.c a68g_CFLAGS = -DBINDIR='"$(bindir)"' -DINCLUDEDIR='"$(includedir)"' TESTS_ENVIRONMENT=./a68g XFAIL_TESTS=\ test-set/a68g.mc.008.appl08.a68\ test-set/a68g.mc.011.appl11.a68\ test-set/a68g.mc.015.appl15.a68\ test-set/a68g.mc.018.appl18.a68\ test-set/a68g.mc.019.appl19.a68\ test-set/a68g.mc.021.clau02.a68\ test-set/a68g.mc.022.clau03.a68\ test-set/a68g.mc.023.clau04.a68\ test-set/a68g.mc.025.clau06.a68\ test-set/a68g.mc.030.coer02.a68\ test-set/a68g.mc.032.coer04.a68\ test-set/a68g.mc.033.coer05.a68\ test-set/a68g.mc.034.coer06.a68\ test-set/a68g.mc.042.decl01.a68\ test-set/a68g.mc.043.decl02.a68\ test-set/a68g.mc.047.decl06.a68\ test-set/a68g.mc.048.decl07.a68\ test-set/a68g.mc.049.flex01.a68\ test-set/a68g.mc.050.flex02.a68\ test-set/a68g.mc.051.flex03.a68\ test-set/a68g.mc.052.flex04.a68\ test-set/a68g.mc.061.idef05.a68\ test-set/a68g.mc.066.idef10.a68\ test-set/a68g.mc.068.idef12.a68\ test-set/a68g.mc.070.idrl02.a68\ test-set/a68g.mc.072.jump02.a68\ test-set/a68g.mc.076.mdeq01.a68\ test-set/a68g.mc.078.mdeq03.a68\ test-set/a68g.mc.080.mdeq05.a68\ test-set/a68g.mc.081.mdeq06.a68\ test-set/a68g.mc.082.misc01.a68\ test-set/a68g.mc.083.misc02.a68\ test-set/a68g.mc.084.misc03.a68\ test-set/a68g.mc.085.misc04.a68\ test-set/a68g.mc.087.misc06.a68\ test-set/a68g.mc.109.numr13.a68\ test-set/a68g.mc.113.oper04.a68\ test-set/a68g.mc.114.oper05.a68\ test-set/a68g.mc.115.oper06.a68\ test-set/a68g.mc.121.oper12.a68\ test-set/a68g.mc.122.oper13.a68\ test-set/a68g.mc.124.oper15.a68\ test-set/a68g.mc.125.oper16.a68\ test-set/a68g.mc.126.scop01.a68\ test-set/a68g.mc.127.scop02.a68\ test-set/a68g.mc.128.scop03.a68\ test-set/a68g.mc.129.scop04.a68\ test-set/a68g.mc.133.scop08.a68\ test-set/a68g.mc.134.scop09.a68\ test-set/a68g.mc.147.simp12.a68\ test-set/a68g.mc.149.simp15.a68\ test-set/a68g.mc.151.smio01.a68\ test-set/a68g.mc.153.smio03.a68\ test-set/a68g.mc.154.smio04.a68\ test-set/a68g.mc.155.smio05.a68\ test-set/a68g.mc.156.smio06.a68\ test-set/a68g.mc.158.smio09.a68\ test-set/a68g.mc.162.stan02.a68\ test-set/a68g.mc.163.stan03.a68\ test-set/a68g.mc.165.stow02.a68\ test-set/a68g.mc.166.stow03.a68\ test-set/a68g.mc.167.stow04.a68\ test-set/a68g.mc.168.stow05.a68\ test-set/a68g.mc.172.synt01.a68\ test-set/a68g.mc.173.synt02.a68\ test-set/a68g.mc.174.synt03.a68\ test-set/a68g.mc.175.synt04.a68\ test-set/a68g.mc.177.synt06.a68\ test-set/a68g.mc.178.synt07.a68\ test-set/a68g.mc.179.synt08.a68 TESTS=\ test-set/a68g.mc.001.appl01.a68\ test-set/a68g.mc.002.appl02.a68\ test-set/a68g.mc.003.appl03.a68\ test-set/a68g.mc.004.appl04.a68\ test-set/a68g.mc.005.appl05.a68\ test-set/a68g.mc.006.appl06.a68\ test-set/a68g.mc.007.appl07.a68\ test-set/a68g.mc.008.appl08.a68\ test-set/a68g.mc.009.appl09.a68\ test-set/a68g.mc.010.appl10.a68\ test-set/a68g.mc.011.appl11.a68\ test-set/a68g.mc.012.appl12.a68\ test-set/a68g.mc.013.appl13.a68\ test-set/a68g.mc.014.appl14.a68\ test-set/a68g.mc.015.appl15.a68\ test-set/a68g.mc.016.appl16.a68\ test-set/a68g.mc.017.appl17.a68\ test-set/a68g.mc.018.appl18.a68\ test-set/a68g.mc.019.appl19.a68\ test-set/a68g.mc.020.clau01.a68\ test-set/a68g.mc.021.clau02.a68\ test-set/a68g.mc.022.clau03.a68\ test-set/a68g.mc.023.clau04.a68\ test-set/a68g.mc.024.clau05.a68\ test-set/a68g.mc.025.clau06.a68\ test-set/a68g.mc.026.clau07.a68\ test-set/a68g.mc.027.clau08.a68\ test-set/a68g.mc.028.clau09.a68\ test-set/a68g.mc.029.coer01.a68\ test-set/a68g.mc.030.coer02.a68\ test-set/a68g.mc.031.coer03.a68\ test-set/a68g.mc.032.coer04.a68\ test-set/a68g.mc.033.coer05.a68\ test-set/a68g.mc.034.coer06.a68\ test-set/a68g.mc.035.coer07.a68\ test-set/a68g.mc.036.coer08.a68\ test-set/a68g.mc.037.coer09.a68\ test-set/a68g.mc.038.coer10.a68\ test-set/a68g.mc.039.coer11.a68\ test-set/a68g.mc.040.coer13.a68\ test-set/a68g.mc.041.coer14.a68\ test-set/a68g.mc.042.decl01.a68\ test-set/a68g.mc.043.decl02.a68\ test-set/a68g.mc.044.decl03.a68\ test-set/a68g.mc.045.decl04.a68\ test-set/a68g.mc.046.decl05.a68\ test-set/a68g.mc.047.decl06.a68\ test-set/a68g.mc.048.decl07.a68\ test-set/a68g.mc.049.flex01.a68\ test-set/a68g.mc.050.flex02.a68\ test-set/a68g.mc.051.flex03.a68\ test-set/a68g.mc.052.flex04.a68\ test-set/a68g.mc.053.garb01.a68\ test-set/a68g.mc.054.garb02.a68\ test-set/a68g.mc.055.garb03.a68\ test-set/a68g.mc.056.garb04.a68\ test-set/a68g.mc.057.idef01.a68\ test-set/a68g.mc.058.idef02.a68\ test-set/a68g.mc.059.idef03.a68\ test-set/a68g.mc.060.idef04.a68\ test-set/a68g.mc.061.idef05.a68\ test-set/a68g.mc.062.idef06.a68\ test-set/a68g.mc.063.idef07.a68\ test-set/a68g.mc.064.idef08.a68\ test-set/a68g.mc.065.idef09.a68\ test-set/a68g.mc.066.idef10.a68\ test-set/a68g.mc.067.idef11.a68\ test-set/a68g.mc.068.idef12.a68\ test-set/a68g.mc.069.idrl01.a68\ test-set/a68g.mc.070.idrl02.a68\ test-set/a68g.mc.071.jump01.a68\ test-set/a68g.mc.072.jump02.a68\ test-set/a68g.mc.073.jump03.a68\ test-set/a68g.mc.074.jump04.a68\ test-set/a68g.mc.075.jump05.a68\ test-set/a68g.mc.076.mdeq01.a68\ test-set/a68g.mc.077.mdeq02.a68\ test-set/a68g.mc.078.mdeq03.a68\ test-set/a68g.mc.079.mdeq04.a68\ test-set/a68g.mc.080.mdeq05.a68\ test-set/a68g.mc.081.mdeq06.a68\ test-set/a68g.mc.082.misc01.a68\ test-set/a68g.mc.083.misc02.a68\ test-set/a68g.mc.084.misc03.a68\ test-set/a68g.mc.085.misc04.a68\ test-set/a68g.mc.086.misc05.a68\ test-set/a68g.mc.087.misc06.a68\ test-set/a68g.mc.088.misc07.a68\ test-set/a68g.mc.089.null01.a68\ test-set/a68g.mc.090.null02.a68\ test-set/a68g.mc.091.null03.a68\ test-set/a68g.mc.092.null04.a68\ test-set/a68g.mc.093.null06.a68\ test-set/a68g.mc.094.null07.a68\ test-set/a68g.mc.095.null08.a68\ test-set/a68g.mc.096.null09.a68\ test-set/a68g.mc.097.numr01.a68\ test-set/a68g.mc.098.numr02.a68\ test-set/a68g.mc.099.numr03.a68\ test-set/a68g.mc.100.numr04.a68\ test-set/a68g.mc.101.numr05.a68\ test-set/a68g.mc.102.numr06.a68\ test-set/a68g.mc.103.numr07.a68\ test-set/a68g.mc.104.numr08.a68\ test-set/a68g.mc.105.numr09.a68\ test-set/a68g.mc.106.numr10.a68\ test-set/a68g.mc.107.numr11.a68\ test-set/a68g.mc.108.numr12.a68\ test-set/a68g.mc.109.numr13.a68\ test-set/a68g.mc.110.oper01.a68\ test-set/a68g.mc.111.oper02.a68\ test-set/a68g.mc.112.oper03.a68\ test-set/a68g.mc.113.oper04.a68\ test-set/a68g.mc.114.oper05.a68\ test-set/a68g.mc.115.oper06.a68\ test-set/a68g.mc.116.oper07.a68\ test-set/a68g.mc.117.oper08.a68\ test-set/a68g.mc.118.oper09.a68\ test-set/a68g.mc.119.oper10.a68\ test-set/a68g.mc.120.oper11.a68\ test-set/a68g.mc.121.oper12.a68\ test-set/a68g.mc.122.oper13.a68\ test-set/a68g.mc.123.oper14.a68\ test-set/a68g.mc.124.oper15.a68\ test-set/a68g.mc.125.oper16.a68\ test-set/a68g.mc.126.scop01.a68\ test-set/a68g.mc.127.scop02.a68\ test-set/a68g.mc.128.scop03.a68\ test-set/a68g.mc.129.scop04.a68\ test-set/a68g.mc.130.scop05.a68\ test-set/a68g.mc.131.scop06.a68\ test-set/a68g.mc.132.scop07.a68\ test-set/a68g.mc.133.scop08.a68\ test-set/a68g.mc.134.scop09.a68\ test-set/a68g.mc.135.scop10.a68\ test-set/a68g.mc.136.simp01.a68\ test-set/a68g.mc.137.simp02.a68\ test-set/a68g.mc.138.simp03.a68\ test-set/a68g.mc.139.simp04.a68\ test-set/a68g.mc.140.simp05.a68\ test-set/a68g.mc.141.simp06.a68\ test-set/a68g.mc.142.simp07.a68\ test-set/a68g.mc.143.simp08.a68\ test-set/a68g.mc.144.simp09.a68\ test-set/a68g.mc.145.simp10.a68\ test-set/a68g.mc.146.simp11.a68\ test-set/a68g.mc.147.simp12.a68\ test-set/a68g.mc.148.simp13.a68\ test-set/a68g.mc.149.simp15.a68\ test-set/a68g.mc.150.simp16.a68\ test-set/a68g.mc.151.smio01.a68\ test-set/a68g.mc.152.smio02.a68\ test-set/a68g.mc.153.smio03.a68\ test-set/a68g.mc.154.smio04.a68\ test-set/a68g.mc.155.smio05.a68\ test-set/a68g.mc.156.smio06.a68\ test-set/a68g.mc.157.smio08.a68\ test-set/a68g.mc.158.smio09.a68\ test-set/a68g.mc.159.smio10.a68\ test-set/a68g.mc.160.smio11.a68\ test-set/a68g.mc.161.smio12.a68\ test-set/a68g.mc.162.stan02.a68\ test-set/a68g.mc.163.stan03.a68\ test-set/a68g.mc.164.stow01.a68\ test-set/a68g.mc.165.stow02.a68\ test-set/a68g.mc.166.stow03.a68\ test-set/a68g.mc.167.stow04.a68\ test-set/a68g.mc.168.stow05.a68\ test-set/a68g.mc.169.stow06.a68\ test-set/a68g.mc.170.stow07.a68\ test-set/a68g.mc.171.stow08.a68\ test-set/a68g.mc.172.synt01.a68\ test-set/a68g.mc.173.synt02.a68\ test-set/a68g.mc.174.synt03.a68\ test-set/a68g.mc.175.synt04.a68\ test-set/a68g.mc.176.synt05.a68\ test-set/a68g.mc.177.synt06.a68\ test-set/a68g.mc.178.synt07.a68\ test-set/a68g.mc.179.synt08.a68\ test-set/a68g.ur.180.r31.a68\ test-set/a68g.ur.181.r33d.a68\ test-set/a68g.ur.182.r34a.a68\ test-set/a68g.ur.183.r541a.a68\ test-set/a68g.ur.184.r541b.a68\ test-set/a68g.ur.185.r541c.a68\ test-set/a68g.ur.186.r542a.a68\ test-set/a68g.ur.187.r542b.a68\ test-set/a68g.ur.188.r542c.a68\ test-set/a68g.ur.189.r6b.a68\ test-set/a68g.ur.190.r6d.a68\ test-set/a68g.ur.191.r6e.a68\ test-set/a68g.ur.192.r71a.a68\ test-set/a68g.ur.193.r71b.a68\ test-set/a68g.ur.194.r72a.a68\ test-set/a68g.ur.195.r8.a68\ test-set/a68g.ur.196.r811.a68\ test-set/a68g.ur.197.r812.a68\ test-set/a68g.ur.198.r9.a68 if EXPORT_DYNAMIC a68g_LDFLAGS = -Wl,--export-dynamic else a68g_LDFLAGS = endif pkginclude_HEADERS = source/a68g.h source/a68g-config.h man_MANS = doc/a68g.1 docdir = @docdir@ doc_DATA = AUTHORS COPYING NEWS README EXTRA_DIST = $(man_MANS)\ $(TESTS)\ ./ISSUES cygwin: rm -fvr release/cygwin make install prefix=release/cygwin/usr cd release/cygwin/usr; mv -v doc share/; rm -fvr include cd release/cygwin/usr/share/doc; mv -v * $(PACKAGE_TARNAME) cd release/cygwin; tar -cf $(PACKAGE_TARNAME)-$(PACKAGE_VERSION)-$(CYGWIN_RELEASE).tar usr cd release/cygwin; bzip2 $(PACKAGE_TARNAME)-$(PACKAGE_VERSION)-$(CYGWIN_RELEASE).tar gunzip -c ../$(PACKAGE_TARNAME)-$(PACKAGE_VERSION).tar.gz | bzip2 -c > release/cygwin/$(PACKAGE_TARNAME)-$(PACKAGE_VERSION)-$(CYGWIN_RELEASE)-src.tar.bz2 algol68g-2.8/test-set/0000777000175000001440000000000012224301440011547 500000000000000algol68g-2.8/test-set/a68g.mc.168.stow05.a680000644000175000001440000000067712224301274014642 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #stow05# ( ""[]; # OK # "a"[]; # KO # "ab"[] # OK # ) algol68g-2.8/test-set/a68g.mc.177.synt06.a680000644000175000001440000000062312224301275014634 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #synt06# # Comment without end algol68g-2.8/test-set/a68g.mc.153.smio03.a680000644000175000001440000000744412224301262014601 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio03# BEGIN # 10/08/73, R van Vliet; 30/09/75, revised. Test the print and putroutines.# INT max ch n = # actual max char, formerly max char[standout channel] # (FILE f:= standout; INT i; on line end(f, (REF FILE f)BOOL: out); DO put(f, space) OD; out: i:= char number(f) -1; TO i DO put(f, backspace) OD; i); print(("Test 1", newline)); print(("Test rather easy output", new line)); COMPL z= -max real I -max real; print((-max int, -max real, z, FALSE, "a", newline)); print(new line); MODE LINTREAL =UNION( INT, LONG INT, LONG LONG INT, REAL, LONG REAL, LONG LONG REAL ); PROC maxim =(LINTREAL lir)LINTREAL: CASE lir IN (INT): max int, (LONG INT): long max int -LENG 1, (LONG LONG INT): long long max int -LENG LENG 2, (REAL): max real, (LONG REAL): long max real -LENG 1.0, (LONG LONG REAL): long long max real -LENG LENG 2.0 ESAC; PROC lengthen =(LINTREAL lir)LINTREAL: CASE lir IN (INT k): LENG k, (LONG INT k): LENG k, (LONG LONG INT k): (print((new line, "No more long ints allowed")); k), (REAL k): LENG k, (LONG REAL k): LENG k, (LONG LONG REAL k): (print((newline, "No more long reals allowed")); k) OUT print((new line, "Lengthen called with illegal mode.", new line)); GOTO stop ESAC; LINTREAL lir := max int; print(lir); TO int lengths -1 DO lir :=maxim(lengthen(lir)); print(lir) OD; LINTREAL int max =lir; lir:=lengthen(lir); print((new line, "The result of trying an extra long int is:", lir,newline,newline)); lir :=max real; print(lir); TO real lengths -1 DO lir:= maxim(lengthen(lir)); print(lir) OD; lir :=lengthen(lir); print((newline, "The result of trying an extra long real is:", lir, newline)); print(new line); INT digitcount = # count the digits in int max # CASE int max IN (INT) : int width, (LONG INT): long int width, (LONG LONG INT) : long long int width OUT print((newline, "The actual mode of intmax is wrong", newline));GOTO stop ESAC; print(newline); TO max ch n -(digitcount +2) DO print(space) OD; print(int max); print((new line, "This integer must be printed at the end of a line", new line)); TO max ch n -(digitcount +2) +1 DO print(space) OD; print(int max); print((new line, "and this integer at the beginning of a line", new line)); TO max ch n -(2*(real width +exp width) +11) DO print(space) OD; print(z); print((new line, "This compl must be printed at the end of a line", new line)); TO max ch n -(2*(real width +exp width) +11) +1 DO print(space) OD; print(z); print((new line, "and this last compl at the beginning of a line", new line)); print((newline, "Three times pi, in stepwise receding positions:", newline)); print((pi, newline)); # no space # print((" ", float(pi, real width +exp width +4, real width -1, exp width +1), newline)); # one space # print((" ", pi, newline)); # two spaces # TO max ch n -4 DO print (space) OD; print("lineoverflow"); print((new line, "[]CHAR was tested", new line, new line)); print(("Finally print a false and a true boolean", newline, FALSE, TRUE)) END algol68g-2.8/test-set/a68g.mc.088.misc07.a680000644000175000001440000004057512224301246014604 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #misc07# # 100 nested proc declarations; prints 100 100 # (INT i := 0; print (((INT a = (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: (PROC a = INT: i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); i +:= 1; a); a), newline)); print ((i, newline)))algol68g-2.8/test-set/a68g.mc.013.appl13.a680000644000175000001440000000242612224301220014547 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl13# # Ring code # BEGIN INT m := 4; m := 2 ** m; INT n # left-most bit # = m OVER 2; [0 : m - 1] BOOL f; [1 : m] INT t; FOR i FROM 0 TO m - 1 DO f[i] := TRUE OD; PROC p = (INT i, k) VOID: BEGIN t[k] := i; f[i] := FALSE; IF k = m THEN print (newline); # Every bit column in 't' now contains the ring code # FOR k TO m DO print (t[k] GE n) OD ELSE INT l; IF f[l := 2 * i MOD m] THEN p (l, k + 1) FI; IF f[l +:= 1] THEN p (l, k + 1) FI FI; f[i] := TRUE END; p (0, 1) ENDalgol68g-2.8/test-set/a68g.mc.039.coer11.a680000644000175000001440000000331412224301224014552 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer11# BEGIN # Contains all possible two-member coercion sequences # UNION (INT, BOOL) ib := 1; print (([] REAL (1), newline)); print (([] REAL (INT: 1), newline)); print (([] REAL (REAL: 1), newline)); print (([] [, ] COMPL (1), newline)); print (([] [, ] COMPL (LOC INT := 1), newline)); print (([] [, ] COMPL ([] COMPL (1, 2)), newline)); print (([, , ] [] BOOL (16 r f), newline)); print (([, , ] [] [, ] BOOL (16 r f), newline)); print (([, , ] [] BOOL (BITS: 16 r f), newline)); print (([, , ] [] [, ] BOOL (BITS: 16 r f), newline)); print (([, ] [] CHAR (bytes pack ("ab")), newline)); print (([, ] [] [, ] CHAR (bytes pack ("ab")), newline)); print (([, ] [] CHAR (LOC BYTES := bytes pack ("ab")), newline)); print (([, ] [] [, ] CHAR (LOC BYTES := bytes pack ("ab")), newline)); print ((REF [] INT (REF INT: HEAP INT := 1), newline)); print ((REF [, ] INT (REF [] INT: HEAP [1] INT := 1), newline)); print ((UNION (INT, REAL, BOOL) (ib), newline)); print (([] REF [] [, ] [] [] INT (LOC PROC REF INT := REF INT: HEAP INT := 1)[1], newline)); print (([] UNION (INT, REAL) (LOC INT := 1)[1], newline)); print (([] UNION (INT, REAL) (REAL: 1)[1], newline)); print (([] UNION (INT, REAL, BOOL) (ib)[1], newline)); SKIP ENDalgol68g-2.8/test-set/a68g.mc.091.null03.a680000644000175000001440000000060112224301246014573 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #null03# DO stop ODalgol68g-2.8/test-set/a68g.mc.103.numr07.a680000644000175000001440000001042712224301251014603 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr07# BEGIN #JKok, 730612, test Choleski decomposition# OP * = ([] REAL a, b) REAL: (REAL s := 0; FOR i TO UPB a DO s +:= a[i] * b[i] OD; s); PROC decsym = (REF [, ] REAL a, REF [] INT p, REAL aux) INT: IF INT n = 1 UPB a; 2 UPB a /= n OR UPB p /= n THEN 0 ELSE REAL max := 0, epsnorm, ukk, uki, aii, INT pk := 1, r := 0; PROC ichvec = (REF [] REAL a, b) VOID: IF INT n = UPB a; n > 0 THEN [] REAL h = a; a := b; b := h FI # interchange two vectors# ; FOR k TO n DO IF a[k, k] > max THEN max := a[k, k]; pk := k FI OD; epsnorm := aux * max; FOR k TO n WHILE max > epsnorm DO INT k1 = k + 1; p[k] := pk; r := k; IF pk /= k THEN ichvec (a[ : k - 1, k], a[ : k - 1, pk]); ichvec (a[k, k1 : pk - 1], a[k1 : pk - 1, pk]); ichvec (a[k, pk + 1 : ], a[pk, pk + 1 : ]); a[pk, pk] := a[k, k] FI; ukk := a[k, k] := sqrt (max); max := 0; pk := k1; FOR i FROM k1 TO n DO uki := a[k, i] := (a[k, i] - a[ : k - 1, k] * a[ : k - 1, i]) / ukk; aii := a[i, i] -:= uki * uki; IF aii > max THEN max := aii; pk := i FI OD OD; r FI # Choleski decomposition with diagonal pivoting# , PROC solsym = ([, ] REAL a, [] INT p, REF [] REAL b) VOID: IF INT n = 1 UPB a; 2 UPB a = n AND UPB p = n AND UPB b = n THEN INT pk, REAL r; FOR k TO n DO r := b[k]; pk := p[k]; b[k] := (b[pk] - a[ : k - 1, k] * b[ : k - 1]) / a[k, k]; IF pk /= k THEN b[pk] := r FI OD; FOR k FROM n BY -1 TO 1 DO b[k] := (b[k] - a[k, k + 1 : ] * b[k + 1 : ]) / a[k, k] OD; FOR k FROM n BY -1 TO 1 DO IF pk := p[k]; pk /= k THEN r := b[k]; b[k] := b[pk]; b[pk] := r FI OD FI # solution of Choleski decomposed system # ; print (("Value, expected, difference", newline, newline)); FOR n TO 8 DO [1 : n, 1 : n] REAL a, aa, [1 : n] REAL b, c, [1 : n] INT piv; FOR i TO n DO FOR j TO n DO a[i, j] := aa[i, j] := 1 / (2 * n + 1 - i - j) OD OD; FOR i TO n DO b[i] := 2 ** (n - i) OD; IF decsym (a, piv, 1e-13) = n THEN solsym (a, piv, b); FOR i TO n DO print ((aa[i, ] * b, REAL (2 ** (n - i)), aa[i, ] * b - 2 ** (n - i), newline)) OD ELSE print ("Coefficients matrix is not positive definite") FI; print (newline) OD #Output approximately: 1 2 1 4 2 1 . . . 128 64 . . . 1 # ENDalgol68g-2.8/test-set/a68g.mc.098.numr02.a680000644000175000001440000000532412224301247014620 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr02# BEGIN # Brinkmanship # # What minreal is the smallest positive real on your installation ? # PROC test = (STRING titel, REAL min real) VOID: (print ((newline, newline, titel, newline)); print (("minreal = ", minreal, newline)); print (("2*minreal = ", 2 * minreal, newline)); print (("minreal*maxreal = ", minreal * maxreal, newline)); print (("sqrt(minreal) = ", sqrt (minreal), newline)); print (("sqrt(minreal)**2 = ", sqrt (minreal) * sqrt (minreal), newline)); IF minreal > 0 THEN print (("ln(minreal) = ", ln (minreal), newline)); print (("exp(ln(minreal) = ", exp (ln (minreal)), newline)) FI); test ("minreal = 5.0/(smallreal**2 * maxreal)", 5.0 / (smallreal * maxreal * smallreal)); test ("minreal = 2.0/(smallreal**2 * maxreal)", 2.0 / (smallreal * maxreal * smallreal)); test ("minreal = 1.5/(smallreal**2 * maxreal)", 1.5 / (smallreal * maxreal * smallreal)); test ("minreal = 1.1/(smallreal**2 * maxreal)", 1.1 / (smallreal * maxreal * smallreal)); test ("minreal = 1.0/(smallreal**2 * maxreal)", 1.0 / (smallreal * maxreal * smallreal)); test ("minreal = (x; x>0, x/10 = 0)", (REAL x := 1; WHILE x / 10 > 0 DO x /:= 10 OD; x)); test ("minreal = (x; x>0, x/2 = 0)", (REAL x := 1; WHILE x / 2 > 0 DO x /:= 2 OD; x)); test ("minreal = 1/maxreal", 1 / maxreal); # to compare # print ((newline, newline, "to compare", newline)); print (("maxreal = ", maxreal, newline)); print (("smallreal = ", smallreal, newline)); print (("1/smallreal**2 = ", 1 / (smallreal * smallreal), newline)); # What would you like this one to do? # print ((newline, newline, "e**-maxreal is positive", newline)); print (("exp(-maxreal) = ", exp (-maxreal), newline)) ENDalgol68g-2.8/test-set/a68g.mc.080.mdeq05.a680000644000175000001440000000110212224301232014537 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #mdeq05# BEGIN # Mode equivalencing # MODE N = UNION(BYTES, BITS, REF BITS); # error, related # MODE SZEREDI = UNION(INT,REAL,REF UNION(INT,REAL)) # Szeredi - ambiguity #; SKIP END algol68g-2.8/test-set/a68g.mc.061.idef05.a680000644000175000001440000000075012224301227014533 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef05# BEGIN INT i := 1; (INT i = i; print (i) # what is the value of i? # ) ENDalgol68g-2.8/test-set/a68g.mc.015.appl15.a680000644000175000001440000001421312224301220014550 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl15# BEGIN # Mincer # CO This program operates in one of two modes: 1. garbage in, garbage out 2. data in, garbage out The basic idea is to read in a program, scramble it, and punch the scrambled program out. The scrambled program can be fed into a compiler to see what it does. Experience shows that most compilers do not take well to this test at all. The program is broken up into syntactic units, where a syntactic unit is an identifier, an unsigned int, a bold, a string, a sequence of the characters +-*/=<>: , or a special. Random numbers are taken from a rectangular distribution with mean supplied by the user. Let 'n1' be the first such random number. The first 'n1' syntactic units are considered to be the first chunk. The next 'n2' syntactic units comprise the second chunk, etc. The chunks are then put out in random order. If the chunks are big enough, the compiler thinks it is getting reasonable stuff, makes some attempt at analyzing the structure, building tables, etc. If the chunks are too small, nothing much happens. The program to be read in resides on the file "program", the scrambled program on the file "result". The values to be used as means for the random numbers are read from 'stand in'. The list is terminated by mean = 0. Values may be preceded by a minus-sign, in which case the chunks in the corresponding output are separated by newlines. For instance, if the input-file contains: 100 -20 0 , two scrambled programs will be generated, the first having chunks of about 100 syntactic units, the second with chunks of about 20 syntactic units, separated. CO INT line width = 72; # for 'program' and 'result' # FILE program; # contains the program # open(program, "program", standin channel); FILE result; # will contain the minced program # establish(result, "result", standout channel, 1, 10000, line width); STRING result sep = "######"; # for result # CHAR quote = """", dot = "."; PROC in item = STRING: (STRING st = in item or comment; comment(st) | skip comment(st); in item | st); PROC comment = (STRING s) BOOL: s = "#" OR s = "CO" OR s = "COMMENT"; PROC skip comment = (STRING s) VOID: WHILE in item or comment /= s DO SKIP OD; PROC in item or comment = STRING: BEGIN more real input; CHAR ch = line[c pos]; STRUCT(STRING item, INT new pos) res := IF letter(ch) THEN INT p = last(letgit); (line[c pos: p], p + 1) ELIF ch = quote THEN INT p = last((CHAR c) BOOL: c /= quote); (line[c pos: p] + quote, p + 2) ELIF digit(ch) THEN INT p = last(digit); (line[c pos: p], p + 1) ELIF ch = dot THEN INT p = last(letgit); (line[c pos: p] + " ", p + 1) ELIF indicant (ch) THEN INT p = last(indicant); (line[c pos: p], p + 1) ELSE (line[c pos], c pos + 1) FI; c pos:= new pos OF res; item OF res END # in item or comment #; PROC last= (PROC (CHAR) BOOL cond) INT: (INT p:= c pos; FOR d FROM c pos + 1 TO UPB line WHILE cond(line[d]) DO p:= d OD; p ); PROC letter = (CHAR ch) BOOL: "a" <= ch AND ch <= "z" OR "A" <= ch AND ch <= "Z" # for UPPER-style #; PROC digit = (CHAR ch) BOOL: "0" <= ch AND ch <= "9"; PROC letgit = (CHAR ch) BOOL: letter (ch) OR digit (ch); PROC indicant = (CHAR ch) BOOL: char in string (ch, LOC INT, "+-*/=<>:"); PROC more real input = VOID: (skip: IF c pos>UPB line THEN newline(program); get line; skip FI; IF line [c pos] = " " THEN c pos +:= 1; skip FI ); INT c pos:= 1, STRING line:= ""; # on 'program' # PROC get line = VOID: (get(program, line); IF UPB line > line width THEN line:= line [1: linewidth] FI; c pos:= 1 ); PROC out item = (STRING s) VOID: (IF char number (result) + UPB s > line width THEN newline (result) FI; put(result, s) ); PROC range = (INT r)INT: # a random integer in the range [1:r] # ENTIER (random * r) + 1; # Reading the program text # MODE TEXT = STRUCT (STRING string, REF TEXT next); REF TEXT no text = NIL; REF TEXT first text:= no text, last text:= no text; on logical file end (program, (REF FILE f) BOOL: run); # Initialize # get line; DO # until end-of-file # STRING st = in item; last text:= (last text :=: no text| first text | next OF last text):= HEAP TEXT:= (st, no text) OD; run: WHILE INT descr = (INT i; read(i); i); INT mean = ABS descr, BOOL sep = descr < 0; 0 < mean AND mean < 10000 DO MODE CHUNK = STRUCT(STRUCT(INT length, REF TEXT text) chunk, REF CHUNK next); REF CHUNK no chunk = NIL; REF CHUNK first chunk:= no chunk, last chunk:= no chunk; INT n chunks:= 0; last text:= first text; WHILE last text :/=: no text DO INT cnt:= 0, REF TEXT p:= last text; TO range (2 * mean - 1) DO (p :/=: no text | p:= next OF p; cnt +:=1) OD # determine chunk #; # enter into chunk chain # last chunk:= (last chunk :=: no chunk | first chunk | next OF last chunk):= HEAP CHUNK:= ((cnt, last text), NIL); n chunks +:= 1; last text:= p OD # chunk chain ready #; # Tie full-circle # (last chunk :/=: no chunk | next OF last chunk:= first chunk); # Mix the chunks # FOR length FROM n chunks BY -1 TO 1 DO TO range (length) DO first chunk:= next OF first chunk OD; # Random chunk found, now write it # REF TEXT p:= text OF chunk OF next OF first chunk; TO length OF chunk OF next OF first chunk DO out item (string OF p); p:= next OF p OD; IF sep THEN newline(result) FI; # Remove chunk # next OF first chunk:= next OF next OF first chunk OD; put(result, (newline, result sep, newline, newline)); printf(( $ "Produced" 4zd x, "chunks of mean length" 3zd , b (", separated", "") l $, n chunks, mean, sep)) OD END algol68g-2.8/test-set/a68g.mc.114.oper05.a680000644000175000001440000000106612224301253014570 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper05# BEGIN # Operator test, mutual recursion # PRIO +> = 1, +< = 1; OP +> = (INT a, b) INT: a +< b; OP +< = (INT a, b) INT: a +> b; 1 +> 2 # loop # ENDalgol68g-2.8/test-set/a68g.mc.054.garb02.a680000644000175000001440000000134512224301226014536 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #garb02# BEGIN # Test garbage collector # REF [] REAL x, y, INT n := 0; l: x := HEAP [1 : 1000] REAL; y := HEAP [1 : 1000] REAL; IF (n +:= 1) < 1000 THEN l FI; print (("collections, garbage, collect seconds:", newline)); print ((collections, garbage, # collect seconds, # newline)) ENDalgol68g-2.8/test-set/a68g.mc.132.scop07.a680000644000175000001440000000111012224301257014563 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #scop07# BEGIN # Scope error, parameter pack is local # print (("Need not run", newline)); print ((LOC INT := 0) +:= 1); REF INT ii; print (sin (ii := LOC INT := 1)); print (ii) ENDalgol68g-2.8/test-set/a68g.mc.100.numr04.a680000644000175000001440000001222312224301250014570 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr04# BEGIN # Two versions of the integration procedure 'qad', one fully recursive (and understandable), one half-recursive, a result of an optimization attempt on the ALGOL60 version # REAL eps = 10000 * small real; PROC qad fr = (REAL a, b, PROC (REAL) REAL fx, STRUCT (REAL re, ae, REF INT skip) e) REAL: BEGIN REAL sum := 0; REAL re = re OF e, ae = ae OF e * 180 / ABS (b - a), REF INT skip = skip OF e := 0; REAL h min = ABS (b - a) * re; PROC int = (REAL x0, f0, x2, f2, x4, f4) VOID: IF REAL x1 = (x0 + x2) / 2, x3 = (x2 + x4) / 2; REAL f1 = fx (x1), f3 = fx (x3); REAL h = x4 - x0, aid1 = 4 * (f1 + f3), aid2 = f0 + f4, v = (aid1 + 2 * f2 + aid2) * 15, t = 6 * f2 - aid1 + aid2; ABS t < ABS v * re + ae THEN sum +:= h * (v - t) ELIF ABS h < h min THEN skip +:= 1 ELSE int (x0, f0, x1, f1, x2, f2); int (x2, f2, x3, f3, x4, f4) FI # of int # ; int (a, fx (a), (a + b) / 2, fx ((a + b) / 2), b, fx (b)); sum / 180 END #of qad fr# ; PROC qad hr = (REAL a, b, PROC (REAL) REAL fx, STRUCT (REAL re, ae, REF INT skip) e) REAL: BEGIN REAL x0 := a, f0 := fx (a), x2 := b, f2 := fx (b); REAL x1 := (x0 + x2) / 2; REAL f1 := fx (x1); REAL sum := 0; REAL re = re OF e, ae = ae OF e * 180 / ABS (b - a), REF INT skip = skip OF e := 0; REAL h min = ABS (b - a) * re; PROC int = VOID: BEGIN REAL x4 = x2, f4 = f2; x2 := x1; f2 := f1; anew: IF x1 := (x0 + x2) / 2; f1 := fx (x1); REAL x3 = (x2 + x4) / 2; REAL f3 := fx (x3); REAL h = x4 - x0, aid1 = 4 * (f1 + f3), aid2 = f0 + f4; REAL v = (aid1 + 2 * f2 + aid2) * 15, t = 6 * f2 - aid1 + aid2; ABS t < ABS v * re + ae THEN sum +:= h * (v - t) ELIF ABS h < h min THEN skip +:= 1 ELSE int; x2 := x3; f2 := f3; GOTO anew FI; x0 := x4; f0 := f4 END #of int# ; int; sum / 180 END #of qad hr# ; PROC test qad = (STRING type, PROC (REAL, REAL, PROC (REAL) REAL, STRUCT (REAL re, ae, REF INT skip)) REAL qad) VOID: BEGIN INT real size = real width + exp width + 6; print ((newline, "Results for ", type, ":", newline, " ", "exponent", (real size - 8) * " ", "integral", (real size - 8) * " ", "error", (real size - 5) * " ", "skip points time", newline)); PROC exp test = (REAL power, answer) VOID: BEGIN INT skip, eval := 0; REAL time := clock; REAL result = qad (0, 1, (REAL x) REAL: (eval +:= 1; (x <= 0 | 0 | exp (ln (x) * power))), (eps, eps, skip)); time := clock - time; print ((power, ",", result, ",", 0.0 #result-answer# , ",", whole (skip, -6), ",", whole (eval, -6), ",", "time", newline)) END # test exp # ; FOR k FROM 4 TO 10 DO exp test (k, 1 / (k + 1)) OD; FOR k FROM 2 TO 7 DO exp test (1 / k, k / (k + 1)) OD END # test qad # ; test qad ("fully recursive version", qad fr); test qad ("half-recursive version", qad hr) ENDalgol68g-2.8/test-set/a68g.ur.190.r6d.a680000644000175000001440000002627612224301306014215 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r6d # (print (("coercions in weak context", newline)); INT vf = 11 * (3 + 13 + 9 + 17); INT ctrt := 0, ctr := 0; PROC controle = ([] REAL a, UNION (STRING, CHAR, COMPL) b) VOID: ((UPB a = 1 AND ABS (a[1] - 1) < 1e-5 | ctr +:= 1 |: UPB a = 3 AND ABS (a[3] - 1) < 1e-5 | ctr +:= 5); (b | (CHAR c): (c = """" | ctr +:= 2), (STRING c): (UPB c = 3 AND c[2] = "." | ctr +:= 8), (COMPL c): (re OF c = 0 AND ABS (IM c - 1) < 1e-5 | ctr +:= 12))); PRIO ?=: = 1, ?:= = 9; # controle,servitudes et contextes pour modes : COMPL et STRING # BEGIN PROC c = (REAL a, CHAR b) VOID: (INT x = ctr; controle (a, b); ctr /= x + 3 | print (("count er in test", ctrt, ctr, x + 3, newline))); PROC PROC COMPL ids = PROC COMPL: COMPL: (0, 1); PROC PROC STRING idr = PROC STRING: STRING: """."""; OP ?=: = (PROC PROC COMPL a) PROC PROC COMPL: a, ?:= = (PROC PROC STRING a) PROC PROC STRING: a, ?=: = (PROC PROC COMPL a, INT b) PROC PROC COMPL: (b | SKIP, a), ?:= = (PROC PROC STRING a, INT b) PROC PROC STRING: (b | SKIP, a), STRUCT (COMPL toto, PROC PROC COMPL de) de = (0, ids), STRUCT (COMPL toto, PROC PROC STRING of) of = (0, idr), [] PROC PROC COMPL sang = ids, [] PROC PROC STRING rang = idr, PROC si = (PROC PROC COMPL a) PROC PROC COMPL: a, ri = (PROC PROC STRING a) PROC PROC STRING: a, UNION (CHAR, PROC PROC COMPL, PROC PROC STRING) u; ctrt := 1; c (im OF (PROC COMPL: COMPL: (0, 1)), (PROC STRING: STRING: """.""")[3]); ctrt := 2; c (im OF (?=:ids ?=: 2), (?:=idr ?:= 2)[3]); ctrt := 3; c (im OF de OF de, (of OF of)[3]); ctrt := 4; c (im OF sang[1], rang[1][3]); ctrt := 5; c (im OF si (ids), ri (idr)[3]); ctrt := 6; c (im OF PROC PROC COMPL (ids), PROC PROC STRING (idr)[3]); ctrt := 7; c (im OF ids, idr[3]); ctrt := 8; c (im OF BEGIN (INT x; ids) EXIT etiq: SKIP END, BEGIN (INT x; idr) EXIT etiq: SKIP END[3]); ctrt := 9; c (im OF IF TRUE THEN ids FI, IF TRUE THEN idr FI[3]); ctrt := 10; c (im OF (1 | ids, SKIP), (1 | idr, SKIP)[3]); ctrt := 11; c (im OF (u := ids | (PROC PROC COMPL x): x), (u := idr | (PROC PROC STRING x): x)[3]); SKIP END; # controle,servitudes et contextes pour modes : STRUCT ( UNION ( INT , PROC STRING )re , [] REAL im) et [] REF STRING # BEGIN PROC c = ([] REAL a, REF STRING b) VOID: (INT x = ctr; controle (a, b); ctr /= x + 13 | print (("count er in test", ctrt, ctr, x + 13, newline))); REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im) ids = HEAP PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im) := STRUCT (UNION (INT, PROC STRING) re, [] REAL im): (0, (2, 3, 1)); REF PROC [] REF STRING idr = HEAP PROC [] REF STRING := [] REF STRING: (NIL, NIL, HEAP STRING := """."""); OP ?=: = (REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im) a) REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im): a, ?:= = (REF PROC [] REF STRING a) REF PROC [] REF STRING: a, ?=: = (REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im) a, INT b) REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im): (b | SKIP, a), ?:= = (REF PROC [] REF STRING a, INT b) REF PROC [] REF STRING: (b | SKIP, a), STRUCT (COMPL toto, REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im) de) de = (0, ids), STRUCT (COMPL toto, REF PROC [] REF STRING of) of = (0, idr), [] REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im) sang = ids, [] REF PROC [] REF STRING rang = idr, PROC si = (REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im) a) REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im): a, ri = (REF PROC [] REF STRING a) REF PROC [] REF STRING: a, UNION (CHAR, REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im), REF PROC [] REF STRING) u; ctrt := 12; c (im OF (HEAP PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im) := STRUCT (UNION (INT, PROC STRING) re, [] REAL im): (0, (2, 3, 1))), (HEAP PROC [] REF STRING := [] REF STRING: (NIL, NIL, HEAP STRING := """."""))[3]); ctrt := 13; c (im OF (?=:ids ?=: 2), (?:=idr ?:= 2)[3]); ctrt := 14; c (im OF de OF de, (of OF of)[3]); ctrt := 15; c (im OF sang[1], rang[1][3]); ctrt := 16; c (im OF si (ids), ri (idr)[3]); ctrt := 17; c (im OF REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im) (ids), REF PROC [] REF STRING (idr)[3]); ctrt := 18; c (im OF ids, idr[3]); ctrt := 19; c (im OF BEGIN (INT x; ids) EXIT etiq: SKIP END, BEGIN (INT x; idr) EXIT etiq: SKIP END[3]); ctrt := 20; c (im OF IF TRUE THEN ids FI, IF TRUE THEN idr FI[3]); ctrt := 21; c (im OF (1 | ids, SKIP), (1 | idr, SKIP)[3]); ctrt := 22; c (im OF (u := ids | (REF PROC STRUCT (UNION (INT, PROC STRING) re, [] REAL im) x): x), (u := idr | (REF PROC [] REF STRING x): x)[3]); SKIP END; # controle,servitudes et contextes pour modes : REF COMPL et REF [] REF STRING # BEGIN PROC c = (REF REAL a, REF REF STRING b) VOID: (INT x = ctr; controle (a, b); ctr /= x + 9 | print (("count er in test", ctrt, ctr, x + 9, newline))); PROC REF COMPL ids = REF COMPL: HEAP COMPL := (0, 1); PROC REF [] REF STRING idr = REF [] REF STRING: HEAP [3] REF STRING := (NIL, NIL, HEAP STRING := """."""); OP ?=: = (PROC REF COMPL a) PROC REF COMPL: a, ?:= = (PROC REF [] REF STRING a) PROC REF [] REF STRING: a, ?=: = (PROC REF COMPL a, INT b) PROC REF COMPL: (b | SKIP, a), ?:= = (PROC REF [] REF STRING a, INT b) PROC REF [] REF STRING: (b | SKIP, a), STRUCT (COMPL toto, PROC REF COMPL de) de = (0, ids), STRUCT (COMPL toto, PROC REF [] REF STRING of) of = (0, idr), [] PROC REF COMPL sang = ids, [] PROC REF [] REF STRING rang = idr, PROC si = (PROC REF COMPL a) PROC REF COMPL: a, ri = (PROC REF [] REF STRING a) PROC REF [] REF STRING: a, UNION (CHAR, PROC REF COMPL, PROC REF [] REF STRING) u; ctrt := 23; c (im OF (REF COMPL: HEAP COMPL := (0, 1)), (REF [] REF STRING: HEAP [3] REF STRING := (NIL, NIL, HEAP STRING := """."""))[3]); ctrt := 24; c (im OF (?=:ids ?=: 2), (?:=idr ?:= 2)[3]); ctrt := 25; c (im OF de OF de, (of OF of)[3]); ctrt := 26; c (im OF sang[1], rang[1][3]); ctrt := 27; c (im OF si (ids), ri (idr)[3]); ctrt := 28; c (im OF PROC REF COMPL (ids), PROC REF [] REF STRING (idr)[3]); ctrt := 29; c (im OF ids, idr[3]); ctrt := 30; c (im OF BEGIN (INT x; ids) EXIT etiq: SKIP END, BEGIN (INT x; idr) EXIT etiq: SKIP END[3]); ctrt := 31; c (im OF IF TRUE THEN ids FI, IF TRUE THEN idr FI[3]); ctrt := 32; c (im OF (1 | ids, SKIP), (1 | idr, SKIP)[3]); ctrt := 33; c (im OF (u := ids | (PROC REF COMPL x): x), (u := idr | (PROC REF [] REF STRING x): x)[3]); SKIP END; # controle,servitudes et contextes pour modes : REF [] COMPL et REF [] COMPL # BEGIN PROC c = (REF [] REAL a, REF COMPL b) VOID: (INT x = ctr; controle (a, b); ctr /= x + 17 | print (("count er in test", ctrt, ctr, x + 17, newline))); REF PROC REF REF [] COMPL ids = HEAP PROC REF REF [] COMPL := REF REF [] COMPL: HEAP REF [] COMPL := HEAP [3] COMPL := (0 I 3, 0 I 2, 0 I 1); REF PROC REF REF [] COMPL idr = HEAP PROC REF REF [] COMPL := REF REF [] COMPL: HEAP REF [] COMPL := HEAP [3] COMPL := (0 I 3, 0 I 2, 0 I 1); OP ?=: = (REF PROC REF REF [] COMPL a) REF PROC REF REF [] COMPL: a, ?:= = (REF PROC REF REF [] COMPL a) REF PROC REF REF [] COMPL: a, ?=: = (REF PROC REF REF [] COMPL a, INT b) REF PROC REF REF [] COMPL: (b | SKIP, a), ?:= = (REF PROC REF REF [] COMPL a, INT b) REF PROC REF REF [] COMPL: (b | SKIP, a), STRUCT (COMPL toto, REF PROC REF REF [] COMPL de) de = (0, ids), STRUCT (COMPL toto, REF PROC REF REF [] COMPL of) of = (0, idr), [] REF PROC REF REF [] COMPL sang = ids, [] REF PROC REF REF [] COMPL rang = idr, PROC si = (REF PROC REF REF [] COMPL a) REF PROC REF REF [] COMPL: a, ri = (REF PROC REF REF [] COMPL a) REF PROC REF REF [] COMPL: a, UNION (CHAR, REF PROC REF REF [] COMPL, REF PROC REF REF [] COMPL) u; ctrt := 34; c (im OF (HEAP PROC REF REF [] COMPL := REF REF [] COMPL: HEAP REF [] COMPL := HEAP [3] COMPL := (0 I 3, 0 I 2, 0 I 1)), (HEAP PROC REF REF [] COMPL := REF REF [] COMPL: HEAP REF [] COMPL := HEAP [3] COMPL := (0 I 3, 0 I 2, 0 I 1))[3]); ctrt := 35; c (im OF (?=:ids ?=: 2), (?:=idr ?:= 2)[3]); ctrt := 36; c (im OF de OF de, (of OF of)[3]); ctrt := 37; c (im OF sang[1], rang[1][3]); ctrt := 38; c (im OF si (ids), ri (idr)[3]); ctrt := 39; c (im OF REF PROC REF REF [] COMPL (ids), REF PROC REF REF [] COMPL (idr)[3]); ctrt := 40; c (im OF ids, idr[3]); ctrt := 41; c (im OF BEGIN (INT x; ids) EXIT etiq: SKIP END, BEGIN (INT x; idr) EXIT etiq: SKIP END[3]); ctrt := 42; c (im OF IF TRUE THEN ids FI, IF TRUE THEN idr FI[3]); ctrt := 43; c (im OF (1 | ids, SKIP), (1 | idr, SKIP)[3]); ctrt := 44; c (im OF (u := ids | (REF PROC REF REF [] COMPL x): x), (u := idr | (REF PROC REF REF [] COMPL x): x)[3]); SKIP END; print ((ctr, " tests ", (ctr = vf | "ok" | "erreur"))))algol68g-2.8/test-set/a68g.mc.166.stow03.a680000644000175000001440000000071012224301274014622 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #stow03# BEGIN [1 : -1] INT k; print ("OK"); k[1] := 1 # overflow # ENDalgol68g-2.8/test-set/a68g.mc.158.smio09.a680000644000175000001440000000230312224301262014601 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio09# ( # Parameter of 'print' # print((1, 2.0, 3 I 4, "5", "67", TRUE, 16r89, newline)); print((bytes pack("10"), STRUCT(BOOL bo, BITS bi)(TRUE, 4r123123), UNION(BOOL, BITS)(4r321321), newline)); print(([]STRUCT([]REAL rr, INT i) (((1.0, 2.0), 3), ((4.0, 5.0), 6)), newline, newline)); ( PROC prent = ([]UNION(INT, REAL, COMPL, BOOL, BITS, CHAR, STRING, PROC(REF FILE)VOID) par) VOID: FOR i TO UPB par DO print(par[i]) OD; prent((1, 2.0, 3 I 4, "5", "67", TRUE, 16r89, newline)) ); ( # Parameters of 'printf' # printf(($ 3d l $, 1, UNION(INT, FORMAT) (2))) ); ( # Badly visible calls of 'print' # (print) ((newline, "Parenthesized primary", 1)); FOR i TO 2 DO CASE i IN print, write, SKIP ESAC ((newline, "Case clause primary", i)) OD ) ) algol68g-2.8/test-set/a68g.mc.138.simp03.a680000644000175000001440000000127712224301260014601 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp03# BEGIN #Referencing and dereferencing# INT i1 = 1; INT i2 = 2; INT i3 = 3; INT ii1 := i1; INT ii2 := i2; REF INT iii1 := ii1; print ((newline, "Value should be 1", iii1)); iii1 := ii2; print ((newline, "Value should be 2", iii1)) ENDalgol68g-2.8/test-set/a68g.mc.058.idef02.a680000644000175000001440000000072112224301227014534 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef02# l2: IF INT i := 1; TRUE THEN INT i := 2; print (i) #2# ELSE print (i) FIalgol68g-2.8/test-set/a68g.mc.074.jump04.a680000644000175000001440000000126712224301231014601 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #jump04# (# Jump out of procedure # (# directly # PROC jump = VOID: (print (2); print ((9, GOTO l, 8))); print (1); jump; print (7); l: print (3)); (# indirectly # MODE HIDE = PROC VOID; HIDE p = (TRUE | GOTO m); print (4); p; print (6); m: print (5))) # result is 1, 2, 3, 4, 5 # algol68g-2.8/test-set/a68g.mc.156.smio06.a680000644000175000001440000000227312224301262014602 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio06# BEGIN # 10/08/73, R van Vliet; 30/09/75, revised. Test the print and putroutines.# INT n dots = 10; print(("Print ", whole(n dots, -2), " dots on the next line", newline)); ( PROC spacedot =(REF FILE f) VOID: #This procedure is used to print 'n dots' dots in a highly recursive call on 'print'. First the current position is moved to 'n dots' by printing spaces, second the dots are printed from right to left.# IF char number(f) < n dots THEN space(f); put(f, spacedot) ELSE #The spaces are done, now we turn to dotter.# put(f, dotter) FI, PROC dotter =(REF FILE f) VOID: IF char number(f) > 1 THEN put(f, "."); backspace(f); put(f, (backspace, dotter)) ELSE put (f, ".") FI; print((spacedot, newline)) ) END algol68g-2.8/test-set/a68g.ur.192.r71a.a680000644000175000001440000005233712224301307014274 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r71a # BEGIN print (("independance of operators in the same range", newline)); # controle # INT vf = 110; INT ctr := 0; [1 : vf] BOOL tc; FOR i TO vf DO tc[i] := TRUE OD; PROC pos = (INT i) BOOL: (tc[i] | ctr +:= 1; tc[i] := FALSE | print (("er.1", i, newline)); SKIP); # declarations de servitude # MODE M = STRUCT (CHAR e1, REF M e2); M vm = ("#", NIL); OP - = (REAL a) PROC (INT, INT) INT: SKIP, PROC PROC (REAL, INT) VOID var := PROC (REAL, INT) VOID: (REAL a, INT b) VOID: HEAP INT, OP - = (INT par) BOOL: pos (1), OP - = (M par) BOOL: pos (2), OP - = (PROC (INT, REAL) INT par) BOOL: pos (3), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) par) BOOL: pos (4), OP - = (PROC STRUCT (INT x, y) par) BOOL: pos (5), OP - = (PROC (INT, INT) INT par) BOOL: pos (6), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) par) BOOL: pos (7), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) par) BOOL: pos (8), OP - = ([, , ] [] BOOL par) BOOL: pos (9), OP - = ([, , ] BITS par) BOOL: pos (10), OP - = (INT p1, INT p2) BOOL: pos (11), OP - = (INT p1, M p2) BOOL: pos (12), OP - = (INT p1, PROC (INT, REAL) INT p2) BOOL: pos (13), OP - = (INT p1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p2) BOOL: pos (14), OP - = (INT p1, PROC STRUCT (INT x, y) p2) BOOL: pos (15), OP - = (INT p1, PROC (INT, INT) INT p2) BOOL: pos (16), OP - = (INT p1, REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p2) BOOL: pos (17), OP - = (INT p1, UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p2) BOOL: pos (18), OP - = (INT p1, [, , ] [] BOOL p2) BOOL: pos (19), OP - = (INT p1, [, , ] BITS p2) BOOL: pos (20), OP - = (M p1, INT p2) BOOL: pos (21), OP - = (M p1, M p2) BOOL: pos (22), OP - = (M p1, PROC (INT, REAL) INT p2) BOOL: pos (23), OP - = (M p1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p2) BOOL: pos (24), OP - = (M p1, PROC STRUCT (INT x, y) p2) BOOL: pos (25), OP - = (M p1, PROC (INT, INT) INT p2) BOOL: pos (26), OP - = (M p1, REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p2) BOOL: pos (27), OP - = (M p1, UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p2) BOOL: pos (28), OP - = (M p1, [, , ] [] BOOL p2) BOOL: pos (29), OP - = (M p1, [, , ] BITS p2) BOOL: pos (30), OP - = (PROC (INT, REAL) INT p1, INT p2) BOOL: pos (31), OP - = (PROC (INT, REAL) INT p1, M p2) BOOL: pos (32), OP - = (PROC (INT, REAL) INT p1, PROC (INT, REAL) INT p2) BOOL: pos (33), OP - = (PROC (INT, REAL) INT p1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p2) BOOL: pos (34), OP - = (PROC (INT, REAL) INT p1, PROC STRUCT (INT x, y) p2) BOOL: pos (35), OP - = (PROC (INT, REAL) INT p1, PROC (INT, INT) INT p2) BOOL: pos (36), OP - = (PROC (INT, REAL) INT p1, REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p2) BOOL: pos (37), OP - = (PROC (INT, REAL) INT p1, UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p2) BOOL: pos (38), OP - = (PROC (INT, REAL) INT p1, [, , ] [] BOOL p2) BOOL: pos (39), OP - = (PROC (INT, REAL) INT p1, [, , ] BITS p2) BOOL: pos (40), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p1, INT p2) BOOL: pos (41), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p1, M p2) BOOL: pos (42), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p1, PROC (INT, REAL) INT p2) BOOL: pos (43), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p2) BOOL: pos (44), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p1, PROC STRUCT (INT x, y) p2) BOOL: pos (45), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p1, PROC (INT, INT) INT p2) BOOL: pos (46), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p1, REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p2) BOOL: pos (47), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p1, UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p2) BOOL: pos (48), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p1, [, , ] [] BOOL p2) BOOL: pos (49), OP - = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p1, [, , ] BITS p2) BOOL: pos (50), OP - = (PROC STRUCT (INT x, y) p1, INT p2) BOOL: pos (51), OP - = (PROC STRUCT (INT x, y) p1, M p2) BOOL: pos (52), OP - = (PROC STRUCT (INT x, y) p1, PROC (INT, REAL) INT p2) BOOL: pos (53), OP - = (PROC STRUCT (INT x, y) p1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p2) BOOL: pos (54), OP - = (PROC STRUCT (INT x, y) p1, PROC STRUCT (INT x, y) p2) BOOL: pos (55), OP - = (PROC STRUCT (INT x, y) p1, PROC (INT, INT) INT p2) BOOL: pos (56), OP - = (PROC STRUCT (INT x, y) p1, REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p2) BOOL: pos (57), OP - = (PROC STRUCT (INT x, y) p1, UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p2) BOOL: pos (58), OP - = (PROC STRUCT (INT x, y) p1, [, , ] [] BOOL p2) BOOL: pos (59), OP - = (PROC STRUCT (INT x, y) p1, [, , ] BITS p2) BOOL: pos (60), OP - = (PROC (INT, INT) INT p1, INT p2) BOOL: pos (61), OP - = (PROC (INT, INT) INT p1, M p2) BOOL: pos (62), OP - = (PROC (INT, INT) INT p1, PROC (INT, REAL) INT p2) BOOL: pos (63), OP - = (PROC (INT, INT) INT p1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p2) BOOL: pos (64), OP - = (PROC (INT, INT) INT p1, PROC STRUCT (INT x, y) p2) BOOL: pos (65), OP - = (PROC (INT, INT) INT p1, PROC (INT, INT) INT p2) BOOL: pos (66), OP - = (PROC (INT, INT) INT p1, REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p2) BOOL: pos (67), OP - = (PROC (INT, INT) INT p1, UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p2) BOOL: pos (68), OP - = (PROC (INT, INT) INT p1, [, , ] [] BOOL p2) BOOL: pos (69), OP - = (PROC (INT, INT) INT p1, [, , ] BITS p2) BOOL: pos (70), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p1, INT p2) BOOL: pos (71), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p1, M p2) BOOL: pos (72), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p1, PROC (INT, REAL) INT p2) BOOL: pos (73), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p2) BOOL: pos (74), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p1, PROC STRUCT (INT x, y) p2) BOOL: pos (75), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p1, PROC (INT, INT) INT p2) BOOL: pos (76), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p1, REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p2) BOOL: pos (77), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p1, UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p2) BOOL: pos (78), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p1, [, , ] [] BOOL p2) BOOL: pos (79), OP - = (REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p1, [, , ] BITS p2) BOOL: pos (80), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p1, INT p2) BOOL: pos (81), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p1, M p2) BOOL: pos (82), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p1, PROC (INT, REAL) INT p2) BOOL: pos (83), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p2) BOOL: pos (84), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p1, PROC STRUCT (INT x, y) p2) BOOL: pos (85), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p1, PROC (INT, INT) INT p2) BOOL: pos (86), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p1, REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p2) BOOL: pos (87), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p1, UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p2) BOOL: pos (88), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p1, [, , ] [] BOOL p2) BOOL: pos (89), OP - = (UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p1, [, , ] BITS p2) BOOL: pos (90), OP - = ([, , ] [] BOOL p1, INT p2) BOOL: pos (91), OP - = ([, , ] [] BOOL p1, M p2) BOOL: pos (92), OP - = ([, , ] [] BOOL p1, PROC (INT, REAL) INT p2) BOOL: pos (93), OP - = ([, , ] [] BOOL p1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p2) BOOL: pos (94), OP - = ([, , ] [] BOOL p1, PROC STRUCT (INT x, y) p2) BOOL: pos (95), OP - = ([, , ] [] BOOL p1, PROC (INT, INT) INT p2) BOOL: pos (96), OP - = ([, , ] [] BOOL p1, REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p2) BOOL: pos (97), OP - = ([, , ] [] BOOL p1, UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p2) BOOL: pos (98), OP - = ([, , ] [] BOOL p1, [, , ] [] BOOL p2) BOOL: pos (99), OP - = ([, , ] [] BOOL p1, [, , ] BITS p2) BOOL: pos (100), OP - = ([, , ] BITS p1, INT p2) BOOL: pos (101), OP - = ([, , ] BITS p1, M p2) BOOL: pos (102), OP - = ([, , ] BITS p1, PROC (INT, REAL) INT p2) BOOL: pos (103), OP - = ([, , ] BITS p1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) p2) BOOL: pos (104), OP - = ([, , ] BITS p1, PROC STRUCT (INT x, y) p2) BOOL: pos (105), OP - = ([, , ] BITS p1, PROC (INT, INT) INT p2) BOOL: pos (106), OP - = ([, , ] BITS p1, REF UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) p2) BOOL: pos (107), OP - = ([, , ] BITS p1, UNION (PROC (INT, REAL) VOID, PROC (REAL, INT) VOID) p2) BOOL: pos (108), OP - = ([, , ] BITS p1, [, , ] [] BOOL p2) BOOL: pos (109), OP - = ([, , ] BITS p1, [, , ] BITS p2) BOOL: pos (110), BOOL b = FALSE; (-0000, -vm, -(PROC p = (INT a, REAL b) INT: 0; p), -STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), -(STRUCT (INT x, y): (1, 2)), --0.1, -LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), -(LOC REF PROC PROC (REAL, INT) VOID := var), -BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, -IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, 0000 - 0000, 0000 - vm, 0000 - (PROC p = (INT a, REAL b) INT: 0; p), 0000 - STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), 0000 - (STRUCT (INT x, y): (1, 2)), 0000 - -0.1, 0000 - LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), 0000 - (LOC REF PROC PROC (REAL, INT) VOID := var), 0000 - BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, 0000 - IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, vm - 0000, vm - vm, vm - (PROC p = (INT a, REAL b) INT: 0; p), vm - STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), vm - (STRUCT (INT x, y): (1, 2)), vm - -0.1, vm - LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), vm - (LOC REF PROC PROC (REAL, INT) VOID := var), vm - BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, vm - IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, (PROC p = (INT a, REAL b) INT: 0; p) - 0000, (PROC p = (INT a, REAL b) INT: 0; p) - vm, (PROC p = (INT a, REAL b) INT: 0; p) - (PROC p = (INT a, REAL b) INT: 0; p), (PROC p = (INT a, REAL b) INT: 0; p) - STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), (PROC p = (INT a, REAL b) INT: 0; p) - (STRUCT (INT x, y): (1, 2)), (PROC p = (INT a, REAL b) INT: 0; p) - -0.1, (PROC p = (INT a, REAL b) INT: 0; p) - LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), (PROC p = (INT a, REAL b) INT: 0; p) - (LOC REF PROC PROC (REAL, INT) VOID := var), (PROC p = (INT a, REAL b) INT: 0; p) - BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, (PROC p = (INT a, REAL b) INT: 0; p) - IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP) - 0000, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP) - vm, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP) - (PROC p = (INT a, REAL b) INT: 0; p), STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP) - STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP) - (STRUCT (INT x, y): (1, 2)), STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP) - -0.1, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP) - LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP) - (LOC REF PROC PROC (REAL, INT) VOID := var), STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP) - BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP) - IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, (STRUCT (INT x, y): (1, 2)) - 0000, (STRUCT (INT x, y): (1, 2)) - vm, (STRUCT (INT x, y): (1, 2)) - (PROC p = (INT a, REAL b) INT: 0; p), (STRUCT (INT x, y): (1, 2)) - STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), (STRUCT (INT x, y): (1, 2)) - (STRUCT (INT x, y): (1, 2)), (STRUCT (INT x, y): (1, 2)) - -0.1, (STRUCT (INT x, y): (1, 2)) - LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), (STRUCT (INT x, y): (1, 2)) - (LOC REF PROC PROC (REAL, INT) VOID := var), (STRUCT (INT x, y): (1, 2)) - BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, (STRUCT (INT x, y): (1, 2)) - IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, -0.1 - 0000, -0.1 - vm, -0.1 - (PROC p = (INT a, REAL b) INT: 0; p), -0.1 - STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), -0.1 - (STRUCT (INT x, y): (1, 2)), -0.1 - -0.1, -0.1 - LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), -0.1 - (LOC REF PROC PROC (REAL, INT) VOID := var), -0.1 - BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, -0.1 - IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) - 0000, LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) - vm, LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) - (PROC p = (INT a, REAL b) INT: 0; p), LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) - STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) - (STRUCT (INT x, y): (1, 2)), LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) - -0.1, LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) - LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) - (LOC REF PROC PROC (REAL, INT) VOID := var), LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) - BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)) - IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, (LOC REF PROC PROC (REAL, INT) VOID := var) - 0000, (LOC REF PROC PROC (REAL, INT) VOID := var) - vm, (LOC REF PROC PROC (REAL, INT) VOID := var) - (PROC p = (INT a, REAL b) INT: 0; p), (LOC REF PROC PROC (REAL, INT) VOID := var) - STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), (LOC REF PROC PROC (REAL, INT) VOID := var) - (STRUCT (INT x, y): (1, 2)), (LOC REF PROC PROC (REAL, INT) VOID := var) - -0.1, (LOC REF PROC PROC (REAL, INT) VOID := var) - LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), (LOC REF PROC PROC (REAL, INT) VOID := var) - (LOC REF PROC PROC (REAL, INT) VOID := var), (LOC REF PROC PROC (REAL, INT) VOID := var) - BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, (LOC REF PROC PROC (REAL, INT) VOID := var) - IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, BEGIN [, , ] [] BOOL tb = 4r1230321; tb END - 0000, BEGIN [, , ] [] BOOL tb = 4r1230321; tb END - vm, BEGIN [, , ] [] BOOL tb = 4r1230321; tb END - (PROC p = (INT a, REAL b) INT: 0; p), BEGIN [, , ] [] BOOL tb = 4r1230321; tb END - STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), BEGIN [, , ] [] BOOL tb = 4r1230321; tb END - (STRUCT (INT x, y): (1, 2)), BEGIN [, , ] [] BOOL tb = 4r1230321; tb END - -0.1, BEGIN [, , ] [] BOOL tb = 4r1230321; tb END - LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), BEGIN [, , ] [] BOOL tb = 4r1230321; tb END - (LOC REF PROC PROC (REAL, INT) VOID := var), BEGIN [, , ] [] BOOL tb = 4r1230321; tb END - BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, BEGIN [, , ] [] BOOL tb = 4r1230321; tb END - IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI - 0000, IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI - vm, IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI - (PROC p = (INT a, REAL b) INT: 0; p), IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI - STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) (SKIP), IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI - (STRUCT (INT x, y): (1, 2)), IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI - -0.1, IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI - LOC UNION (STRUCT (INT x, y), STRUCT (INT x, y, z)), IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI - (LOC REF PROC PROC (REAL, INT) VOID := var), IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI - BEGIN [, , ] [] BOOL tb = 4r1230321; tb END, IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI - IF [1, 1, 1] BITS tb; b THEN tb ELSE 8r0 FI, SKIP); FOR i TO vf DO (tc[i] | print (("err.2", i))) OD; print ((ctr, " tests ", (ctr = vf | "ok" | "error"))) END ## ## ## algol68g-2.8/test-set/a68g.mc.097.numr01.a680000644000175000001440000000262312224301247014615 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr01# BEGIN CO This program calculates (x+(1-x)) ** n (which is 1, more or less) for various values of x and n, through binomial expansion. An attempt has been made to localize the precision of the floating point calculations. CO FOR n TO 100 DO CO Begin of length package CO MODE REEL = # LONG # REAL; # OP * = (REEL x, INT i) REEL: x * LENG i; OP / = (REEL x, INT i) REEL: x / LENG i; # REEL one = # LONG # 1.0; REEL val1 = # LONG # 0.99, val2 = # LONG # 0.9, val3 = # LONG # 0.5; CO end of length package CO PROC poly = (REEL x, INT n) REEL: (REEL s := one, a := one; FOR i TO n DO a := a * (one - x) * (n - i + 1) / i; s := s * x + a OD; s) CO poly CO ; printf (($/zzdx, 3(h(6, 2)x)$, n, poly (val1, n), poly (val2, n), poly (val3, n))) OD ENDalgol68g-2.8/test-set/a68g.mc.150.simp16.a680000644000175000001440000000266412224301262014602 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp16# PR norun PR # 321 314159.265e-5 t 1.1 i 2.2 ongeluksgetal aap:noot 654 1 2 3 4 5 6 10 20 30 40 The above is input for the following program # (# Simple unformatted transput # MODE TERMSTRING = STRUCT (STRING string, CHAR term); CHAR ch, INT i, REAL r, BOOL b, COMPL z, [1 : 13] CHAR rowch, STRUCT (TERMSTRING s, t, INT i) struct, [1 : 2] STRUCT (INT i, STRUCT (INT i, j) j) rowstruct; [1 : 2] INT a1, a2; make term (stand in, " :"); read (ch); read (i); read (r); read (b); read (z); read (newline); print ((ch, i, r, " ", b, " ", z, newline)); read ((rowch, newline)); print ((rowch, newline)); read ((struct, newline)); print ((struct, newline)); read ((rowstruct, newline)); print ((rowstruct, newline)); FOR n FROM 4 BY -4 TO -4 DO # 4, 0, -4 # print ((newline, newline, whole (i, n), " ", fixed (r, n, 2), " ", float (r, n, 2, 2))) OD; FOR n TO 4 DO read (IF ODD n THEN a1[n OVER 2 + 1] ELSE a2[n OVER 2] FI) OD; print ((newpage, a1, newline, a2, newline, "End")))algol68g-2.8/test-set/a68g.mc.077.mdeq02.a680000644000175000001440000000112012224301232014542 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #mdeq02# BEGIN # Mode equivalencing # MODE N = PROC (M) M, M = PROC (N) N; PROC M (PROC N (SKIP)); PROC N (PROC M (SKIP)); # Both okay, since 'M' and 'N' are the same # SKIP ENDalgol68g-2.8/test-set/a68g.mc.131.scop06.a680000644000175000001440000000103312224301257014565 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #scop06# BEGIN # Scope error # print (("Need not run", newline)); REF INT ii; MODE A = [ii := LOC INT := 1] BOOL; LOC A; print (ii) ENDalgol68g-2.8/test-set/a68g.mc.172.synt01.a680000644000175000001440000000350712224301275014626 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #synt01# BEGIN # Small infringements # # All tests are made in separate enclosed clauses to allow the parser to recover # # No redeclaring of bolds # (MODE REAL = INT; SKIP); (MODE COMPL = STRUCT(REAL r, phi); SKIP); (MODE FILE = INT; SKIP); (MODE REF INT = REF INT; SKIP); (MODE GOTO = INT; SKIP); (MODE GO = INT ; SKIP); (MODE IS = INT; SKIP); (MODE AT = INT; SKIP); (MODE TRUE = INT; SKIP); (MODE EMPTY = INT; SKIP); (MODE VOID = INT; SKIP); (MODE M = LONG BOOL; SKIP); (MODE M = SHORT FILE; SKIP); (MODE M = LONG REF INT; SKIP); (MODE M = FLEX FLEX [] CHAR; SKIP); (MODE LONG BOOL = BITS; SKIP); (MODE SHORT FILE = FORMAT; SKIP); (MODE LONG REF INT = INT; SKIP); (MODE FLEX [] INT = COMPL; SKIP); (MODE FLEX M = COMPL; SKIP); (PRIO + = 08; SKIP); (02r1001, 7r16, 16refg, 17refg); (HEAP [@1 : 6]REAL); (OP IS = (INT i) BOOL : i = 0; IS 1); (OP OF = (INT i) BOOL : i = 0; OF 1); (OP AT = (INT i) BOOL : i = 0; AT 1); (OP IS = (INT i, j) BOOL : i = j; 1 IS 2); # No comments in tags and denotations # ( 12 34); # OK # ( 12 # KO # 34); ( 12 CO KO CO 34 ); ( 12 COMMENT KO COMMENT 34 ); ( algol # KO # 68 ); (LONG INT i = LENG 1; SKIP); (LONG # KO # INT i = LENG 1; SKIP); (SHORT # KO # 2r101); # GO TO is allowed, but watch the loop-clause # (GO TO stop; GO # KO # TO stop; GO TO stop); (FOR i FROM GO TO stop DO SKIP OD); (FROM GO TO stop DO SKIP OD); SKIP END COMMENT No comment allowed COMMENT algol68g-2.8/test-set/a68g.mc.063.idef07.a680000644000175000001440000000121712224301230014530 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef07# BEGIN # Redeclaring LWB # OP LWB = ([] INT a) REAL: a[1] + a[2]; OP LWB = ([] REAL a) REAL: a[1] - a[2]; print (LWB (1 | (8, 2), 3, [] INT: SKIP)); # 10.0 # print (LWB (1 | (8, 2), 3, [] REAL: SKIP)); # 6.0 # SKIP ENDalgol68g-2.8/test-set/a68g.ur.193.r71b.a680000644000175000001440000001163512224301310014264 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r71b # (print (("independance of operators in different range contexts", newline)); INT vf = 17; INT ctr := 0; BOOL b = TRUE; MODE M = STRUCT (CHAR e1, REF M e2); PRIO +> = 1, OP +> = (BOOL b) REF BOOL: HEAP BOOL := b, +> = (BOOL a, REF BOOL b) INT: ctr +:= (b | 0 | 1); b +> +>FALSE; (OP +> = (INT a) INT: 1, PRIO +> = 2, OP +> = (REAL a, b) INT: 6; OP +> = (INT a, b) INT: 4, +> = (REAL a) INT: 5; b +> +>FALSE; SKIP); IF OP +> = (M a) INT: 4, PRIO +> = 1, OP +> = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) a, b) INT: 9; OP +> = (M a, b) INT: 2, +> = (STRUCT (CHAR e1, REF STRUCT (CHAR e1, REF M e) e2) a) INT: 7; b +> +>FALSE; b THEN OP +> = (PROC (INT, REAL) VOID a) INT: 1, PRIO +> = 6, OP +> = (PROC (REAL, INT) VOID a, b) INT: 2; OP +> = (PROC (INT, REAL) VOID a, b) INT: 6, +> = (PROC (REAL, INT) VOID a) INT: 3; b +> +>FALSE; SKIP ELSE OP +> = (STRUCT (INT x, y) a) INT: 5, PRIO +> = 6, OP +> = (STRUCT (INT y, x) a, b) INT: 2; OP +> = (STRUCT (INT x, y) a, b) INT: 8, +> = (STRUCT (INT y, x) a) INT: 8; b +> +>FALSE; SKIP FI; TO 1 WHILE OP +> = (PROC (INT, REAL) VOID a) INT: 7, PRIO +> = 6, OP +> = (UNION (PROC (REAL, INT) VOID, PROC (INT, REAL) INT) a, b) INT: 6; OP +> = (PROC (INT, REAL) VOID a, b) INT: 5, +> = (UNION (PROC (REAL, INT) VOID, PROC (INT, REAL) INT) a) INT: 6; b +> +>FALSE; b DO OP +> = (UNION (PROC (INT, REAL) INT, PROC (REAL, INT) INT) a) INT: 3, PRIO +> = 4, OP +> = (UNION (PROC (REAL, INT) VOID, PROC (INT, INT) INT) a, b) INT: 3; OP +> = (UNION (PROC (INT, REAL) INT, PROC (REAL, INT) INT) a, b) INT: 6, +> = (UNION (PROC (REAL, INT) VOID, PROC (INT, INT) INT) a) INT: 9; b +> +>FALSE; SKIP OD; (OP +> = (UNION (STRUCT (INT y, x), STRUCT (INT x, y)) a) INT: 4, PRIO +> = 4, OP +> = (UNION (STRUCT (REAL x, y), STRUCT (REAL y, x)) a, b) INT: 6; OP +> = (UNION (STRUCT (INT y, x), STRUCT (INT x, y)) a, b) INT: 7, +> = (UNION (STRUCT (REAL x, y), STRUCT (REAL y, x)) a) INT: 1; b +> +>FALSE; SKIP); IF OP +> = (CHAR a) INT: 8, PRIO +> = 8, OP +> = (REF REF PROC REF PROC [] CHAR a, b) INT: 5; OP +> = (CHAR a, b) INT: 6, +> = (REF REF PROC REF PROC [] CHAR a) INT: 4; b +> +>FALSE; b THEN OP +> = (PROC (INT, REAL) INT a) INT: 7, PRIO +> = 4, OP +> = (INT a, b) INT: 2; OP +> = (PROC (INT, REAL) INT a, b) INT: 8, +> = (INT a) INT: 7; b +> +>FALSE; SKIP ELSE OP +> = (REF PROC REF M a) INT: 8, PRIO +> = 8, OP +> = (REF PROC M a, b) INT: 3; OP +> = (REF PROC REF M a, b) INT: 6, +> = (REF PROC M a) INT: 6; b +> +>FALSE; SKIP FI; TO 1 WHILE OP +> = (PROC BOOL a) INT: 6, PRIO +> = 7, OP +> = (REF BOOL a, b) INT: 5; OP +> = (PROC BOOL a, b) INT: 4, +> = (REF BOOL a) INT: 3; b +> +>FALSE; b DO OP +> = (REF PROC INT a) INT: 3, PRIO +> = 4, OP +> = (COMPL a, b) INT: 5; OP +> = (REF PROC INT a, b) INT: 4, +> = (COMPL a) INT: 9; b +> +>FALSE; SKIP OD; (OP +> = (REAL a) INT: 5, PRIO +> = 3, OP +> = (COMPL a, b) INT: 6; OP +> = (REAL a, b) INT: 3, +> = (COMPL a) INT: 2; b +> +>FALSE; SKIP); IF OP +> = (INT a) INT: 6, PRIO +> = 5, OP +> = (REF COMPL a, b) INT: 4; OP +> = (INT a, b) INT: 1, +> = (REF COMPL a) INT: 8; b +> +>FALSE; b THEN OP +> = ([] BOOL a) INT: 3, PRIO +> = 2, OP +> = (BITS a, b) INT: 3; OP +> = ([] BOOL a, b) INT: 3, +> = (BITS a) INT: 4; b +> +>FALSE; SKIP ELSE MODE BITES = STRUCT (INT n, [1 : 4] CHAR text); OP +> = ([] CHAR a) INT: 3, PRIO +> = 7, OP +> = (BITES a, b) INT: 9; OP +> = ([] CHAR a, b) INT: 8, +> = (BITES a) INT: 7; b +> +>FALSE; SKIP FI; TO 1 WHILE OP +> = ([] REAL a) INT: 5, PRIO +> = 3, OP +> = (REAL a, b) INT: 2; OP +> = ([] REAL a, b) INT: 1, +> = (REAL a) INT: 1; b +> +>FALSE; b DO OP +> = ([, , ] [] M a) INT: 3, PRIO +> = 2, OP +> = (M a, b) INT: 1; OP +> = ([, , ] [] M a, b) INT: 3, +> = (M a) INT: 8; b +> +>FALSE; SKIP OD; b +> +>FALSE; print ((ctr, " tests ", (ctr = vf | "ok" | "error")))) ## ## ## algol68g-2.8/test-set/a68g.mc.101.numr05.a680000644000175000001440000001321612224301250014575 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr05# BEGIN # JKok, 730620, test least squares procedures, 740919, tested on Control Data A68 Compiler, results OK # MODE TOLS = STRUCT (REAL prec, max), OP * = ([] REAL a, b) REAL: (REAL s := 0; FOR i TO UPB a DO s +:= a[i] * b[i] OD; s), OP * = (REAL a, [] REAL b) [] REAL: ([1 : UPB b] REAL c; FOR i TO UPB b DO c[i] := a * b[i] OD; c), OP +:= = (REF [] REAL a, [] REAL b) REF [] REAL: (FOR i TO UPB a DO a[i] +:= b[i] OD; a); PROC lsqdec = (REF [, ] REAL a, REF TOLS aux, REF [] REAL aid, REF [] INT ci) INT: IF INT n = 1 UPB a, m = 2 UPB a; UPB aid /= m OR UPB ci /= m THEN -1 ELSE INT r := 0, minmn := (m < n | m | n), pk := 1, REAL w, eps, sigma := 0, aidk, beta, [1 : m] REAL sum; FOR k TO m DO IF (w := sum[k] := a[, k] * a[, k]) > sigma THEN sigma := w; pk := k FI OD; w := max OF aux := sqrt (sigma); eps := (prec OF aux) * w; FOR k TO minmn WHILE w > eps DO REAL akk = a[k, pk]; r := k; ci[k] := pk; IF pk /= k THEN [] REAL h = a[, k]; a[, k] := a[, pk]; a[, pk] := h; sum[pk] := sum[k] FI; aidk := aid[k] := (akk < 0 | w | -w); a[k, k] := akk - aidk; beta := -1 / (sigma - akk * aidk); pk := k; sigma := 0; FOR j FROM k + 1 TO m DO a[k : , j] +:= beta * (a[k : , k] * a[k : , j]) * a[k : , k]; IF (w := sum[j] -:= a[k, j] ** 2) > sigma THEN pk := j; sigma := w FI OD; w := sqrt (sigma) OD; r FI # end of householder triangularization # , PROC lsqsol = ([, ] REAL a, [] REAL aid, [] INT ci, [] REAL b) [] REAL: BEGIN INT n = 1 UPB a, m = 2 UPB a, INT cik; [1 : n] REAL bb := b; IF m <= n THEN FOR k TO m DO bb[k : ] +:= a[k : , k] * bb[k : ] / (aid[k] * a[k, k]) * a[k : , k] OD; FOR k FROM m BY -1 TO 1 DO bb[k] := (bb[k] - a[k, k + 1 : ] * bb[k + 1 : m]) / aid[k] OD; FOR k FROM m - 1 BY -1 TO 1 DO IF cik := ci[k]; cik /= k THEN REAL w = bb[k]; bb[k] := bb[cik]; bb[cik] := w FI OD FI; bb END # of computation of least squares solution # ; FOR n FROM 4 TO 6 DO FOR m TO n DO [1 : n, 1 : m] REAL a, [1 : n] REAL b, [1 : m] REAL aid, [1 : m] INT piv, TOLS aux; FOR i TO n DO FOR j TO m DO a[i, j] := i ** (j - 1) OD OD; FOR i TO n DO b[i] := i ** (n - 1) OD; prec OF aux := 1e-10; print (newline); print ("n ="); print (n); print (newline); print ("m ="); print (m); print (new line); IF lsqdec (a, aux, aid, piv) < m THEN print (" rank < number of columns") ELSE [1 : n] REAL sol := lsqsol (a, aid, piv, b); print (" solution :"); FOR k TO m DO print ((fixed (sol[k], 0, 4), blank)) OD; print (newline); print (" residue : "); print (fixed (sol[m + 1 : ] * sol[m + 1 : ], 0, 4)); print (newline); print (newline) FI # Output approximately: sol: 25.0 res: 2390.0 sol: -27.0 20.8 res: 226.8 sol: 10.5 -16.7 7.5 res: 1.8 sol: 0.0 0.0 0.0 1.0 res: 0.0 sol: 195.8 res: 271290.8 sol: -250.6 148.8 res: 49876.4 sol: 158.4 -201.77 58.43 res: 2081.83 sol: -43.2 81.43 -49.57 12.0 res: 8.23 sol: 0.0 0.0 0.0 0.0 1.0 res: 0.0 sol: 2033.5 res: 46529717.5 sol: -2860.0 1398.14 res: 12320657.14 sol: 2250.0 -2434.36 547.5 res: 1129757.14 sol: -1040.0 1704.25 -823.3 130.56 res: 25257.14 sol: 220.0 -465.75 344.17 -114.44 17.50 res: 57.14 sol: 0.0 0.0 0.0 0.0 0.0 1.0 res: 0.0 # OD OD ENDalgol68g-2.8/test-set/a68g.mc.034.coer06.a680000644000175000001440000000105512224301223014550 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer06# BEGIN # Case clause # UNION (INT, REAL) ir, UNION (INT, CHAR) ic; print(CASE (FALSE|ir|ic) IN (INT):1, (REAL):2 ESAC) # Error, (p|ir|ic) cannot be meekly balanced # END algol68g-2.8/test-set/a68g.mc.145.simp10.a680000644000175000001440000000072412224301261014572 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp10# (INT i := 1; PROC a = (INT j) VOID: print (i + j); (INT i := 2; a (10)) # 11 # )algol68g-2.8/test-set/a68g.mc.024.clau05.a680000644000175000001440000000103312224301222014535 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #clau05# (#Test vacuum as string # PROC p = (STRING s) VOID: print ((newline, LWB s, UPB s, s)); p ("") # +1 +0 # ; p (()) # +1 +0 # ; p (BEGIN END) #1 0# )algol68g-2.8/test-set/a68g.mc.011.appl11.a680000644000175000001440000000500412224301217014544 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl11# COMMENT This is the intended program BEGIN # ALGOL 68 program TJD730702. This program tests some operator calculus and print the same results as the ALGOL 68 program TJD730701, viz., a difference table of a 4-th degree polynomial. # MODE FUN = PROC(INT)INT; OPERATOR nabla = (FUN t)FUN : (INT x)INT : t (x)- t (x-1); MODE OPERATOR = PROC(FUN)FUN; OP UP = (OPERATOR a, INT b)OPERATOR : (FUN f) FUN : IF b=0 THEN f ELSE a ( (a UP (b-1)) (f)) FI; PRIO MIN = 1; OP MIN = (INT a, b)INT : (a<=b | a | b); FUN pol4 = (INT x)INT : x*(x+1)*(x+2)*(x+3); FOR n FROM 0 TO 20 DO print(n); FOR k FROM 0 TO (n-1) MIN 5 DO print((nabla UP k) (pol4) (n)) OD; print(newline) OD END COMMENT # end of intended program # BEGIN # Attempt at partial parametrization # # A / between ## separates the partial params from the direct ones # MODE FUN = UNION(PROC(INT)INT, FUNINTINT); MODE FUNINTINT = # caused by nabla # STRUCT(PROC(FUN, # / # INT)INT f, REF FUN p); OP FUN2INT = (FUN f, INT i)INT : CASE f IN (PROC(INT)INT pf) : pf(i), (FUNINTINT f) : (f OF f)(p OF f, i) ESAC; OPERATOR nabla = (FUN t)FUN : FUNINTINT # cast for scope-violating object # ( (FUN t, INT x)INT : t FUN2INT (x)- t FUN2INT (x-1), HEAP FUN:= t); MODE OPERATOR = UNION(PROC(FUN)FUN, OPINTFUN); MODE OPINTFUN = # caused by UP # STRUCT( PROC(OPERATOR, INT, # / # FUN) FUN f, REF OPERATOR p1, REF INT p2); OP OP2FUN = (OPERATOR op, FUN f) FUN : CASE op IN (PROC(FUN)FUN pf) : pf(f), (OPINTFUN op) : (f OF op)(p1 OF op, p2 OF op, f) ESAC; OP UP = (OPERATOR a, INT b)OPERATOR : OPINTFUN # cast for scope-violating object # ( (OPERATOR a, INT b, # / # FUN f) FUN : IF b=0 THEN f ELSE a OP2FUN ( (a UP (b-1)) OP2FUN (f)) FI, HEAP OPERATOR:= a, HEAP INT:= b); PRIO MIN = 1; PRIO FUN2INT = 9; PRIO OP2FUN = 9; OP MIN = (INT a, b)INT : (a<=b | a | b); FUN pol4 = (INT x)INT : x*(x+1)*(x+2)*(x+3); FOR n FROM 0 TO 20 DO print(n); FOR k FROM 0 TO (n-1) MIN 5 DO print((nabla UP k) OP2FUN (pol4) FUN2INT (n)) OD; print(newline) OD END algol68g-2.8/test-set/a68g.mc.140.simp05.a680000644000175000001440000000127112224301260014566 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp05# # Simple jumps # (INT j := 0, i; k: i := j; IF i >= 2 THEN GOTO l FI; print ("0"); m: IF i >= 1 THEN n FI; print ("0"); o: GOTO p; l: print ("1"); i := i - 2; m; n: print ("1"); o; p: print (newline); j := j + 1; IF j <= 3 THEN k FI # Result: 00 01 10 11 # )algol68g-2.8/test-set/a68g.mc.115.oper06.a680000644000175000001440000000075512224301254014577 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper06# BEGIN # operator # OP +=(REAL a, b)REAL: a-b, OP +=(REF REAL a,b)REAL: a-b; # error, related modes # SKIP END algol68g-2.8/test-set/a68g.mc.092.null04.a680000644000175000001440000000060312224301246014577 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #null04# (SKIP, SKIP)algol68g-2.8/test-set/a68g.ur.189.r6b.a680000644000175000001440000005017012224301306014211 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r6b # (print (("coercions in firm context", newline)); INT vf = 800; INT ctrt := 0, ctr := 0, ctrloc := 0; BOOL bascule := TRUE, b, PROC controle = VOID: IF b AND ctr = ctrloc + 15 THEN ctr +:= 5 ELSE print (("er. in test", ctrt, ctr, ctrloc + 15, newline)) FI; PROC tilt = VOID: print (("er.op", ctrt, ctr - ctrloc, newline)); # servitudes # UNION (INT, REAL) vu = 1e0, MODE SB = STRUCT (BOOL ch, of), UBE = UNION (BOOL, INT), PRIO BOLD = 2, -==: = 1; # mode a posteriori : [,] BOOL # OP -==: = ([, ] BOOL a) [, ] BOOL: (FALSE, FALSE, NOT (ctr +:= 1; a)[3, 1]), -==: = ([, ] BOOL a, b) [, ] BOOL: (a[3, 1] AND b[3, 1] | ctr +:= 2; (FALSE, FALSE, TRUE) | tilt; SKIP), BOLD = ([, ] BOOL a, b) [, ] BOOL: (NOT a[3, 1] AND b[3, 1] | ctr +:= 2; (FALSE, FALSE, bascule := NOT bascule) | tilt; SKIP); # mode a posteriori : UNION ( BITS , REAL , SB ) # OP -==: = (UNION (BITS, REAL, SB) a) SB: (NOT ch OF (ctr +:= 1; a | (SB a): a), FALSE), -==: = (UNION (BITS, REAL, SB) a, b) SB: (((a | (SB a): ch OF a) AND (b | (SB b): ch OF b) | ctr +:= 2; TRUE | tilt; SKIP), FALSE), BOLD = (UNION (BITS, REAL, SB) a, b) SB: ((NOT (a | (SB a): ch OF a) AND (b | (SB b): ch OF b) | ctr +:= 2; bascule := NOT bascule | tilt; SKIP), FALSE); # mode a posteriori : UNION ( UNION ( COMPL , BOOL ), INT , UNION ( INT , UBE )) # OP -==: = (UNION (UNION (COMPL, BOOL), INT, UNION (INT, UBE)) a) BOOL: (ctr +:= 1; a | (BOOL a): NOT a), -==: = (UNION (UNION (COMPL, BOOL), INT, UNION (INT, UBE)) a, b) BOOL: ((a | (BOOL a): a) AND (b | (BOOL b): b) | ctr +:= 2; TRUE | tilt; SKIP), BOLD = (UNION (UNION (COMPL, BOOL), INT, UNION (INT, UBE)) a, b) BOOL: (NOT (a | (BOOL a): a) AND (b | (BOOL b): b) | ctr +:= 2; bascule := NOT bascule | tilt; SKIP); BEGIN # coercion sur mode : SB # SB ident = (TRUE, FALSE); STRUCT (INT a, SB ch) de = (0, ident), [] SB rang = (SKIP, ident, SKIP), PROC proc = (SB a) SB: a; #contextes # ctrt := 1; ctrloc := ctr; b := ch OF (ident -==: ident -==: -==:ident BOLD (-==:-==:ident -==: (ident -==: ident)) BOLD ident); controle; ctrt := 2; ctrloc := ctr; b := ch OF (SB ((TRUE, FALSE)) -==: SB ((TRUE, FALSE)) -==: -==:SB ((TRUE, FALSE)) BOLD (-==:-==:SB ((TRUE, FALSE)) -==: (SB ((TRUE, FALSE)) -==: SB ((TRUE, FALSE)))) BOLD SB ((TRUE, FALSE))); controle; ctrt := 3; ctrloc := ctr; b := ch OF (ch OF de -==: ch OF de -==: -==:ch OF de BOLD (-==:-==:ch OF de -==: (ch OF de -==: ch OF de)) BOLD ch OF de); controle; ctrt := 4; ctrloc := ctr; b := ch OF (rang[2] -==: rang[2] -==: -==:rang[2] BOLD (-==:-==:rang[2] -==: (rang[2] -==: rang[2])) BOLD rang[2]); controle; ctrt := 5; ctrloc := ctr; b := ch OF (proc (ident) -==: proc (ident) -==: -==:proc (ident) BOLD (-==:-==:proc (ident) -==: (proc (ident) -==: proc (ident))) BOLD proc (ident)); controle; ctrt := 6; ctrloc := ctr; b := ch OF (IF FALSE THEN SKIP ELSE ident FI -==: IF FALSE THEN SKIP ELSE ident FI -==: -==:IF FALSE THEN SKIP ELSE ident FI BOLD (-==:-==:IF FALSE THEN SKIP ELSE ident FI -==: (IF FALSE THEN SKIP ELSE ident FI -==: IF FALSE THEN SKIP ELSE ident FI)) BOLD IF FALSE THEN SKIP ELSE ident FI); controle; ctrt := 7; ctrloc := ctr; b := ch OF (SB (1 | ident, SKIP) -==: SB (1 | ident, SKIP) -==: -==:SB (1 | ident, SKIP) BOLD (-==:-==:SB (1 | ident, SKIP) -==: (SB (1 | ident, SKIP) -==: SB (1 | ident, SKIP))) BOLD SB (1 | ident, SKIP)); controle; ctrt := 8; ctrloc := ctr; b := ch OF ((GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: -==:(GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) BOLD (-==:-==:(GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: ((GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e))) BOLD (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e)); controle; SKIP END; BEGIN # coercion sur mode : BOOL # BOOL ident = TRUE; STRUCT (INT a, BOOL ch) de = (0, ident), [] BOOL rang = (SKIP, ident, SKIP), PROC proc = (BOOL a) BOOL: a; #contextes # ctrt := 9; ctrloc := ctr; b := ident -==: ident -==: -==:ident BOLD (-==:-==:ident -==: (ident -==: ident)) BOLD ident; controle; ctrt := 10; ctrloc := ctr; b := BOOL (TRUE) -==: BOOL (TRUE) -==: -==:BOOL (TRUE) BOLD (-==:-==:BOOL (TRUE) -==: (BOOL (TRUE) -==: BOOL (TRUE))) BOLD BOOL (TRUE); controle; ctrt := 11; ctrloc := ctr; b := ch OF de -==: ch OF de -==: -==:ch OF de BOLD (-==:-==:ch OF de -==: (ch OF de -==: ch OF de)) BOLD ch OF de; controle; ctrt := 12; ctrloc := ctr; b := rang[2] -==: rang[2] -==: -==:rang[2] BOLD (-==:-==:rang[2] -==: (rang[2] -==: rang[2])) BOLD rang[2]; controle; ctrt := 13; ctrloc := ctr; b := proc (ident) -==: proc (ident) -==: -==:proc (ident) BOLD (-==:-==:proc (ident) -==: (proc (ident) -==: proc (ident))) BOLD proc (ident); controle; ctrt := 14; ctrloc := ctr; b := IF FALSE THEN SKIP ELSE ident FI -==: IF FALSE THEN SKIP ELSE ident FI -==: -==:IF FALSE THEN SKIP ELSE ident FI BOLD (-==:-==:IF FALSE THEN SKIP ELSE ident FI -==: (IF FALSE THEN SKIP ELSE ident FI -==: IF FALSE THEN SKIP ELSE ident FI)) BOLD IF FALSE THEN SKIP ELSE ident FI; controle; ctrt := 15; ctrloc := ctr; b := BOOL (1 | ident, SKIP) -==: BOOL (1 | ident, SKIP) -==: -==:BOOL (1 | ident, SKIP) BOLD (-==:-==:BOOL (1 | ident, SKIP) -==: (BOOL (1 | ident, SKIP) -==: BOOL (1 | ident, SKIP))) BOLD BOOL (1 | ident, SKIP); controle; ctrt := 16; ctrloc := ctr; b := (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: -==:(GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) BOLD (-==:-==:(GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: ((GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e))) BOLD (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e); controle; SKIP END; BEGIN # coercion sur mode : REF [,] BOOL # REF [, ] BOOL ident = HEAP [3, 1] BOOL := (FALSE, FALSE, TRUE); STRUCT (INT a, REF [, ] BOOL ch) de = (0, ident), [] REF [, ] BOOL rang = (SKIP, ident, SKIP), PROC proc = (REF [, ] BOOL a) REF [, ] BOOL: a; #contextes # ctrt := 17; ctrloc := ctr; b := (ident -==: ident -==: -==:ident BOLD (-==:-==:ident -==: (ident -==: ident)) BOLD ident)[3, 1]; controle; ctrt := 18; ctrloc := ctr; b := (REF [, ] BOOL (HEAP [3, 1] BOOL := (FALSE, FALSE, TRUE)) -==: REF [, ] BOOL (HEAP [3, 1] BOOL := (FALSE, FALSE, TRUE)) -==: -==:REF [, ] BOOL (HEAP [3, 1] BOOL := (FALSE, FALSE, TRUE)) BOLD (-==:-==:REF [, ] BOOL (HEAP [3, 1] BOOL := (FALSE, FALSE, TRUE)) -==: (REF [, ] BOOL (HEAP [3, 1] BOOL := (FALSE, FALSE, TRUE)) -==: REF [, ] BOOL (HEAP [3, 1] BOOL := (FALSE, FALSE, TRUE)))) BOLD REF [, ] BOOL (HEAP [3, 1] BOOL := (FALSE, FALSE, TRUE)))[3, 1]; controle; ctrt := 19; ctrloc := ctr; b := (ch OF de -==: ch OF de -==: -==:ch OF de BOLD (-==:-==:ch OF de -==: (ch OF de -==: ch OF de)) BOLD ch OF de)[3, 1]; controle; ctrt := 20; ctrloc := ctr; b := (rang[2] -==: rang[2] -==: -==:rang[2] BOLD (-==:-==:rang[2] -==: (rang[2] -==: rang[2])) BOLD rang[2])[3, 1]; controle; ctrt := 21; ctrloc := ctr; b := (proc (ident) -==: proc (ident) -==: -==:proc (ident) BOLD (-==:-==:proc (ident) -==: (proc (ident) -==: proc (ident))) BOLD proc (ident))[3, 1]; controle; ctrt := 22; ctrloc := ctr; b := (IF FALSE THEN SKIP ELSE ident FI -==: IF FALSE THEN SKIP ELSE ident FI -==: -==:IF FALSE THEN SKIP ELSE ident FI BOLD (-==:-==:IF FALSE THEN SKIP ELSE ident FI -==: (IF FALSE THEN SKIP ELSE ident FI -==: IF FALSE THEN SKIP ELSE ident FI)) BOLD IF FALSE THEN SKIP ELSE ident FI)[3, 1]; controle; ctrt := 23; ctrloc := ctr; b := (REF [, ] BOOL (1 | ident, SKIP) -==: REF [, ] BOOL (1 | ident, SKIP) -==: -==:REF [, ] BOOL (1 | ident, SKIP) BOLD (-==:-==:REF [, ] BOOL (1 | ident, SKIP) -==: (REF [, ] BOOL (1 | ident, SKIP) -==: REF [, ] BOOL (1 | ident, SKIP))) BOLD REF [, ] BOOL (1 | ident, SKIP))[3, 1]; controle; ctrt := 24; ctrloc := ctr; b := ((GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: -==:(GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) BOLD (-==:-==:(GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: ((GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e))) BOLD (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e))[3, 1]; controle; SKIP END; BEGIN # coercion sur mode : REF SB # REF SB ident = HEAP SB := (TRUE, FALSE); STRUCT (INT a, REF SB ch) de = (0, ident), [] REF SB rang = (SKIP, ident, SKIP), PROC proc = (REF SB a) REF SB: a; #contextes # ctrt := 25; ctrloc := ctr; b := ch OF (ident -==: ident -==: -==:ident BOLD (-==:-==:ident -==: (ident -==: ident)) BOLD ident); controle; ctrt := 26; ctrloc := ctr; b := ch OF (REF SB (HEAP SB := (TRUE, FALSE)) -==: REF SB (HEAP SB := (TRUE, FALSE)) -==: -==:REF SB (HEAP SB := (TRUE, FALSE)) BOLD (-==:-==:REF SB (HEAP SB := (TRUE, FALSE)) -==: (REF SB (HEAP SB := (TRUE, FALSE)) -==: REF SB (HEAP SB := (TRUE, FALSE)))) BOLD REF SB (HEAP SB := (TRUE, FALSE))); controle; ctrt := 27; ctrloc := ctr; b := ch OF (ch OF de -==: ch OF de -==: -==:ch OF de BOLD (-==:-==:ch OF de -==: (ch OF de -==: ch OF de)) BOLD ch OF de); controle; ctrt := 28; ctrloc := ctr; b := ch OF (rang[2] -==: rang[2] -==: -==:rang[2] BOLD (-==:-==:rang[2] -==: (rang[2] -==: rang[2])) BOLD rang[2]); controle; ctrt := 29; ctrloc := ctr; b := ch OF (proc (ident) -==: proc (ident) -==: -==:proc (ident) BOLD (-==:-==:proc (ident) -==: (proc (ident) -==: proc (ident))) BOLD proc (ident)); controle; ctrt := 30; ctrloc := ctr; b := ch OF (IF FALSE THEN SKIP ELSE ident FI -==: IF FALSE THEN SKIP ELSE ident FI -==: -==:IF FALSE THEN SKIP ELSE ident FI BOLD (-==:-==:IF FALSE THEN SKIP ELSE ident FI -==: (IF FALSE THEN SKIP ELSE ident FI -==: IF FALSE THEN SKIP ELSE ident FI)) BOLD IF FALSE THEN SKIP ELSE ident FI); controle; ctrt := 31; ctrloc := ctr; b := ch OF (REF SB (1 | ident, SKIP) -==: REF SB (1 | ident, SKIP) -==: -==:REF SB (1 | ident, SKIP) BOLD (-==:-==:REF SB (1 | ident, SKIP) -==: (REF SB (1 | ident, SKIP) -==: REF SB (1 | ident, SKIP))) BOLD REF SB (1 | ident, SKIP)); controle; ctrt := 32; ctrloc := ctr; b := ch OF ((GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: -==:(GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) BOLD (-==:-==:(GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: ((GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e))) BOLD (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e)); controle; SKIP END; BEGIN # coercion sur mode : REF BOOL # REF BOOL ident = HEAP BOOL := TRUE; STRUCT (INT a, REF BOOL ch) de = (0, ident), [] REF BOOL rang = (SKIP, ident, SKIP), PROC proc = (REF BOOL a) REF BOOL: a; #contextes # ctrt := 33; ctrloc := ctr; b := ident -==: ident -==: -==:ident BOLD (-==:-==:ident -==: (ident -==: ident)) BOLD ident; controle; ctrt := 34; ctrloc := ctr; b := REF BOOL (HEAP BOOL := TRUE) -==: REF BOOL (HEAP BOOL := TRUE) -==: -==:REF BOOL (HEAP BOOL := TRUE) BOLD (-==:-==:REF BOOL (HEAP BOOL := TRUE) -==: (REF BOOL (HEAP BOOL := TRUE) -==: REF BOOL (HEAP BOOL := TRUE))) BOLD REF BOOL (HEAP BOOL := TRUE); controle; ctrt := 35; ctrloc := ctr; b := ch OF de -==: ch OF de -==: -==:ch OF de BOLD (-==:-==:ch OF de -==: (ch OF de -==: ch OF de)) BOLD ch OF de; controle; ctrt := 36; ctrloc := ctr; b := rang[2] -==: rang[2] -==: -==:rang[2] BOLD (-==:-==:rang[2] -==: (rang[2] -==: rang[2])) BOLD rang[2]; controle; ctrt := 37; ctrloc := ctr; b := proc (ident) -==: proc (ident) -==: -==:proc (ident) BOLD (-==:-==:proc (ident) -==: (proc (ident) -==: proc (ident))) BOLD proc (ident); controle; ctrt := 38; ctrloc := ctr; b := IF FALSE THEN SKIP ELSE ident FI -==: IF FALSE THEN SKIP ELSE ident FI -==: -==:IF FALSE THEN SKIP ELSE ident FI BOLD (-==:-==:IF FALSE THEN SKIP ELSE ident FI -==: (IF FALSE THEN SKIP ELSE ident FI -==: IF FALSE THEN SKIP ELSE ident FI)) BOLD IF FALSE THEN SKIP ELSE ident FI; controle; ctrt := 39; ctrloc := ctr; b := REF BOOL (1 | ident, SKIP) -==: REF BOOL (1 | ident, SKIP) -==: -==:REF BOOL (1 | ident, SKIP) BOLD (-==:-==:REF BOOL (1 | ident, SKIP) -==: (REF BOOL (1 | ident, SKIP) -==: REF BOOL (1 | ident, SKIP))) BOLD REF BOOL (1 | ident, SKIP); controle; ctrt := 40; ctrloc := ctr; b := (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: -==:(GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) BOLD (-==:-==:(GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: ((GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e) -==: (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e))) BOLD (GOTO ee EXIT e: (INT x; vu | (REAL): ident) EXIT ee: GOTO e); controle; SKIP END; print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.146.simp11.a680000644000175000001440000000546312224301261014601 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp11# BEGIN # Translation decimal number to Roman notation and vice versa # PROC roman = (INT number) STRING: BEGIN INT n := number, STRING result, [] STRUCT (INT value, STRING r) table = ((1000, "M"), (900, "CM"), (500, "D"), (400, "CD"), (100, "C"), (90, "XC"), (50, "L"), (40, "XL"), (10, "X"), (9, "IX"), (5, "V"), (4, "IV"), (1, "I")); FOR i TO UPB table DO INT v = value OF table[i], STRING r = r OF table[i]; WHILE v LE n DO (result +:= r, n -:= v) OD OD; result END, PROC value of roman = (STRING text) INT: IF text = "" THEN 0 ELSE OP ABS = (CHAR s) INT: CASE INT p; char in string (s, p, "IVXLCDM"); p IN 1, 5, 10, 50, 100, 500, 1000 ESAC, PROC char in string = (CHAR c, REF INT i, STRING s) BOOL: (FOR k TO UPB s DO (c = s[k] | i := k; l) OD; FALSE EXIT l: TRUE); INT v, maxv := 0, maxp; FOR p TO UPB text DO IF (v := ABS text[p]) > maxv THEN maxp := p; maxv := v FI OD; maxv - value of roman (text[ : maxp - 1]) + value of roman (text[maxp + 1 : ]) FI; print (roman (1968)); # "MCMLXVIII" # print (value of roman ("MCMLXXIII")) #1973# ENDalgol68g-2.8/test-set/a68g.mc.144.simp09.a680000644000175000001440000000210512224301261014574 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp09# BEGIN # "In situ" permutation# PROC permvec = (REF [] INT vec, [] INT p) VOID: FOR j TO UPB p DO INT k := p[j]; WHILE k > j DO k := p[k] OD; IF k = j THEN INT h = vec[j], INT l := p[k]; WHILE l NE j DO vec[k] := vec[l]; k := l; l := p[k] OD; vec[k] := h FI OD, [1 : 5] INT x := (4, 5, 1, 3, 2); print (("Output: 1 2 3 4 5 ", newline)); print ((permvec (x, (3, 5, 4, 1, 2)); x)) ENDalgol68g-2.8/test-set/a68g.mc.102.numr06.a680000644000175000001440000000702512224301251014601 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr06# BEGIN # Vector calculus # MODE VEC = [1 : 1] REAL; OP * = (REAL a, VEC b) VEC: ([1 : UPB b] REAL c; FOR i TO UPB b DO c[i] := a * b[i] OD; c), OP * = (VEC a, b) REAL: (REAL s := 0; FOR i TO UPB a DO s +:= a[i] * b[i] OD; s), OP + = (VEC a, b) VEC: ([1 : UPB b] REAL c; FOR i TO UPB a DO c[i] := a[i] + b[i] OD; c); PROC dec = (REF [, ] REAL a, REF [] INT p) VOID: BEGIN INT n = UPB p; INT pk, REAL max, s, [1 : n] REAL v; FOR i TO n DO v[i] := 1 / sqrt (a[i, ] * a[i, ]) OD; FOR k TO n DO max := 0; pk := k; FOR i FROM k TO n DO a[i, k] -:= a[i, : k - 1] * a[ : k - 1, k]; s := ABS a[i, k] * v[i]; IF s > max THEN pk := i; max := s FI OD; p[k] := pk; IF pk /= k THEN [] REAL h = a[pk, ]; a[pk, ] := a[k, ]; a[k, ] := h; v[pk] := v[k] FI; FOR i FROM k + 1 TO n DO a[k, i] -:= a[k, : k - 1] * a[ : k - 1, i] OD; a[k, k + 1 : # this row may be empty # ] := (1 / a[k, k]) * a[k, k + 1 : ] OD END # end decomposition of 'a' # , PROC sol = ([, ] REAL a, [] INT p, REF [] REAL b) VOID: BEGIN INT n = UPB p; FOR k TO n DO INT pk = p[k], REAL r = b[k]; b[k] := (b[pk] - a[k, : k - 1] * b[ : k - 1]) / a[k, k]; IF pk /= k THEN b[pk] := r FI OD; FOR k FROM n BY -1 TO 1 DO b[k] -:= a[k, k + 1 : ] * b[k + 1 : ] OD END # end of back substitution of solution into 'b' # ; FOR n TO 8 DO [1 : n, 1 : n] REAL a, aa, [1 : n] REAL b, [1 : n] INT piv; print (newline); print (" n ="); print (n); print (newline); FOR i TO n DO FOR j TO n DO a[i, j] := aa[i, j] := 1 / (i + j - 1) OD OD; # Hilbert-matrix # FOR i TO n DO b[i] := 2 / 2 ** i OD; dec (a, piv); sol (a, piv, b); FOR i TO n DO print (aa[i, ] * b); print (newline); print (2 / 2 ** i); # these two should approximately be the same # print ((newline, newline)) OD OD ENDalgol68g-2.8/test-set/a68g.mc.016.appl16.a680000644000175000001440000000430512224301220014553 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl16# BEGIN # Sheep in mountain cleft # # See A. van Wijngaarden, Programmacorrectheid en grammatica's, in Mathematical Centre Syllabus 21, XII, 1975. # PROC p = (INT i, j, STRING s) VOID: # i is line number, j is the position of the dot in s; three spaces have been appended to the left and the right of s, in order to simplify the testing # BEGIN print ((newline, i, " ", s[4 : n])); IF s[j - 2 : j] = "><." # h6 # THEN p (i + 1, j - 2, s[ : j - 3] + ".<>" + s[j + 1 : ]) ELIF s[j : j + 2] = ".><" # h7 # THEN p (i + 1, j + 2, s[ : j - 1] + "<>." + s[j + 3 : ]) ELIF s[j - 1 : j + 3] = ">.<><" # h4 # THEN p (i + 1, j - 1, s[ : j - 2] + ".>" + s[j + 1 : ]) ELIF s[j - 3 : j + 1] = "><>.<" # h5 # THEN p (i + 1, j + 1, s[ : j - 1] + "<." + s[j + 2 : ]) ELIF s[j - 1 : j + 1] = ">.<" # h4, h5 # THEN print (newline); p (i + 1, j - 1, s[ : j - 2] + ".>" + s[j + 1 : ]); print (newline); p (i + 1, j + 1, s[ : j - 1] + "<." + s[j + 2 : ]) ELIF s[j - 1 : j] = ">." # h8 # THEN p (i + 1, j - 1, s[ : j - 2] + ".>" + s[j + 1 : ]) ELIF s[j : j + 1] = ".<" THEN p (i + 1, j + 1, s[ : j - 1] + "<." + s[j + 2 : ]) # h9 # FI END # p # ; INT a, b; # read((a, b)); # a := 3; b := 3; INT n = a + b + 7; IF a >= 0 AND b >= 0 THEN p (1, a + 4, " " + a * ">" + "." + b * "<" + " ") FI ENDalgol68g-2.8/test-set/a68g.mc.030.coer02.a680000644000175000001440000000141712224301223014542 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer02# BEGIN # Widening # FOR i TO 2 DO print( CASE i IN TRUE, 2r1 OUT []BOOL(TRUE) ESAC [CASE i IN 1 , bits_width OUT SKIP ESAC] ) OD; # TT # print(newline); FOR n TO 3 DO print((re OF CASE n IN 1, 2.0, 3 I 5 ESAC, im OF CASE n IN 1, 2.0, 3 I 5 ESAC)) OD # 1.0 0.0, 2.0 0.0, 3.0 5.0 # END algol68g-2.8/test-set/a68g.mc.021.clau02.a680000644000175000001440000000137512224301221014537 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #clau02# BEGIN # Case conformity # MODE M = UNION ([]INT, BOOL, STRING); PROC prpm = REF PROC M: HEAP PROC M:= M : "aap "; FOR n TO 4 DO CASE CASE n IN TRUE, IF FALSE THEN "aa" ELSE "b " FI, prpm OUT LOC[1:1]INT:=1 ESAC IN (UNION(STRING, BOOL) sb): print(("sb ", sb)), ([]INT i): print(("i ", i)) OUT print("void") ESAC OD # sb TRUE sb b sb aap i 1 # END algol68g-2.8/test-set/a68g.ur.185.r541c.a680000644000175000001440000006647712224301302014367 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r541a # (print (("routine texts without parameters", newline)); INT vf = 47 * 10 + 45; INT ctr := 0, ctrt := 0, ctrloc; PROC ctrl = (INT inc) VOID: (ctr /= ctrloc + inc | print (("count er in test", ctrt, ctr, ctrloc + inc, newline))); # servitudes pour les corps de routines # OP MON = (REAL a) REAL: (ctr +:= 1; 3.14), = = (BOOL a, INT b) INT: (a | b | ctr -:= 1), UNION (INT, BOOL) vu, MODE STRA = STRUCT (INT de, REF INT of), [, ] INT ta = 1, PROC pra = (UNION (INT, BOOL) a) INT: (a | (INT x): (ctr +:= 1; x)), INT ida = 1; MODE STRB = STRUCT (BOOL de, REF INT of), [, ] BOOL tb = TRUE, PROC prb = (UNION (INT, BOOL) a) BOOL: (a | (BOOL x): (ctr +:= 1; x)), BOOL idb = TRUE; # mode rendu : PROC INT # (MODE R = PROC INT; PROC test = (R proc) VOID: IF proc = 1 THEN ctr +:= 1 ELSE print (("er", ctrt, ctr - ctrloc, newline)) FI; OP ?=:= = (R x) R: (test (x); x); (ctrt := 1; ctrloc := ctr; test (INT: LOC INT := (ctr +:= 1; 1)); FOR ident FROM INT: LOC INT := (ctr +:= 1; 1) BY INT: LOC INT := (ctr +:= 1; 1) TO INT: LOC INT := (ctr +:= 1; 1) WHILE BOOL: LOC BOOL := (ctr +:= 1; TRUE) DO [INT: LOC INT := (ctr +:= 1; 1) : 4, -1 : INT: LOC INT := (ctr +:= 1; 1)] R ent; ent[INT: LOC INT := (ctr +:= 1; 1), 0] := ent[1, INT: LOC INT := (ctr +:= 1; 1)] := INT: LOC INT := (ctr +:= 1; 1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: LOC INT := (ctr +:= 1; 1); REAL e = 0.12345; INT: LOC INT := (ctr +:= 1; 1)); test (par); alfa := ?=:=(INT: LOC INT := (ctr +:= 1; 1)); R ident = INT: LOC INT := (ctr +:= 1; 1), R loc := CASE INT: LOC INT := (ctr +:= 1; 1) IN INT: LOC INT := (ctr +:= 1; 1), SKIP ESAC, tas := INT: LOC INT := (ctr +:= 1; 1); test (ident); test (loc); test (tas); PROC proc = R: INT: LOC INT := (ctr +:= 1; 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: LOC INT := (ctr +:= 1; 1), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: LOC INT := (ctr +:= 1; 1), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: LOC INT := (ctr +:= 1; 1)); UNION (R, CHAR) union := pr (proc, INT: LOC INT := (ctr +:= 1; 1), proc); test ((union | (R a): a)); (test (R BEGIN INT: LOC INT := (ctr +:= 1; 1) END), ?=:=(union; BOOL: LOC BOOL := (ctr +:= 1; TRUE) | INT: LOC INT := (ctr +:= 1; 1)), INT: LOC INT := (ctr +:= 1; 1), test ((BOOL bool = FALSE; union | (R): INT: LOC INT := (ctr +:= 1; 1), (CHAR car): SKIP))); ctrl (47)); (ctrt := 2; ctrloc := ctr; test (INT: INT: (ctr +:= 1; 1)); FOR ident FROM INT: INT: (ctr +:= 1; 1) BY INT: INT: (ctr +:= 1; 1) TO INT: INT: (ctr +:= 1; 1) WHILE BOOL: BOOL: (ctr +:= 1; TRUE) DO [INT: INT: (ctr +:= 1; 1) : 4, -1 : INT: INT: (ctr +:= 1; 1)] R ent; ent[INT: INT: (ctr +:= 1; 1), 0] := ent[1, INT: INT: (ctr +:= 1; 1)] := INT: INT: (ctr +:= 1; 1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: INT: (ctr +:= 1; 1); REAL e = 0.12345; INT: INT: (ctr +:= 1; 1)); test (par); alfa := ?=:=(INT: INT: (ctr +:= 1; 1)); R ident = INT: INT: (ctr +:= 1; 1), R loc := CASE INT: INT: (ctr +:= 1; 1) IN INT: INT: (ctr +:= 1; 1), SKIP ESAC, tas := INT: INT: (ctr +:= 1; 1); test (ident); test (loc); test (tas); PROC proc = R: INT: INT: (ctr +:= 1; 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: INT: (ctr +:= 1; 1), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: INT: (ctr +:= 1; 1), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: INT: (ctr +:= 1; 1)); UNION (R, CHAR) union := pr (proc, INT: INT: (ctr +:= 1; 1), proc); test ((union | (R a): a)); (test (R BEGIN INT: INT: (ctr +:= 1; 1) END), ?=:=(union; BOOL: BOOL: (ctr +:= 1; TRUE) | INT: INT: (ctr +:= 1; 1)), INT: INT: (ctr +:= 1; 1), test ((BOOL bool = FALSE; union | (R): INT: INT: (ctr +:= 1; 1), (CHAR car): SKIP))); ctrl (47)); (ctrt := 3; ctrloc := ctr; test (INT: 3.14 = MON 0.5 = 1); FOR ident FROM INT: 3.14 = MON 0.5 = 1 BY INT: 3.14 = MON 0.5 = 1 TO INT: 3.14 = MON 0.5 = 1 WHILE BOOL: 3.14 = MON 0.5 = TRUE DO [INT: 3.14 = MON 0.5 = 1 : 4, -1 : INT: 3.14 = MON 0.5 = 1] R ent; ent[INT: 3.14 = MON 0.5 = 1, 0] := ent[1, INT: 3.14 = MON 0.5 = 1] := INT: 3.14 = MON 0.5 = 1; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: 3.14 = MON 0.5 = 1; REAL e = 0.12345; INT: 3.14 = MON 0.5 = 1); test (par); alfa := ?=:=(INT: 3.14 = MON 0.5 = 1); R ident = INT: 3.14 = MON 0.5 = 1, R loc := CASE INT: 3.14 = MON 0.5 = 1 IN INT: 3.14 = MON 0.5 = 1, SKIP ESAC, tas := INT: 3.14 = MON 0.5 = 1; test (ident); test (loc); test (tas); PROC proc = R: INT: 3.14 = MON 0.5 = 1, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: 3.14 = MON 0.5 = 1, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: 3.14 = MON 0.5 = 1, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: 3.14 = MON 0.5 = 1); UNION (R, CHAR) union := pr (proc, INT: 3.14 = MON 0.5 = 1, proc); test ((union | (R a): a)); (test (R BEGIN INT: 3.14 = MON 0.5 = 1 END), ?=:=(union; BOOL: 3.14 = MON 0.5 = TRUE | INT: 3.14 = MON 0.5 = 1), INT: 3.14 = MON 0.5 = 1, test ((BOOL bool = FALSE; union | (R): INT: 3.14 = MON 0.5 = 1, (CHAR car): SKIP))); ctrl (47)); (ctrt := 4; ctrloc := ctr; test (INT: de OF STRA (1, ctr +:= 1)); FOR ident FROM INT: de OF STRA (1, ctr +:= 1) BY INT: de OF STRA (1, ctr +:= 1) TO INT: de OF STRA (1, ctr +:= 1) WHILE BOOL: de OF STRB (TRUE, ctr +:= 1) DO [INT: de OF STRA (1, ctr +:= 1) : 4, -1 : INT: de OF STRA (1, ctr +:= 1)] R ent; ent[INT: de OF STRA (1, ctr +:= 1), 0] := ent[1, INT: de OF STRA (1, ctr +:= 1)] := INT: de OF STRA (1, ctr +:= 1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: de OF STRA (1, ctr +:= 1); REAL e = 0.12345; INT: de OF STRA (1, ctr +:= 1)); test (par); alfa := ?=:=(INT: de OF STRA (1, ctr +:= 1)); R ident = INT: de OF STRA (1, ctr +:= 1), R loc := CASE INT: de OF STRA (1, ctr +:= 1) IN INT: de OF STRA (1, ctr +:= 1), SKIP ESAC, tas := INT: de OF STRA (1, ctr +:= 1); test (ident); test (loc); test (tas); PROC proc = R: INT: de OF STRA (1, ctr +:= 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: de OF STRA (1, ctr +:= 1), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: de OF STRA (1, ctr +:= 1), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: de OF STRA (1, ctr +:= 1)); UNION (R, CHAR) union := pr (proc, INT: de OF STRA (1, ctr +:= 1), proc); test ((union | (R a): a)); (test (R BEGIN INT: de OF STRA (1, ctr +:= 1) END), ?=:=(union; BOOL: de OF STRB (TRUE, ctr +:= 1) | INT: de OF STRA (1, ctr +:= 1)), INT: de OF STRA (1, ctr +:= 1), test ((BOOL bool = FALSE; union | (R): INT: de OF STRA (1, ctr +:= 1), (CHAR car): SKIP))); ctrl (47)); (ctrt := 5; ctrloc := ctr; test (INT: ta[ida, (ctr +:= 1; 1)]); FOR ident FROM INT: ta[ida, (ctr +:= 1; 1)] BY INT: ta[ida, (ctr +:= 1; 1)] TO INT: ta[ida, (ctr +:= 1; 1)] WHILE BOOL: tb[ida, (ctr +:= 1; 1)] DO [INT: ta[ida, (ctr +:= 1; 1)] : 4, -1 : INT: ta[ida, (ctr +:= 1; 1)]] R ent; ent[INT: ta[ida, (ctr +:= 1; 1)], 0] := ent[1, INT: ta[ida, (ctr +:= 1; 1)]] := INT: ta[ida, (ctr +:= 1; 1)]; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: ta[ida, (ctr +:= 1; 1)]; REAL e = 0.12345; INT: ta[ida, (ctr +:= 1; 1)]); test (par); alfa := ?=:=(INT: ta[ida, (ctr +:= 1; 1)]); R ident = INT: ta[ida, (ctr +:= 1; 1)], R loc := CASE INT: ta[ida, (ctr +:= 1; 1)] IN INT: ta[ida, (ctr +:= 1; 1)], SKIP ESAC, tas := INT: ta[ida, (ctr +:= 1; 1)]; test (ident); test (loc); test (tas); PROC proc = R: INT: ta[ida, (ctr +:= 1; 1)], STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: ta[ida, (ctr +:= 1; 1)], (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: ta[ida, (ctr +:= 1; 1)], proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: ta[ida, (ctr +:= 1; 1)]); UNION (R, CHAR) union := pr (proc, INT: ta[ida, (ctr +:= 1; 1)], proc); test ((union | (R a): a)); (test (R BEGIN INT: ta[ida, (ctr +:= 1; 1)] END), ?=:=(union; BOOL: tb[ida, (ctr +:= 1; 1)] | INT: ta[ida, (ctr +:= 1; 1)]), INT: ta[ida, (ctr +:= 1; 1)], test ((BOOL bool = FALSE; union | (R): INT: ta[ida, (ctr +:= 1; 1)], (CHAR car): SKIP))); ctrl (47)); (ctrt := 6; ctrloc := ctr; test (INT: pra (1)); FOR ident FROM INT: pra (1) BY INT: pra (1) TO INT: pra (1) WHILE BOOL: prb (TRUE) DO [INT: pra (1) : 4, -1 : INT: pra (1)] R ent; ent[INT: pra (1), 0] := ent[1, INT: pra (1)] := INT: pra (1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: pra (1); REAL e = 0.12345; INT: pra (1)); test (par); alfa := ?=:=(INT: pra (1)); R ident = INT: pra (1), R loc := CASE INT: pra (1) IN INT: pra (1), SKIP ESAC, tas := INT: pra (1); test (ident); test (loc); test (tas); PROC proc = R: INT: pra (1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: pra (1), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: pra (1), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: pra (1)); UNION (R, CHAR) union := pr (proc, INT: pra (1), proc); test ((union | (R a): a)); (test (R BEGIN INT: pra (1) END), ?=:=(union; BOOL: prb (TRUE) | INT: pra (1)), INT: pra (1), test ((BOOL bool = FALSE; union | (R): INT: pra (1), (CHAR car): SKIP))); ctrl (47)); (ctrt := 7; ctrloc := ctr; test (INT: INT (ctr +:= 1; ida | 1, SKIP)); FOR ident FROM INT: INT (ctr +:= 1; ida | 1, SKIP) BY INT: INT (ctr +:= 1; ida | 1, SKIP) TO INT: INT (ctr +:= 1; ida | 1, SKIP) WHILE BOOL: BOOL (ctr +:= 1; ida | TRUE, SKIP) DO [INT: INT (ctr +:= 1; ida | 1, SKIP) : 4, -1 : INT: INT (ctr +:= 1; ida | 1, SKIP)] R ent; ent[INT: INT (ctr +:= 1; ida | 1, SKIP), 0] := ent[1, INT: INT (ctr +:= 1; ida | 1, SKIP)] := INT: INT (ctr +:= 1; ida | 1, SKIP); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: INT (ctr +:= 1; ida | 1, SKIP); REAL e = 0.12345; INT: INT (ctr +:= 1; ida | 1, SKIP)); test (par); alfa := ?=:=(INT: INT (ctr +:= 1; ida | 1, SKIP)); R ident = INT: INT (ctr +:= 1; ida | 1, SKIP), R loc := CASE INT: INT (ctr +:= 1; ida | 1, SKIP) IN INT: INT (ctr +:= 1; ida | 1, SKIP), SKIP ESAC, tas := INT: INT (ctr +:= 1; ida | 1, SKIP); test (ident); test (loc); test (tas); PROC proc = R: INT: INT (ctr +:= 1; ida | 1, SKIP), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: INT (ctr +:= 1; ida | 1, SKIP), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: INT (ctr +:= 1; ida | 1, SKIP), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: INT (ctr +:= 1; ida | 1, SKIP)); UNION (R, CHAR) union := pr (proc, INT: INT (ctr +:= 1; ida | 1, SKIP), proc); test ((union | (R a): a)); (test (R BEGIN INT: INT (ctr +:= 1; ida | 1, SKIP) END), ?=:=(union; BOOL: BOOL (ctr +:= 1; ida | TRUE, SKIP) | INT: INT (ctr +:= 1; ida | 1, SKIP)), INT: INT (ctr +:= 1; ida | 1, SKIP), test ((BOOL bool = FALSE; union | (R): INT: INT (ctr +:= 1; ida | 1, SKIP), (CHAR car): SKIP))); ctrl (47)); (ctrt := 8; ctrloc := ctr; test (INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END); FOR ident FROM INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END BY INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END TO INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END WHILE BOOL: BEGIN INT x; ctr +:= 1; e: TRUE EXIT f: SKIP END DO [INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END : 4, -1 : INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END] R ent; ent[INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, 0] := ent[1, INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END] := INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END; REAL e = 0.12345; INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END); test (par); alfa := ?=:=(INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END); R ident = INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, R loc := CASE INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END IN INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, SKIP ESAC, tas := INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END; test (ident); test (loc); test (tas); PROC proc = R: INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END); UNION (R, CHAR) union := pr (proc, INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, proc); test ((union | (R a): a)); (test (R BEGIN INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END END), ?=:=(union; BOOL: BEGIN INT x; ctr +:= 1; e: TRUE EXIT f: SKIP END | INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END), INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, test ((BOOL bool = FALSE; union | (R): INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, (CHAR car): SKIP))); ctrl (47)); (ctrt := 9; ctrloc := ctr; test (INT: (NOT idb | SKIP | ctr +:= 1; ida)); FOR ident FROM INT: (NOT idb | SKIP | ctr +:= 1; ida) BY INT: (NOT idb | SKIP | ctr +:= 1; ida) TO INT: (NOT idb | SKIP | ctr +:= 1; ida) WHILE BOOL: (NOT idb | SKIP | ctr +:= 1; idb) DO [INT: (NOT idb | SKIP | ctr +:= 1; ida) : 4, -1 : INT: (NOT idb | SKIP | ctr +:= 1; ida)] R ent; ent[INT: (NOT idb | SKIP | ctr +:= 1; ida), 0] := ent[1, INT: (NOT idb | SKIP | ctr +:= 1; ida)] := INT: (NOT idb | SKIP | ctr +:= 1; ida); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: (NOT idb | SKIP | ctr +:= 1; ida); REAL e = 0.12345; INT: (NOT idb | SKIP | ctr +:= 1; ida)); test (par); alfa := ?=:=(INT: (NOT idb | SKIP | ctr +:= 1; ida)); R ident = INT: (NOT idb | SKIP | ctr +:= 1; ida), R loc := CASE INT: (NOT idb | SKIP | ctr +:= 1; ida) IN INT: (NOT idb | SKIP | ctr +:= 1; ida), SKIP ESAC, tas := INT: (NOT idb | SKIP | ctr +:= 1; ida); test (ident); test (loc); test (tas); PROC proc = R: INT: (NOT idb | SKIP | ctr +:= 1; ida), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: (NOT idb | SKIP | ctr +:= 1; ida), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: (NOT idb | SKIP | ctr +:= 1; ida), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: (NOT idb | SKIP | ctr +:= 1; ida)); UNION (R, CHAR) union := pr (proc, INT: (NOT idb | SKIP | ctr +:= 1; ida), proc); test ((union | (R a): a)); (test (R BEGIN INT: (NOT idb | SKIP | ctr +:= 1; ida) END), ?=:=(union; BOOL: (NOT idb | SKIP | ctr +:= 1; idb) | INT: (NOT idb | SKIP | ctr +:= 1; ida)), INT: (NOT idb | SKIP | ctr +:= 1; ida), test ((BOOL bool = FALSE; union | (R): INT: (NOT idb | SKIP | ctr +:= 1; ida), (CHAR car): SKIP))); ctrl (47)); (ctrt := 10; ctrloc := ctr; test (INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); FOR ident FROM INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC BY INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC TO INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC WHILE BOOL: CASE vu := (ctr +:= 1; TRUE) IN (BOOL x): x ESAC DO [INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC : 4, -1 : INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC] R ent; ent[INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, 0] := ent[1, INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC] := INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC; REAL e = 0.12345; INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); test (par); alfa := ?=:=(INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); R ident = INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, R loc := CASE INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC IN INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, SKIP ESAC, tas := INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC; test (ident); test (loc); test (tas); PROC proc = R: INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); UNION (R, CHAR) union := pr (proc, INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, proc); test ((union | (R a): a)); (test (R BEGIN INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC END), ?=:=(union; BOOL: CASE vu := (ctr +:= 1; TRUE) IN (BOOL x): x ESAC | INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC), INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, test ((BOOL bool = FALSE; union | (R): INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, (CHAR car): SKIP))); ctrl (47)); SKIP); # mode rendu : INT # (MODE R = INT; PROC test = (R proc) VOID: IF proc = 1 THEN ctr +:= 1 ELSE print (("er", ctrt, ctr - ctrloc, newline)) FI; OP ?=:= = (R x) R: (test (x); x); (ctrt := 11; ctrloc := ctr; test (INT: LOC INT := (ctr +:= 1; 1)); FOR ident FROM INT: INT: (ctr +:= 1; 1) BY INT: pra (1) TO INT: ta[ida, (ctr +:= 1; 1)] WHILE BOOL: tb[ida, (ctr +:= 1; 1)] DO [INT: de OF STRA (1, ctr +:= 1) : 4, -1 : INT: LOC INT := (ctr +:= 1; 1)] R ent; ent[INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, 0] := ent[1, INT: INT: (ctr +:= 1; 1)] := INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: LOC INT := (ctr +:= 1; 1); REAL e = 0.12345; INT: INT (ctr +:= 1; ida | 1, SKIP)); test (par); alfa := ?=:=(INT: INT: (ctr +:= 1; 1)); R ident = INT: INT (ctr +:= 1; ida | 1, SKIP), R loc := CASE INT: de OF STRA (1, ctr +:= 1) IN INT: ta[ida, (ctr +:= 1; 1)], SKIP ESAC, tas := INT: pra (1); test (ident); test (loc); test (tas); PROC proc = R: INT: INT: (ctr +:= 1; 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: (NOT idb | SKIP | ctr +:= 1; ida), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: INT (ctr +:= 1; ida | 1, SKIP)); UNION (R, CHAR) union := pr (proc, INT: INT (ctr +:= 1; ida | 1, SKIP), proc); test ((union | (R a): a)); (test (R BEGIN INT: pra (1) END), ?=:=(union; BOOL: prb (TRUE) | INT: pra (1)), INT: de OF STRA (1, ctr +:= 1), test ((BOOL bool = FALSE; union | (R): INT: de OF STRA (1, ctr +:= 1), (CHAR car): SKIP))); ctrl (45)); SKIP); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.147.simp12.a680000644000175000001440000000142512224301261014575 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp12# # Towers of Hanoi, Report 11.13. # FOR k TO 8 DO FILE f := stand out; PROC p = (INT me, de, ma) VOID: IF ma > 0 THEN p (me, 6 - me - de, ma - 1); putf (f, (me, de, ma)); # move from peg 'me' to peg 'de' piece 'ma' # p (6 - me - de, de, ma - 1) FI; putf (f, ($l"k = "dl, n((2 ** k + 15) % 16)(2(2(4(3(d)x)x)x)l)$, k)); p (1, 2, k) ODalgol68g-2.8/test-set/a68g.mc.170.stow07.a680000644000175000001440000000505612224301274014631 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #stow07# BEGIN # Test + and = on strings # PROC equal = (STRING a, b) BOOL: (INT p = UPB a - LWB a + 1, q = UPB b - LWB b + 1; INT r = (p > 0 | p | 0), s = (q > 0 | q | 0); IF r /= s THEN FALSE ELSE BOOL c := TRUE; INT la = LWB a - 1, lb = LWB b - 1; FOR i TO r WHILE c := a[i + la] = b[i + lb] DO SKIP OD; c FI); PROC concat = (STRING a, b) STRING: (INT p = UPB a - LWB a + 1, q = UPB b - LWB b + 1; INT r = (p > 0 | p | 0), s = (q > 0 | q | 0); [r + s] CHAR c; (c[1 : p@LWB a] := a, c[r + 1 : r + q@LWB b] := b); c); print (("This program should print a 25 * 25 block of stars.", newline, newline)); FOR lwb a FROM -2 TO 2 DO FOR sze a FROM -2 TO 2 DO print (newline); FOR lwb b FROM -2 TO 2 DO FOR sze b FROM -2 TO 2 DO STRING a = "1a"[1 : sze a@lwb a], b = "1b"[1 : sze b@lwb b]; print ("*"); # to estimate progress # # test = # IF (a = b) = equal (a, b) THEN SKIP ELSE print ((newline, "Error in string comparison: ", "should be ", (equal (a, b) | "" | "un"), "equal", ", are ", (a = b | "" | "un"), "equal")); GOTO bad FI; # test + # IF a + b = concat (a, b) THEN SKIP ELSE print ((newline, "Error in string concatenation: ", "should be """, concat (a, b), """, is """, a + b, """")); GOTO bad FI EXIT bad: print ((newline, " first string is """, a, """, lwb=", whole (LWB a, 4), ", upb =", whole (UPB a, 4), ", second string is """, b, """, lwb=", whole (LWB b, 4), ", upb =", whole (UPB b, 4), newline)) OD OD OD OD ENDalgol68g-2.8/test-set/a68g.mc.004.appl04.a680000644000175000001440000000314412224301215014551 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl04# BEGIN # 1. Sets in ALGOL 68; 2. Pebble problem of E.W. Dijkstra # MODE RED = REF STRUCT (RED red), WHITE = REF STRUCT (WHITE white), BLUE = REF STRUCT (BLUE blue); MODE STONE = UNION (RED, WHITE, BLUE); PROC sort = (REF [] STONE st) VOID: (INT pr := 1, pw := 1, pb := UPB st; PRIO EXCH = 1; OP EXCH = (REF STONE a, b) VOID: (STONE c = b; b := a; a := c); TO UPB st DO CASE st[pw] IN (RED): (st[pr] EXCH st[pw]; pr +:= 1; pw +:= 1), (WHITE): pw +:= 1, (BLUE): (st[pw] EXCH st[pb]; pb -:= 1) ESAC OD); OP PRINT = (REF [] STONE st) VOID: (print (newline); FOR i TO UPB st DO print ((st[i] | (RED): "r", (WHITE): "w", (BLUE): "b")) OD); INT n = 20; [1 : n] STONE stone; FOR i TO UPB stone DO stone[i] := (ENTIER (random * 3) + 1 | RED (NIL), WHITE (NIL), BLUE (NIL)) OD; PRINT stone; sort (stone); PRINT stone ENDalgol68g-2.8/test-set/a68g.mc.081.mdeq06.a680000644000175000001440000000166412224301232014556 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #mdeq06# BEGIN # Some equivalencing # MODE A = STRUCT(REF A l, REF A r), B = STRUCT(REF B l, REF B r), C = STRUCT(REF D l, REF E r), D = STRUCT(REF E l, REF C r), E = STRUCT(REF C l, REF D r), F = STRUCT(REF STRUCT(REF A l, REF B r) l, REF STRUCT (REF STRUCT(REF C l, REF D r) l, REF STRUCT(REF E l, REF F r) r ) r ); MODE M = UNION(A, B, C, D, E, F); # error, all modes are the same # SKIP END algol68g-2.8/test-set/a68g.mc.045.decl04.a680000644000175000001440000000071612224301224014533 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #decl04# (MODE U = UNION (INT, REAL); LOC UNION (U) # no list needed # u := 1; print (u))algol68g-2.8/test-set/a68g.mc.119.oper10.a680000644000175000001440000001200012224301254014560 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper10# BEGIN # Dyadic operators, non-bold monads # INT decls := 0; # the first declaration is different to avoid a recursive loop # OP + = (INT a, b) INT: (INT c := a; c PLUSAB b); decls PLUSAB 1; OP +< = (INT a, b) INT: a + b; decls PLUSAB 1; OP +> = (INT a, b) INT: a + b; decls PLUSAB 1; OP +/ = (INT a, b) INT: a + b; decls PLUSAB 1; OP += = (INT a, b) INT: a + b; decls PLUSAB 1; OP +* = (INT a, b) INT: a + b; decls PLUSAB 1; OP +:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP +<:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP +>:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP +/:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP +=:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP +*:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP +=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP +<=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP +>=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP +/=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP +==: = (INT a, b) INT: a + b; decls PLUSAB 1; OP +*=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP - = (INT a, b) INT: a + b; decls PLUSAB 1; OP -< = (INT a, b) INT: a + b; decls PLUSAB 1; OP -> = (INT a, b) INT: a + b; decls PLUSAB 1; OP -/ = (INT a, b) INT: a + b; decls PLUSAB 1; OP -= = (INT a, b) INT: a + b; decls PLUSAB 1; OP -* = (INT a, b) INT: a + b; decls PLUSAB 1; OP -:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP -<:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP ->:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP -/:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP -=:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP -*:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP -=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP -<=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP ->=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP -/=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP -==: = (INT a, b) INT: a + b; decls PLUSAB 1; OP -*=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP % = (INT a, b) INT: a + b; decls PLUSAB 1; OP %< = (INT a, b) INT: a + b; decls PLUSAB 1; OP %> = (INT a, b) INT: a + b; decls PLUSAB 1; OP %/ = (INT a, b) INT: a + b; decls PLUSAB 1; OP %= = (INT a, b) INT: a + b; decls PLUSAB 1; OP %* = (INT a, b) INT: a + b; decls PLUSAB 1; OP %:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP %<:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP %>:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP %/:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP %=:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP %*:= = (INT a, b) INT: a + b; decls PLUSAB 1; OP %=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP %<=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP %>=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP %/=: = (INT a, b) INT: a + b; decls PLUSAB 1; OP %==: = (INT a, b) INT: a + b; decls PLUSAB 1; OP %*=: = (INT a, b) INT: a + b; decls PLUSAB 1; PRIO + = 1, +< = 1, +> = 1, +/ = 1, += = 1, +* = 1, +:= = 1, +<:= = 1, +>:= = 1, +/:= = 1, +=:= = 1, +*:= = 1, +=: = 1, +<=: = 1, +>=: = 1, +/=: = 1, +==: = 1, +*=: = 1, - = 1, -< = 1, -> = 1, -/ = 1, -= = 1, -* = 1, -:= = 1, -<:= = 1, ->:= = 1, -/:= = 1, -=:= = 1, -*:= = 1, -=: = 1, -<=: = 1, ->=: = 1, -/=: = 1, -==: = 1, -*=: = 1, % = 1, %< = 1, %> = 1, %/ = 1, %= = 1, %* = 1, %:= = 1, %<:= = 1, %>:= = 1, %/:= = 1, %=:= = 1, %*:= = 1, %=: = 1, %<=: = 1, %>=: = 1, %/=: = 1, %==: = 1, %*=: = 1; print (("Should print two equal integers (number of non-bold monads)", newline, 0 + 1 +< 1 +> 1 +/ 1 += 1 +* 1 +:= 1 +<:= 1 +>:= 1 +/:= 1 +=:= 1 +*:= 1 +=: 1 +<=: 1 +>=: 1 +/=: 1 +==: 1 +*=: 1 - 1 -< 1 -> 1 -/ 1 -= 1 -* 1 -:= 1 -<:= 1 ->:= 1 -/:= 1 -=:= 1 -*:= 1 -=: 1 -<=: 1 ->=: 1 -/=: 1 -==: 1 -*=: 1 % 1 %< 1 %> 1 %/ 1 %= 1 %* 1 %:= 1 %<:= 1 %>:= 1 %/:= 1 %=:= 1 %*:= 1 %=: 1 %<=: 1 %>=: 1 %/=: 1 %==: 1 %*=: 1, decls)) ENDalgol68g-2.8/test-set/a68g.mc.001.appl01.a680000644000175000001440000000227412224301215014546 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl01# BEGIN # ALGOL 68 program, TJD 730705. Calculates all increasing sequences adding up to a given integer from 1 to 10 # [1 : 4] INT a; PROC print solution = (INT p) VOID: print ((a[1 : p], newline)); PROC build up = (INT p, rest) VOID: IF rest = 0 THEN print solution (p) ELSE FOR k FROM (p = 0 | 1 | a[p] + 1) TO rest DO (a[p + 1] := k; build up (p + 1, rest - k)) OD FI; FOR g TO 10 DO print ((newline, g, " =", newline)); build up (0, g) OD # For an ALGOL 60 program yielding the same output see Th.J. Dekker, Syllabus Informatica, Instituut voor Toepassingen van de Wiskunde, Universiteit van Amsterdam, 1972, page 81 - 82 # ENDalgol68g-2.8/test-set/a68g.ur.191.r6e.a680000644000175000001440000004417112224301307014212 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r6e # (print (("coercions in soft context", newline)); INT vf = 330; INT ctrt := 0, ctr := 0; MODE MODEREP = REF UNION (INT, COMPL); # procedure de controle # BOOL active := TRUE; PROC c = (UNION (REF PROC INT, REF REF COMPL, REF PROC [] UNION (INT, COMPL), MODEREP) par) VOID: ctr +:= (par | (REF PROC INT p): (active := FALSE; INT x = p; active := TRUE; x), (REF REF COMPL): 5, (REF PROC [] UNION (INT, COMPL)): 7, (MODEREP): 11 | print (("erreur mode", ctrt, newline)); 0); # instructions de servitude generales # PROC pe = INT: (active | print ("activation pe"); 0 | 3); PROC INT rpe := pe; HEAP COMPL rc; REF COMPL rrc := rc; UNION (INT, COMPL) ru := 1 I 0; PROC rpru := [] UNION (INT, COMPL): (print ("activation pru"); 1); BEGIN # servitudes pour unites du mode PROC PROC REF PROC INT # PROC PROC REF PROC INT ident = PROC REF PROC INT: REF PROC INT: rpe; OP &=: = (BOOL a, PROC PROC REF PROC INT b) PROC PROC REF PROC INT: (a | b), PRIO &=: = 9, STRUCT (PROC PROC REF PROC INT de, of) de = (ident, SKIP); [] PROC PROC REF PROC INT rang = ident, PROC pav = (PROC PROC REF PROC INT x) PROC PROC REF PROC INT: x; # contextes # ctrt := 1; c ((PROC REF PROC INT: REF PROC INT: rpe) := ((PROC REF PROC INT: REF PROC INT: rpe) := (PROC REF PROC INT: REF PROC INT: rpe) := (PROC REF PROC INT: REF PROC INT: rpe) := pe)); (((PROC REF PROC INT: REF PROC INT: rpe) :/=: NIL) AND (rpe :=: (PROC REF PROC INT: REF PROC INT: rpe)) | ctr +:= 1); ctrt := 2; c (NOT FALSE &=: ident := (NOT FALSE &=: ident := NOT FALSE &=: ident := NOT FALSE &=: ident := pe)); ((NOT FALSE &=: ident :/=: NIL) AND (rpe :=: NOT FALSE &=: ident) | ctr +:= 1); ctrt := 3; c (de OF de := (de OF de := de OF de := de OF de := pe)); ((de OF de :/=: NIL) AND (rpe :=: de OF de) | ctr +:= 1); ctrt := 4; c (rang[1] := (rang[1] := rang[1] := rang[1] := pe)); ((rang[1] :/=: NIL) AND (rpe :=: rang[1]) | ctr +:= 1); ctrt := 5; c (pav (ident) := (pav (ident) := pav (ident) := pav (ident) := pe)); ((pav (ident) :/=: NIL) AND (rpe :=: pav (ident)) | ctr +:= 1); ctrt := 6; c (PROC PROC REF PROC INT BEGIN ident END := (PROC PROC REF PROC INT BEGIN ident END := PROC PROC REF PROC INT BEGIN ident END := PROC PROC REF PROC INT BEGIN ident END := pe)); ((PROC PROC REF PROC INT BEGIN ident END :/=: NIL) AND (rpe :=: PROC PROC REF PROC INT BEGIN ident END) | ctr +:= 1); ctrt := 7; c (ident := (ident := ident := ident := pe)); ((ident :/=: NIL) AND (rpe :=: ident) | ctr +:= 1); ctrt := 8; c (BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := (BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := pe)); ((BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END :/=: NIL) AND (rpe :=: BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END) | ctr +:= 1); ctrt := 9; c ((TRUE | SKIP; ident) := ((TRUE | SKIP; ident) := (TRUE | SKIP; ident) := (TRUE | SKIP; ident) := pe)); (((TRUE | SKIP; ident) :/=: NIL) AND (rpe :=: (TRUE | SKIP; ident)) | ctr +:= 1); ctrt := 10; c (CASE -2 IN SKIP, ident OUT ident ESAC := (CASE -2 IN SKIP, ident OUT ident ESAC := CASE -2 IN SKIP, ident OUT ident ESAC := CASE -2 IN SKIP, ident OUT ident ESAC := pe)); ((CASE -2 IN SKIP, ident OUT ident ESAC :/=: NIL) AND (rpe :=: CASE -2 IN SKIP, ident OUT ident ESAC) | ctr +:= 1); ctrt := 11; c ((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := ((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := pe)); (((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) :/=: NIL) AND (rpe :=: (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident)) | ctr +:= 1); SKIP END; BEGIN # servitudes pour unites du mode PROC REF REF COMPL # PROC REF REF COMPL ident = REF REF COMPL: rrc; OP &=: = (BOOL a, PROC REF REF COMPL b) PROC REF REF COMPL: (a | b), PRIO &=: = 9, STRUCT (PROC REF REF COMPL de, of) de = (ident, SKIP); [] PROC REF REF COMPL rang = ident, PROC pav = (PROC REF REF COMPL x) PROC REF REF COMPL: x; # contextes # ctrt := 12; c ((REF REF COMPL: rrc) := ((REF REF COMPL: rrc) := (REF REF COMPL: rrc) := (REF REF COMPL: rrc) := rc)); (((REF REF COMPL: rrc) :/=: NIL) AND (rrc :=: (REF REF COMPL: rrc)) | ctr +:= 1); ctrt := 13; c (NOT FALSE &=: ident := (NOT FALSE &=: ident := NOT FALSE &=: ident := NOT FALSE &=: ident := rc)); ((NOT FALSE &=: ident :/=: NIL) AND (rrc :=: NOT FALSE &=: ident) | ctr +:= 1); ctrt := 14; c (de OF de := (de OF de := de OF de := de OF de := rc)); ((de OF de :/=: NIL) AND (rrc :=: de OF de) | ctr +:= 1); ctrt := 15; c (rang[1] := (rang[1] := rang[1] := rang[1] := rc)); ((rang[1] :/=: NIL) AND (rrc :=: rang[1]) | ctr +:= 1); ctrt := 16; c (pav (ident) := (pav (ident) := pav (ident) := pav (ident) := rc)); ((pav (ident) :/=: NIL) AND (rrc :=: pav (ident)) | ctr +:= 1); ctrt := 17; c (PROC REF REF COMPL BEGIN ident END := (PROC REF REF COMPL BEGIN ident END := PROC REF REF COMPL BEGIN ident END := PROC REF REF COMPL BEGIN ident END := rc)); ((PROC REF REF COMPL BEGIN ident END :/=: NIL) AND (rrc :=: PROC REF REF COMPL BEGIN ident END) | ctr +:= 1); ctrt := 18; c (ident := (ident := ident := ident := rc)); ((ident :/=: NIL) AND (rrc :=: ident) | ctr +:= 1); ctrt := 19; c (BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := (BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := rc)); ((BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END :/=: NIL) AND (rrc :=: BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END) | ctr +:= 1); ctrt := 20; c ((TRUE | SKIP; ident) := ((TRUE | SKIP; ident) := (TRUE | SKIP; ident) := (TRUE | SKIP; ident) := rc)); (((TRUE | SKIP; ident) :/=: NIL) AND (rrc :=: (TRUE | SKIP; ident)) | ctr +:= 1); ctrt := 21; c (CASE -2 IN SKIP, ident OUT ident ESAC := (CASE -2 IN SKIP, ident OUT ident ESAC := CASE -2 IN SKIP, ident OUT ident ESAC := CASE -2 IN SKIP, ident OUT ident ESAC := rc)); ((CASE -2 IN SKIP, ident OUT ident ESAC :/=: NIL) AND (rrc :=: CASE -2 IN SKIP, ident OUT ident ESAC) | ctr +:= 1); ctrt := 22; c ((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := ((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := rc)); (((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) :/=: NIL) AND (rrc :=: (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident)) | ctr +:= 1); SKIP END; BEGIN # servitudes pour unites du mode PROC PROC PROC REF PROC [] UNION ( INT , COMPL ) # PROC PROC PROC REF PROC [] UNION (INT, COMPL) ident = PROC PROC REF PROC [] UNION (INT, COMPL): PROC REF PROC [] UNION (INT, COMPL): REF PROC [] UNION (INT, COMPL): rpru; OP &=: = (BOOL a, PROC PROC PROC REF PROC [] UNION (INT, COMPL) b) PROC PROC PROC REF PROC [] UNION (INT, COMPL): (a | b), PRIO &=: = 9, STRUCT (PROC PROC PROC REF PROC [] UNION (INT, COMPL) de, of) de = (ident, SKIP); [] PROC PROC PROC REF PROC [] UNION (INT, COMPL) rang = ident, PROC pav = (PROC PROC PROC REF PROC [] UNION (INT, COMPL) x) PROC PROC PROC REF PROC [] UNION (INT, COMPL): x; # contextes # ctrt := 23; c ((PROC PROC REF PROC [] UNION (INT, COMPL): PROC REF PROC [] UNION (INT, COMPL): REF PROC [] UNION (INT, COMPL): rpru) := ((PROC PROC REF PROC [] UNION (INT, COMPL): PROC REF PROC [] UNION (INT, COMPL): REF PROC [] UNION (INT, COMPL): rpru) := (PROC PROC REF PROC [] UNION (INT, COMPL): PROC REF PROC [] UNION (INT, COMPL): REF PROC [] UNION (INT, COMPL): rpru) := (PROC PROC REF PROC [] UNION (INT, COMPL): PROC REF PROC [] UNION (INT, COMPL): REF PROC [] UNION (INT, COMPL): rpru) := rpru)); (((PROC PROC REF PROC [] UNION (INT, COMPL): PROC REF PROC [] UNION (INT, COMPL): REF PROC [] UNION (INT, COMPL): rpru) :/=: NIL) AND (rpru :=: (PROC PROC REF PROC [] UNION (INT, COMPL): PROC REF PROC [] UNION (INT, COMPL): REF PROC [] UNION (INT, COMPL): rpru)) | ctr +:= 1); ctrt := 24; c (NOT FALSE &=: ident := (NOT FALSE &=: ident := NOT FALSE &=: ident := NOT FALSE &=: ident := rpru)); ((NOT FALSE &=: ident :/=: NIL) AND (rpru :=: NOT FALSE &=: ident) | ctr +:= 1); ctrt := 25; c (de OF de := (de OF de := de OF de := de OF de := rpru)); ((de OF de :/=: NIL) AND (rpru :=: de OF de) | ctr +:= 1); ctrt := 26; c (rang[1] := (rang[1] := rang[1] := rang[1] := rpru)); ((rang[1] :/=: NIL) AND (rpru :=: rang[1]) | ctr +:= 1); ctrt := 27; c (pav (ident) := (pav (ident) := pav (ident) := pav (ident) := rpru)); ((pav (ident) :/=: NIL) AND (rpru :=: pav (ident)) | ctr +:= 1); ctrt := 28; c (PROC PROC PROC REF PROC [] UNION (INT, COMPL) BEGIN ident END := (PROC PROC PROC REF PROC [] UNION (INT, COMPL) BEGIN ident END := PROC PROC PROC REF PROC [] UNION (INT, COMPL) BEGIN ident END := PROC PROC PROC REF PROC [] UNION (INT, COMPL) BEGIN ident END := rpru)); ((PROC PROC PROC REF PROC [] UNION (INT, COMPL) BEGIN ident END :/=: NIL) AND (rpru :=: PROC PROC PROC REF PROC [] UNION (INT, COMPL) BEGIN ident END) | ctr +:= 1); ctrt := 29; c (ident := (ident := ident := ident := rpru)); ((ident :/=: NIL) AND (rpru :=: ident) | ctr +:= 1); ctrt := 30; c (BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := (BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := rpru)); ((BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END :/=: NIL) AND (rpru :=: BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END) | ctr +:= 1); ctrt := 31; c ((TRUE | SKIP; ident) := ((TRUE | SKIP; ident) := (TRUE | SKIP; ident) := (TRUE | SKIP; ident) := rpru)); (((TRUE | SKIP; ident) :/=: NIL) AND (rpru :=: (TRUE | SKIP; ident)) | ctr +:= 1); ctrt := 32; c (CASE -2 IN SKIP, ident OUT ident ESAC := (CASE -2 IN SKIP, ident OUT ident ESAC := CASE -2 IN SKIP, ident OUT ident ESAC := CASE -2 IN SKIP, ident OUT ident ESAC := rpru)); ((CASE -2 IN SKIP, ident OUT ident ESAC :/=: NIL) AND (rpru :=: CASE -2 IN SKIP, ident OUT ident ESAC) | ctr +:= 1); ctrt := 33; c ((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := ((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := rpru)); (((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) :/=: NIL) AND (rpru :=: (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident)) | ctr +:= 1); SKIP END; BEGIN # servitudes pour unites du mode PROC PROC MODEREP # PROC PROC MODEREP ident = PROC MODEREP: MODEREP: ru; OP &=: = (BOOL a, PROC PROC MODEREP b) PROC PROC MODEREP: (a | b), PRIO &=: = 9, STRUCT (PROC PROC MODEREP de, of) de = (ident, SKIP); [] PROC PROC MODEREP rang = ident, PROC pav = (PROC PROC MODEREP x) PROC PROC MODEREP: x; # contextes # ctrt := 34; c ((PROC MODEREP: MODEREP: ru) := ((PROC MODEREP: MODEREP: ru) := (PROC MODEREP: MODEREP: ru) := (PROC MODEREP: MODEREP: ru) := 1)); (((PROC MODEREP: MODEREP: ru) :/=: NIL) AND (ru :=: (PROC MODEREP: MODEREP: ru)) | ctr +:= 1); ctrt := 35; c (NOT FALSE &=: ident := (NOT FALSE &=: ident := NOT FALSE &=: ident := NOT FALSE &=: ident := 1)); ((NOT FALSE &=: ident :/=: NIL) AND (ru :=: NOT FALSE &=: ident) | ctr +:= 1); ctrt := 36; c (de OF de := (de OF de := de OF de := de OF de := 1)); ((de OF de :/=: NIL) AND (ru :=: de OF de) | ctr +:= 1); ctrt := 37; c (rang[1] := (rang[1] := rang[1] := rang[1] := 1)); ((rang[1] :/=: NIL) AND (ru :=: rang[1]) | ctr +:= 1); ctrt := 38; c (pav (ident) := (pav (ident) := pav (ident) := pav (ident) := 1)); ((pav (ident) :/=: NIL) AND (ru :=: pav (ident)) | ctr +:= 1); ctrt := 39; c (PROC PROC MODEREP BEGIN ident END := (PROC PROC MODEREP BEGIN ident END := PROC PROC MODEREP BEGIN ident END := PROC PROC MODEREP BEGIN ident END := 1)); ((PROC PROC MODEREP BEGIN ident END :/=: NIL) AND (ru :=: PROC PROC MODEREP BEGIN ident END) | ctr +:= 1); ctrt := 40; c (ident := (ident := ident := ident := 1)); ((ident :/=: NIL) AND (ru :=: ident) | ctr +:= 1); ctrt := 41; c (BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := (BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END := 1)); ((BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END :/=: NIL) AND (ru :=: BEGIN (SKIP; GOTO s) EXIT s: ident EXIT e: SKIP END) | ctr +:= 1); ctrt := 42; c ((TRUE | SKIP; ident) := ((TRUE | SKIP; ident) := (TRUE | SKIP; ident) := (TRUE | SKIP; ident) := 1)); (((TRUE | SKIP; ident) :/=: NIL) AND (ru :=: (TRUE | SKIP; ident)) | ctr +:= 1); ctrt := 43; c (CASE -2 IN SKIP, ident OUT ident ESAC := (CASE -2 IN SKIP, ident OUT ident ESAC := CASE -2 IN SKIP, ident OUT ident ESAC := CASE -2 IN SKIP, ident OUT ident ESAC := 1)); ((CASE -2 IN SKIP, ident OUT ident ESAC :/=: NIL) AND (ru :=: CASE -2 IN SKIP, ident OUT ident ESAC) | ctr +:= 1); ctrt := 44; c ((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := ((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) := 1)); (((ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident) :/=: NIL) AND (ru :=: (ru | (UNION (COMPL, UNION (INT, COMPL), INT)): ident)) | ctr +:= 1); SKIP END; print ((ctr, " tests ", (ctr = vf | "ok" | "erreur"))))algol68g-2.8/test-set/a68g.mc.020.clau01.a680000644000175000001440000000161112224301221014526 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #clau01# BEGIN # Some routines # PROC p = (REAL x) REAL: x + 1; [# 1 : 9 # ] UNION (PROC REAL, PROC (REAL) REAL) a = (sin, cos, REAL: 3, (REAL x) REAL: x ** 2, p, PROC REAL: REAL: 3.14, REAL: p (2), random, SKIP); FOR i TO UPB a DO print (CASE a[i] IN (PROC REAL pr): pr, (PROC (REAL) REAL pr): pr (i) OUT "skip" ESAC) OD # Output: +0. 841 470 984 807 5, -0. 416 146 836 546 4, 3.0, 16.0, 6.0, 3.14, 3.0, some random number, skip # ENDalgol68g-2.8/test-set/a68g.mc.064.idef08.a680000644000175000001440000000325312224301230014534 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef08# BEGIN # Hiding of operators # print (("Should not run", newline)); # To be hidden: # OP + = (UNION (INT, REAL, BOOL) p) INT: 2; (OP + = (INT i) INT: 3; # hides # print (+1); print (+1.0) # OK, KO # ; print (newline)); (OP + = (REF PROC REAL i) INT: 3; # hides # print (+1); print (+1.0) # KO, KO # ; print (newline)); (OP + = ([] REAL i) INT: 3; # does not hide # print (+1); print (+1.0) # OK, OK # ; print (newline)); (OP + = (UNION ([] INT, [] REAL) i) INT: 3; # does not hide # print (+1); print (+1.0) # OK, OK # ; print (newline)); (OP + = (UNION ([] INT, REAL) i) INT: 3; # hides # print (+1); print (+1.0) # KO, OK # ; print (newline)); (OP + = (REF UNION (INT, BOOL) i) INT: 3; # hides # print (+1); print (+1.0) # KO, KO # ; print (newline)); (OP + = (UNION (CHAR, REF UNION (INT, BOOL)) i) INT: 3; # hides # print (+1); print (+1.0) # KO, KO # ; print (newline)); (OP + = (UNION (CHAR, REF UNION (REF INT, REF BOOL)) i) INT: 3; # does not hide # print (+1); print (+1.0) # OK, OK # ; print (newline)); SKIP ENDalgol68g-2.8/test-set/a68g.mc.143.simp08.a680000644000175000001440000000431012224301261014572 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp08# # Simple coercions # (print (("Prediction: results:", newline)); PROC print ia = (STRING pred) VOID: print ((pred, ": ", ia, newline)); [1 : 3] INT ia := (1, 2, 3); print ia ("+1+2+3 "); # dereferencing # INT i = LOC REF INT := ia[1] #twice dereferenced, at the right moment # ; print (("+1 : ", i, newline)); REF INT ri := ia[2]; # no deref # REF INT (ri) := -2; print ia ("+1-2+3 "); # deproceduring # PROC pri = REF INT: ia[3]; pri := -3 # soft deproc # ; print ia ("+1-2-3 "); PROC pria = REF [] INT: ia; pria[1] := pria[2]; print ia ("-2-2-3 "); # uniting # UNION (REAL, [] INT, [, ] INT) unia = # some-uniting # UNION (REAL, [] INT) # cast # # one-uniting # (ia) # deref# ; ia := (3, 2, 1) # spoil ia # ; CASE unia IN ([] INT ia): (print (("-2-2-3 : ", ia, newline)); print (("-2-2-3 : ", unia # why not ? # , newline)); print ia ("+3+2+1 ") # spoiled ia # ) OUT print ("Bad case of case") ESAC; # widening # REAL x = ia[1]; COMPL z = x; print (("3e0,3e0i0e0 : ", x, z, newline)); [] BOOL b = 8r52, STRING s = bytes pack ("abc"); print (("f...ftftftfabc: ", b, s, newline)); # rowing # [1 : 1, 1 : 3] INT iaa; FOR i TO 3 DO iaa[1, i] := 5 + i OD; PROC print iaa = (STRING pred) VOID: print ((pred, ": ", LWB iaa, UPB iaa, 2 LWB iaa, 2 UPB iaa, iaa, newline)); print iaa ("+1+1+1+3+6+7+8"); ia := iaa[1, ]; print ia ("+6+7+8 "); ia := (1, 2, 3); iaa := ia # rowing # ; print iaa ("+1+1+1+3+1+2+3"); # "hipping" # REF INT p = NIL, q = NIL; print (("true : ", p :=: q, newline)); ia := (1, 5, l) # no assignation # ; l: print ia ("+1+2+3 "); ia := (5, SKIP, 7); ia[2] := 6; print ia ("+5+6+7 "))algol68g-2.8/test-set/a68g.ur.198.r9.a680000644000175000001440000004313512224301312014052 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r9 # (print (("test of operator identifiers : tam and tad", newline)); INT nbt = 271; [1 : nbt] BOOL tc; FOR i TO nbt DO tc[i] := TRUE OD; INT ctr := 0; PROC pos = (INT i) BOOL: (ctr +:= 1; tc[i] | tc[i] := FALSE | print (("err.1", i, newline)); SKIP); (OP TTT = (INT a) BOOL: pos (1); OP &:= = (INT a) BOOL: pos (2); OP &=: = (INT a) BOOL: pos (3); OP & = (INT a) BOOL: pos (4); OP ?:= = (INT a) BOOL: pos (5); OP ?=: = (INT a) BOOL: pos (6); OP ? = (INT a) BOOL: pos (7); OP +:= = (INT a) BOOL: pos (8); OP +=: = (INT a) BOOL: pos (9); OP + = (INT a) BOOL: pos (10); OP -:= = (INT a) BOOL: pos (11); OP -=: = (INT a) BOOL: pos (12); OP - = (INT a) BOOL: pos (13); OP ^:= = (INT a) BOOL: pos (14); OP ^=: = (INT a) BOOL: pos (15); OP ^ = (INT a) BOOL: pos (16); OP &<:= = (INT a) BOOL: pos (17); OP &<=: = (INT a) BOOL: pos (18); OP &< = (INT a) BOOL: pos (19); OP &>:= = (INT a) BOOL: pos (20); OP &>=: = (INT a) BOOL: pos (21); OP &> = (INT a) BOOL: pos (22); OP &/:= = (INT a) BOOL: pos (23); OP &/=: = (INT a) BOOL: pos (24); OP &/ = (INT a) BOOL: pos (25); OP &*:= = (INT a) BOOL: pos (26); OP &*=: = (INT a) BOOL: pos (27); OP &* = (INT a) BOOL: pos (28); OP &=:= = (INT a) BOOL: pos (29); OP &==: = (INT a) BOOL: pos (30); OP &= = (INT a) BOOL: pos (31); OP ?<:= = (INT a) BOOL: pos (32); OP ?<=: = (INT a) BOOL: pos (33); OP ?< = (INT a) BOOL: pos (34); OP ?>:= = (INT a) BOOL: pos (35); OP ?>=: = (INT a) BOOL: pos (36); OP ?> = (INT a) BOOL: pos (37); OP ?/:= = (INT a) BOOL: pos (38); OP ?/=: = (INT a) BOOL: pos (39); OP ?/ = (INT a) BOOL: pos (40); OP ?*:= = (INT a) BOOL: pos (41); OP ?*=: = (INT a) BOOL: pos (42); OP ?* = (INT a) BOOL: pos (43); OP ?=:= = (INT a) BOOL: pos (44); OP ?==: = (INT a) BOOL: pos (45); OP ?= = (INT a) BOOL: pos (46); OP +<:= = (INT a) BOOL: pos (47); OP +<=: = (INT a) BOOL: pos (48); OP +< = (INT a) BOOL: pos (49); OP +>:= = (INT a) BOOL: pos (50); OP +>=: = (INT a) BOOL: pos (51); OP +> = (INT a) BOOL: pos (52); OP +/:= = (INT a) BOOL: pos (53); OP +/=: = (INT a) BOOL: pos (54); OP +/ = (INT a) BOOL: pos (55); OP +*:= = (INT a) BOOL: pos (56); OP +*=: = (INT a) BOOL: pos (57); OP +* = (INT a) BOOL: pos (58); OP +=:= = (INT a) BOOL: pos (59); OP +==: = (INT a) BOOL: pos (60); OP += = (INT a) BOOL: pos (61); OP -<:= = (INT a) BOOL: pos (62); OP -<=: = (INT a) BOOL: pos (63); OP -< = (INT a) BOOL: pos (64); OP ->:= = (INT a) BOOL: pos (65); OP ->=: = (INT a) BOOL: pos (66); OP -> = (INT a) BOOL: pos (67); OP -/:= = (INT a) BOOL: pos (68); OP -/=: = (INT a) BOOL: pos (69); OP -/ = (INT a) BOOL: pos (70); OP -*:= = (INT a) BOOL: pos (71); OP -*=: = (INT a) BOOL: pos (72); OP -* = (INT a) BOOL: pos (73); OP -=:= = (INT a) BOOL: pos (74); OP -==: = (INT a) BOOL: pos (75); OP -= = (INT a) BOOL: pos (76); OP ^<:= = (INT a) BOOL: pos (77); OP ^<=: = (INT a) BOOL: pos (78); OP ^< = (INT a) BOOL: pos (79); OP ^>:= = (INT a) BOOL: pos (80); OP ^>=: = (INT a) BOOL: pos (81); OP ^> = (INT a) BOOL: pos (82); OP ^/:= = (INT a) BOOL: pos (83); OP ^/=: = (INT a) BOOL: pos (84); OP ^/ = (INT a) BOOL: pos (85); OP ^*:= = (INT a) BOOL: pos (86); OP ^*=: = (INT a) BOOL: pos (87); OP ^* = (INT a) BOOL: pos (88); OP ^=:= = (INT a) BOOL: pos (89); OP ^==: = (INT a) BOOL: pos (90); OP ^= = (INT a) BOOL: pos (91); TTT 1; &:=2; &=:6; &4; ?:=5; ?=:4; ?1; +:=9; +=:2; +7; -:=1; -=:6; -2; ^:=6; ^=:3; ^5; &<:=6; &<=:2; &<8; &>:=8; &>=:7; &>6; &/:=6; &/=:5; &/6; &*:=3; &*=:4; &*3; &=:=6; &==:9; &=4; ?<:=4; ?<=:6; ?<7; ?>:=1; ?>=:8; ?>8; ?/:=5; ?/=:6; ?/4; ?*:=7; ?*=:4; ?*2; ?=:=8; ?==:7; ?=8; +<:=8; +<=:3; +<6; +>:=6; +>=:6; +>7; +/:=5; +/=:4; +/3; +*:=3; +*=:4; +*5; +=:=4; +==:9; +=5; -<:=3; -<=:6; -<3; ->:=2; ->=:6; ->5; -/:=4; -/=:1; -/8; -*:=3; -*=:2; -*3; -=:=3; -==:4; -=3; ^<:=7; ^<=:9; ^<8; ^>:=7; ^>=:5; ^>3; ^/:=2; ^/=:1; ^/1; ^*:=3; ^*=:2; ^*1; ^=:=3; ^==:8; ^=6; SKIP); (PRIO &:= = 7; PRIO ?:= = 8; PRIO +:= = 9; PRIO -:= = 1; PRIO ^:= = 2; PRIO <:= = 3; PRIO >:= = 4; PRIO /:= = 5; PRIO *:= = 6; PRIO =:= = 7; PRIO &<:= = 8; PRIO &>:= = 9; PRIO &/:= = 1; PRIO &*:= = 2; PRIO &=:= = 3; PRIO ?<:= = 4; PRIO ?>:= = 5; PRIO ?/:= = 6; PRIO ?*:= = 7; PRIO ?=:= = 8; PRIO +<:= = 9; PRIO +>:= = 1; PRIO +/:= = 2; PRIO +*:= = 3; PRIO +=:= = 4; PRIO -<:= = 5; PRIO ->:= = 6; PRIO -/:= = 7; PRIO -*:= = 8; PRIO -=:= = 9; PRIO ^<:= = 1; PRIO ^>:= = 2; PRIO ^/:= = 3; PRIO ^*:= = 4; PRIO ^=:= = 5; PRIO <<:= = 6; PRIO <>:= = 7; PRIO <:= = 2; PRIO >>:= = 3; PRIO >/:= = 4; PRIO >*:= = 5; PRIO >=:= = 6; PRIO /<:= = 7; PRIO />:= = 8; PRIO //:= = 9; PRIO /*:= = 1; PRIO /=:= = 2; PRIO *<:= = 3; PRIO *>:= = 4; PRIO */:= = 5; PRIO **:= = 6; PRIO *=:= = 7; PRIO =<:= = 8; PRIO =>:= = 9; PRIO =/:= = 1; PRIO =*:= = 2; PRIO ==:= = 3; OP &:= = (INT a, b) BOOL: pos (92); OP ?:= = (INT a, b) BOOL: pos (93); OP +:= = (INT a, b) BOOL: pos (94); OP -:= = (INT a, b) BOOL: pos (95); OP ^:= = (INT a, b) BOOL: pos (96); OP <:= = (INT a, b) BOOL: pos (97); OP >:= = (INT a, b) BOOL: pos (98); OP /:= = (INT a, b) BOOL: pos (99); OP *:= = (INT a, b) BOOL: pos (100); OP =:= = (INT a, b) BOOL: pos (101); OP &<:= = (INT a, b) BOOL: pos (102); OP &>:= = (INT a, b) BOOL: pos (103); OP &/:= = (INT a, b) BOOL: pos (104); OP &*:= = (INT a, b) BOOL: pos (105); OP &=:= = (INT a, b) BOOL: pos (106); OP ?<:= = (INT a, b) BOOL: pos (107); OP ?>:= = (INT a, b) BOOL: pos (108); OP ?/:= = (INT a, b) BOOL: pos (109); OP ?*:= = (INT a, b) BOOL: pos (110); OP ?=:= = (INT a, b) BOOL: pos (111); OP +<:= = (INT a, b) BOOL: pos (112); OP +>:= = (INT a, b) BOOL: pos (113); OP +/:= = (INT a, b) BOOL: pos (114); OP +*:= = (INT a, b) BOOL: pos (115); OP +=:= = (INT a, b) BOOL: pos (116); OP -<:= = (INT a, b) BOOL: pos (117); OP ->:= = (INT a, b) BOOL: pos (118); OP -/:= = (INT a, b) BOOL: pos (119); OP -*:= = (INT a, b) BOOL: pos (120); OP -=:= = (INT a, b) BOOL: pos (121); OP ^<:= = (INT a, b) BOOL: pos (122); OP ^>:= = (INT a, b) BOOL: pos (123); OP ^/:= = (INT a, b) BOOL: pos (124); OP ^*:= = (INT a, b) BOOL: pos (125); OP ^=:= = (INT a, b) BOOL: pos (126); OP <<:= = (INT a, b) BOOL: pos (127); OP <>:= = (INT a, b) BOOL: pos (128); OP <:= = (INT a, b) BOOL: pos (132); OP >>:= = (INT a, b) BOOL: pos (133); OP >/:= = (INT a, b) BOOL: pos (134); OP >*:= = (INT a, b) BOOL: pos (135); OP >=:= = (INT a, b) BOOL: pos (136); OP /<:= = (INT a, b) BOOL: pos (137); OP />:= = (INT a, b) BOOL: pos (138); OP //:= = (INT a, b) BOOL: pos (139); OP /*:= = (INT a, b) BOOL: pos (140); OP /=:= = (INT a, b) BOOL: pos (141); OP *<:= = (INT a, b) BOOL: pos (142); OP *>:= = (INT a, b) BOOL: pos (143); OP */:= = (INT a, b) BOOL: pos (144); OP **:= = (INT a, b) BOOL: pos (145); OP *=:= = (INT a, b) BOOL: pos (146); OP =<:= = (INT a, b) BOOL: pos (147); OP =>:= = (INT a, b) BOOL: pos (148); OP =/:= = (INT a, b) BOOL: pos (149); OP =*:= = (INT a, b) BOOL: pos (150); OP ==:= = (INT a, b) BOOL: pos (151); 3 &:= 7; 2 ?:= 8; 3 +:= 6; 1 -:= 4; 5 ^:= 5; 9 <:= 5; 6 >:= 6; 1 /:= 3; 9 *:= 2; 5 =:= 9; 2 &<:= 8; 9 &>:= 7; 3 &/:= 9; 4 &*:= 1; 8 &=:= 5; 8 ?<:= 3; 5 ?>:= 6; 6 ?/:= 1; 5 ?*:= 4; 6 ?=:= 6; 5 +<:= 7; 2 +>:= 2; 3 +/:= 6; 3 +*:= 8; 3 +=:= 3; 7 -<:= 6; 4 ->:= 4; 5 -/:= 9; 1 -*:= 5; 2 -=:= 2; 9 ^<:= 3; 9 ^>:= 3; 2 ^/:= 3; 1 ^*:= 9; 3 ^=:= 7; 2 <<:= 7; 2 <>:= 2; 7 <:= 5; 8 >>:= 7; 3 >/:= 2; 5 >*:= 2; 4 >=:= 3; 5 /<:= 3; 9 />:= 9; 4 //:= 2; 1 /*:= 1; 3 /=:= 7; 3 *<:= 1; 9 *>:= 9; 8 */:= 3; 5 **:= 9; 4 *=:= 5; 1 =<:= 4; 7 =>:= 9; 6 =/:= 7; 3 =*:= 9; 1 ==:= 3; SKIP); (PRIO &=: = 4; PRIO ?=: = 5; PRIO +=: = 6; PRIO -=: = 7; PRIO ^=: = 8; PRIO <=: = 9; PRIO >=: = 1; PRIO /=: = 2; PRIO *=: = 3; PRIO ==: = 4; PRIO &<=: = 5; PRIO &>=: = 6; PRIO &/=: = 7; PRIO &*=: = 8; PRIO &==: = 9; PRIO ?<=: = 1; PRIO ?>=: = 2; PRIO ?/=: = 3; PRIO ?*=: = 4; PRIO ?==: = 5; PRIO +<=: = 6; PRIO +>=: = 7; PRIO +/=: = 8; PRIO +*=: = 9; PRIO +==: = 1; PRIO -<=: = 2; PRIO ->=: = 3; PRIO -/=: = 4; PRIO -*=: = 5; PRIO -==: = 6; PRIO ^<=: = 7; PRIO ^>=: = 8; PRIO ^/=: = 9; PRIO ^*=: = 1; PRIO ^==: = 2; PRIO <<=: = 3; PRIO <>=: = 4; PRIO <=: = 8; PRIO >>=: = 9; PRIO >/=: = 1; PRIO >*=: = 2; PRIO >==: = 3; PRIO /<=: = 4; PRIO />=: = 5; PRIO //=: = 6; PRIO /*=: = 7; PRIO /==: = 8; PRIO *<=: = 9; PRIO *>=: = 1; PRIO */=: = 2; PRIO **=: = 3; PRIO *==: = 4; PRIO =<=: = 5; PRIO =>=: = 6; PRIO =/=: = 7; PRIO =*=: = 8; PRIO ===: = 9; OP &=: = (INT a, b) BOOL: pos (152); OP ?=: = (INT a, b) BOOL: pos (153); OP +=: = (INT a, b) BOOL: pos (154); OP -=: = (INT a, b) BOOL: pos (155); OP ^=: = (INT a, b) BOOL: pos (156); OP <=: = (INT a, b) BOOL: pos (157); OP >=: = (INT a, b) BOOL: pos (158); OP /=: = (INT a, b) BOOL: pos (159); OP *=: = (INT a, b) BOOL: pos (160); OP ==: = (INT a, b) BOOL: pos (161); OP &<=: = (INT a, b) BOOL: pos (162); OP &>=: = (INT a, b) BOOL: pos (163); OP &/=: = (INT a, b) BOOL: pos (164); OP &*=: = (INT a, b) BOOL: pos (165); OP &==: = (INT a, b) BOOL: pos (166); OP ?<=: = (INT a, b) BOOL: pos (167); OP ?>=: = (INT a, b) BOOL: pos (168); OP ?/=: = (INT a, b) BOOL: pos (169); OP ?*=: = (INT a, b) BOOL: pos (170); OP ?==: = (INT a, b) BOOL: pos (171); OP +<=: = (INT a, b) BOOL: pos (172); OP +>=: = (INT a, b) BOOL: pos (173); OP +/=: = (INT a, b) BOOL: pos (174); OP +*=: = (INT a, b) BOOL: pos (175); OP +==: = (INT a, b) BOOL: pos (176); OP -<=: = (INT a, b) BOOL: pos (177); OP ->=: = (INT a, b) BOOL: pos (178); OP -/=: = (INT a, b) BOOL: pos (179); OP -*=: = (INT a, b) BOOL: pos (180); OP -==: = (INT a, b) BOOL: pos (181); OP ^<=: = (INT a, b) BOOL: pos (182); OP ^>=: = (INT a, b) BOOL: pos (183); OP ^/=: = (INT a, b) BOOL: pos (184); OP ^*=: = (INT a, b) BOOL: pos (185); OP ^==: = (INT a, b) BOOL: pos (186); OP <<=: = (INT a, b) BOOL: pos (187); OP <>=: = (INT a, b) BOOL: pos (188); OP <=: = (INT a, b) BOOL: pos (192); OP >>=: = (INT a, b) BOOL: pos (193); OP >/=: = (INT a, b) BOOL: pos (194); OP >*=: = (INT a, b) BOOL: pos (195); OP >==: = (INT a, b) BOOL: pos (196); OP /<=: = (INT a, b) BOOL: pos (197); OP />=: = (INT a, b) BOOL: pos (198); OP //=: = (INT a, b) BOOL: pos (199); OP /*=: = (INT a, b) BOOL: pos (200); OP /==: = (INT a, b) BOOL: pos (201); OP *<=: = (INT a, b) BOOL: pos (202); OP *>=: = (INT a, b) BOOL: pos (203); OP */=: = (INT a, b) BOOL: pos (204); OP **=: = (INT a, b) BOOL: pos (205); OP *==: = (INT a, b) BOOL: pos (206); OP =<=: = (INT a, b) BOOL: pos (207); OP =>=: = (INT a, b) BOOL: pos (208); OP =/=: = (INT a, b) BOOL: pos (209); OP =*=: = (INT a, b) BOOL: pos (210); OP ===: = (INT a, b) BOOL: pos (211); 6 &=: 8; 6 ?=: 7; 7 +=: 1; 2 -=: 8; 3 ^=: 4; 6 <=: 2; 5 >=: 7; 4 /=: 6; 8 *=: 9; 4 ==: 6; 5 &<=: 3; 7 &>=: 4; 9 &/=: 1; 1 &*=: 7; 9 &==: 8; 6 ?<=: 6; 2 ?>=: 1; 8 ?/=: 6; 5 ?*=: 1; 3 ?==: 8; 2 +<=: 6; 1 +>=: 5; 3 +/=: 3; 4 +*=: 2; 8 +==: 6; 9 -<=: 3; 6 ->=: 4; 1 -/=: 2; 4 -*=: 4; 5 -==: 4; 3 ^<=: 6; 1 ^>=: 3; 1 ^/=: 4; 9 ^*=: 2; 7 ^==: 4; 4 <<=: 4; 6 <>=: 3; 7 <=: 3; 6 >>=: 8; 6 >/=: 8; 6 >*=: 6; 7 >==: 5; 4 /<=: 7; 4 />=: 6; 1 //=: 6; 6 /*=: 8; 1 /==: 7; 2 *<=: 7; 9 *>=: 2; 6 */=: 9; 4 **=: 3; 8 *==: 4; 8 =<=: 5; 9 =>=: 6; 6 =/=: 4; 1 =*=: 7; 8 ===: 1; SKIP); (PRIO & = 2; PRIO ? = 3; PRIO + = 4; PRIO - = 5; PRIO ^ = 6; PRIO < = 7; PRIO > = 8; PRIO / = 9; PRIO * = 1; PRIO = = 2; PRIO &< = 3; PRIO &> = 4; PRIO &/ = 5; PRIO &* = 6; PRIO &= = 7; PRIO ?< = 8; PRIO ?> = 9; PRIO ?/ = 1; PRIO ?* = 2; PRIO ?= = 3; PRIO +< = 4; PRIO +> = 5; PRIO +/ = 6; PRIO +* = 7; PRIO += = 8; PRIO -< = 9; PRIO -> = 1; PRIO -/ = 2; PRIO -* = 3; PRIO -= = 4; PRIO ^< = 5; PRIO ^> = 6; PRIO ^/ = 7; PRIO ^* = 8; PRIO ^= = 9; PRIO << = 1; PRIO <> = 2; PRIO < = 6; PRIO >> = 7; PRIO >/ = 8; PRIO >* = 9; PRIO >= = 1; PRIO /< = 2; PRIO /> = 3; PRIO // = 4; PRIO /* = 5; PRIO /= = 6; PRIO *< = 7; PRIO *> = 8; PRIO */ = 9; PRIO ** = 1; PRIO *= = 2; PRIO =< = 3; PRIO => = 4; PRIO =/ = 5; PRIO =* = 6; PRIO == = 7; OP & = (INT a, b) BOOL: pos (212); OP ? = (INT a, b) BOOL: pos (213); OP + = (INT a, b) BOOL: pos (214); OP - = (INT a, b) BOOL: pos (215); OP ^ = (INT a, b) BOOL: pos (216); OP < = (INT a, b) BOOL: pos (217); OP > = (INT a, b) BOOL: pos (218); OP / = (INT a, b) BOOL: pos (219); OP * = (INT a, b) BOOL: pos (220); OP = = (INT a, b) BOOL: pos (221); OP &< = (INT a, b) BOOL: pos (222); OP &> = (INT a, b) BOOL: pos (223); OP &/ = (INT a, b) BOOL: pos (224); OP &* = (INT a, b) BOOL: pos (225); OP &= = (INT a, b) BOOL: pos (226); OP ?< = (INT a, b) BOOL: pos (227); OP ?> = (INT a, b) BOOL: pos (228); OP ?/ = (INT a, b) BOOL: pos (229); OP ?* = (INT a, b) BOOL: pos (230); OP ?= = (INT a, b) BOOL: pos (231); OP +< = (INT a, b) BOOL: pos (232); OP +> = (INT a, b) BOOL: pos (233); OP +/ = (INT a, b) BOOL: pos (234); OP +* = (INT a, b) BOOL: pos (235); OP += = (INT a, b) BOOL: pos (236); OP -< = (INT a, b) BOOL: pos (237); OP -> = (INT a, b) BOOL: pos (238); OP -/ = (INT a, b) BOOL: pos (239); OP -* = (INT a, b) BOOL: pos (240); OP -= = (INT a, b) BOOL: pos (241); OP ^< = (INT a, b) BOOL: pos (242); OP ^> = (INT a, b) BOOL: pos (243); OP ^/ = (INT a, b) BOOL: pos (244); OP ^* = (INT a, b) BOOL: pos (245); OP ^= = (INT a, b) BOOL: pos (246); OP << = (INT a, b) BOOL: pos (247); OP <> = (INT a, b) BOOL: pos (248); OP < = (INT a, b) BOOL: pos (252); OP >> = (INT a, b) BOOL: pos (253); OP >/ = (INT a, b) BOOL: pos (254); OP >* = (INT a, b) BOOL: pos (255); OP >= = (INT a, b) BOOL: pos (256); OP /< = (INT a, b) BOOL: pos (257); OP /> = (INT a, b) BOOL: pos (258); OP // = (INT a, b) BOOL: pos (259); OP /* = (INT a, b) BOOL: pos (260); OP /= = (INT a, b) BOOL: pos (261); OP *< = (INT a, b) BOOL: pos (262); OP *> = (INT a, b) BOOL: pos (263); OP */ = (INT a, b) BOOL: pos (264); OP ** = (INT a, b) BOOL: pos (265); OP *= = (INT a, b) BOOL: pos (266); OP =< = (INT a, b) BOOL: pos (267); OP => = (INT a, b) BOOL: pos (268); OP =/ = (INT a, b) BOOL: pos (269); OP =* = (INT a, b) BOOL: pos (270); OP == = (INT a, b) BOOL: pos (271); 3 & 8; 9 ? 5; 9 + 9; 4 - 1; 3 ^ 1; 6 < 8; 3 > 8; 2 / 4; 5 * 3; 5 = 2; 7 &< 3; 3 &> 4; 9 &/ 4; 9 &* 1; 8 &= 3; 8 ?< 8; 6 ?> 1; 2 ?/ 2; 8 ?* 7; 4 ?= 1; 8 +< 2; 2 +> 5; 2 +/ 3; 3 +* 8; 1 += 8; 6 -< 8; 5 -> 7; 9 -/ 6; 3 -* 8; 6 -= 2; 9 ^< 7; 6 ^> 3; 5 ^/ 9; 8 ^* 4; 2 ^= 4; 2 << 8; 6 <> 1; 8 < 4; 8 >> 6; 7 >/ 5; 6 >* 2; 2 >= 8; 1 /< 7; 9 /> 5; 2 // 7; 1 /* 3; 6 /= 6; 5 *< 1; 9 *> 3; 9 */ 7; 9 ** 5; 2 *= 7; 6 =< 7; 2 => 7; 3 =/ 1; 8 =* 4; 5 == 6; SKIP); FOR i TO nbt DO (tc[i] | print (("err.2", i))) OD; print ((ctr, " tests ", (ctr = nbt | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.125.oper16.a680000644000175000001440000011250012224301255014572 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper16# # Tests on operators # BEGIN PROC error = (INT i) VOID: print (("Error in test", i)); PROC tste = (INT i) VOID: BEGIN error (i); print (("; wrong branch taken", newline)) END; PROC tsti = (INT i, INT p, q) VOID: IF p = q THEN SKIP ELSE error (i); print (("; value is: ", q, ", must be: ", p, newline)) FI; PROC tstr = (INT i, REAL p, q) VOID: # two reals are considered equal if their difference is negligible compared to one of them # IF p + (p - q) / 8 = p THEN SKIP ELSE error (i); print (("; value is: ", q, ", must be: ", p, newline)) FI; PROC tstb = (INT i, BOOL p, q) VOID: BEGIN IF p THEN IF q THEN SKIP ELSE GOTO bad FI ELSE IF q THEN GOTO bad ELSE SKIP FI FI EXIT bad: error (i); print (("; value is: ", q, ", must be: ", p, newline)) END; PROC tstc = (INT i, CHAR p, q) VOID: IF p = q THEN SKIP ELSE error (i); print (("; value is: ", q, ", must be: ", p, newline)) FI; PROC tstli = (INT i, LONG INT p, q) VOID: IF p = q THEN SKIP ELSE error (i); print (("; value is: ", q, ", must be: ", p, newline)) FI; PROC tstlr = (INT i, LONG REAL p, q) VOID: IF p + (p - q) / LONG 8 = p THEN SKIP ELSE error (i); print (("; value is: ", q, ", must be: ", p, newline)) FI; print (("Test: REPR, ABS", newline)); BEGIN INT b1; LONG INT b2; INT b0 = 44; [1 : 2] CHAR a; a[2] := "a"; tstc (1, "a", REPR ABS "a"); tstc (2, "a", REPR ABS a[2]); tsti (3, +43, ABS (REPR 43)); tsti (4, +44, ABS (REPR b0)); b1 := 45; tsti (5, +45, ABS (REPR b1)); tsti (6, +46, ABS (REPR (46 + 0))); b2 := LONG 43; tsti (7, +43, ABS (REPR SHORTEN b2)); tsti (8, +46, ABS REPR SHORTEN LONG 46) END; print (("Test: LWB, UPB", newline)); BEGIN REF [] CHAR b; [-5 : -3, -1 : 3] REF [, ] REAL a; tsti (9, -5, 1 LWB a); tsti (10, -5, LWB a); tsti (11, -1, 2 LWB a); tsti (12, -3, 1 UPB a); tsti (13, -3, UPB a); tsti (14, +3, 2 UPB a); FOR i FROM LWB a BY 1 TO UPB a DO FOR j FROM 2 LWB a BY 1 TO 2 UPB a DO BEGIN [i : j, -j : -i] REAL b; a[i, j] := b; tsti (15, i, 1 LWB a[i, j]); tsti (16, j, UPB a[i, j]); tsti (17, -j, 2 LWB a[i, j]); tsti (18, -i, 2 UPB a[i, j]) END OD OD END; BEGIN [1 : 3, 2 : 4, 3 : 5] INT a aaaaa; INT jjjjjj; FOR i FROM 1 BY 1 TO 3 DO tsti (19, i, i LWB aaaaaa); tsti (20, i + 2, i UPB aaaaaa) OD; FOR i FROM -3 BY 1 TO -1 DO tsti (21, -i, -i LWB aaaaaa); tsti (22, 2 - i, -i UPB aaaaaa) OD; jjjjjj := 2; tsti (23, +2, jjjjjj LWB aaaaaa); tsti (24, +4, jjjjjj UPB aaaaaa); tsti (25, +1, LWB "abc"); tsti (26, +3, UPB "cde"); tsti (27, +1, (1 + 0) LWB "abc"); tsti (28, +3, 1 UPB "efg") END; print (("Test: OR, AND", newline)); BEGIN BOOL t = TRUE; BOOL f = FALSE; BOOL a; a := t OR t; tstb (29, TRUE, a); a := t OR f; tstb (30, TRUE, a); a := f OR t; tstb (31, TRUE, a); a := f OR f; tstb (32, FALSE, a); a := t AND t; tstb (33, TRUE, a); a := t AND f; tstb (34, FALSE, a); a := f AND t; tstb (35, FALSE, a); a := f AND f; tstb (36, FALSE, a); a := NOT t AND t; tstb (37, FALSE, a); a := NOT f AND t; tstb (38, TRUE, a); a := NOT t AND f; tstb (39, FALSE, a); a := NOT f AND f; tstb (40, FALSE, a); a := NOT t OR t; tstb (41, TRUE, a); a := NOT f OR t; tstb (42, TRUE, a); a := NOT t OR f; tstb (43, FALSE, a); a := NOT f OR f; tstb (44, TRUE, a); a := t AND NOT t; tstb (45, FALSE, a); a := t AND NOT f; tstb (46, TRUE, a); a := f AND NOT t; tstb (47, FALSE, a); a := f AND NOT f; tstb (48, FALSE, a); a := t OR NOT t; tstb (49, TRUE, a); a := t OR NOT f; tstb (50, TRUE, a); a := f OR NOT t; tstb (51, FALSE, a); a := f OR NOT f; tstb (52, TRUE, a); a := NOT t AND NOT t; tstb (53, FALSE, a); a := NOT t AND NOT f; tstb (54, FALSE, a); a := NOT f AND NOT t; tstb (55, FALSE, a); a := NOT f AND NOT f; tstb (56, TRUE, a); a := NOT t OR NOT t; tstb (57, FALSE, a); a := NOT t OR NOT f; tstb (58, TRUE, a); a := NOT f OR NOT t; tstb (59, TRUE, a); a := NOT f OR NOT f; tstb (60, TRUE, a); a := t; tstb (61, TRUE, a); a := a AND t; tstb (62, TRUE, a); a := a OR t; tstb (63, TRUE, a); a := a OR f; tstb (64, TRUE, a); a := a AND f; tstb (65, FALSE, a); a := a AND f; tstb (66, FALSE, a); a := a AND t; tstb (67, FALSE, a); a := a OR f; tstb (68, FALSE, a); a := a OR t; tstb (69, TRUE, a); a := t; tstb (70, TRUE, a); a := t AND a; tstb (71, TRUE, a); a := t OR a; tstb (72, TRUE, a); a := f OR a; tstb (73, TRUE, a); a := f AND a; tstb (74, FALSE, a); a := f AND a; tstb (75, FALSE, a); a := t AND a; tstb (76, FALSE, a); a := f OR a; tstb (77, FALSE, a); a := t OR a; tstb (78, TRUE, a); SKIP END; BEGIN BOOL t = TRUE; BOOL f = FALSE; tstb (79, TRUE, t OR f); tstb (80, TRUE, t OR t); tstb (81, TRUE, f OR t); tstb (82, FALSE, f OR f); tstb (83, TRUE, NOT (f OR f)); tstb (84, TRUE, NOT (f AND f)); tstb (85, TRUE, t AND t); tstb (86, FALSE, t AND f); tstb (87, FALSE, f AND t); tstb (88, FALSE, f AND f); tstb (89, TRUE, (t OR t) OR (f OR f)); tstb (90, FALSE, (t OR t) AND (f OR f)); tstb (91, TRUE, t OR (f OR f)); tstb (92, TRUE, NOT (t AND (f OR f))); tstb (93, FALSE, NOT NOT ((f OR f) OR f)); tstb (94, TRUE, NOT NOT NOT ((f OR f) AND f)); IF t OR f THEN SKIP ELSE tste (95) FI; IF t OR t THEN SKIP ELSE tste (96) FI; IF f OR t THEN SKIP ELSE tste (97) FI; IF f OR f THEN tste (98) FI; IF NOT (f OR f) THEN SKIP ELSE tste (99) FI; IF NOT (f AND f) THEN SKIP ELSE tste (100) FI; IF t AND t THEN SKIP ELSE tste (101) FI; IF t AND f THEN tste (102) FI; IF f AND t THEN tste (103) FI; IF f AND f THEN tste (104) FI; IF (t OR t) AND (t OR t) THEN SKIP ELSE tste (105) FI; IF (t OR t) OR (t OR t) THEN SKIP ELSE tste (106) FI; IF (t OR t) OR f THEN SKIP ELSE tste (107) FI; IF (t OR t) AND t THEN SKIP ELSE tste (108) FI; IF t OR (t OR t) THEN SKIP ELSE tste (109) FI; IF t AND (t OR f) THEN SKIP ELSE tste (110) FI; BOOL a1; a1 := t AND f; tstb (111, FALSE, a1); BOOL a2; a2 := NOT (t OR f); tstb (112, FALSE, a2); BEGIN BOOL t; t := TRUE; BOOL f; f := FALSE; IF (NOT (NOT ((t OR t) AND (t OR t)) OR ((f OR f) OR f) AND (t OR f AND f)) AND f) OR NOT t THEN tste (113) ELSE SKIP FI; BOOL x; x := (NOT (NOT ((t OR t) AND (t OR t)) OR ((f OR f) OR f) AND (t OR (f AND f))) AND f) OR NOT t; tstb (114, FALSE, x); BOOL y = (NOT (NOT ((t OR t) AND (t OR t)) OR ((f OR f) OR f) AND (t OR (f AND f))) AND f) OR NOT t; tstb (115, FALSE, y) END END; print (("Test: NE, EQ for booleans", newline)); BEGIN BOOL t = TRUE; BOOL f = FALSE; tstb (116, TRUE, t NE f); tstb (117, FALSE, t NE t); tstb (118, TRUE, f NE t); tstb (119, FALSE, f NE f); tstb (120, TRUE, NOT (f NE f)); tstb (121, FALSE, NOT (f EQ f)); tstb (122, TRUE, t EQ t); tstb (123, FALSE, t EQ f); tstb (124, FALSE, f EQ t); tstb (125, TRUE, f EQ f); tstb (126, FALSE, (t NE t) NE (f NE f)); tstb (127, TRUE, (t NE t) EQ (f NE f)); tstb (128, TRUE, t NE (f NE f)); tstb (129, TRUE, NOT (t EQ (f NE f))); tstb (130, FALSE, NOT NOT ((f NE f) NE f)); tstb (131, FALSE, NOT NOT NOT ((f NE f) EQ f)); IF t NE f THEN SKIP ELSE tste (132) FI; IF t NE t THEN tste (133) FI; IF f NE t THEN SKIP ELSE tste (134) FI; IF f NE f THEN tste (135) FI; IF NOT (f NE f) THEN SKIP ELSE tste (136) FI; IF NOT (f EQ f) THEN tste (137) FI; IF t EQ t THEN SKIP ELSE tste (138) FI; IF t EQ f THEN tste (139) FI; IF f EQ t THEN tste (140) FI; IF f EQ f THEN SKIP ELSE tste (141) FI; IF (t NE t) EQ (t NE t) THEN SKIP ELSE tste (142) FI; IF (t NE t) NE (t NE t) THEN tste (143) FI; IF (t NE t) NE f THEN tste (144) FI; IF (t NE t) EQ t THEN tste (145) FI; IF t NE (t NE t) THEN SKIP ELSE tste (146) FI; IF t EQ (t NE f) THEN SKIP ELSE tste (147) FI; BOOL a1; a1 := t EQ f; tstb (148, FALSE, a1); BOOL a2; a2 := NOT (t NE f); tstb (149, FALSE, a2); BEGIN BOOL t; t := TRUE; BOOL f; f := FALSE; IF (NOT (NOT ((t NE t) EQ (t NE t)) NE ((f NE f) NE f) EQ (t NE f EQ f)) EQ f) NE NOT t THEN SKIP ELSE tste (150) FI; BOOL x; x := (NOT (NOT ((t NE t) EQ (t NE t)) NE ((f NE f) NE f) EQ (t NE (f EQ f))) EQ f) NE NOT t; tstb (151, TRUE, x); BOOL y = (NOT (NOT ((t NE t) EQ (t NE t)) NE ((f NE f) NE f) EQ (t NE (f EQ f))) EQ f) NE NOT t; tstb (152, TRUE, y) END END; print (("Test: NOT", newline)); BEGIN BOOL a1, a2, a3, b1, b2, b3; BOOL a4 = NOT FALSE; BOOL a5 = NOT NOT FALSE; BOOL a6 = NOT NOT NOT FALSE; BOOL a7 = NOT a6; BOOL a8 = NOT a7; BOOL a9 = NOT NOT a8; BOOL a10 = NOT NOT NOT a9; IF NOT TRUE THEN tste (153) FI; IF NOT NOT TRUE THEN SKIP ELSE tste (154) FI; IF NOT NOT NOT TRUE THEN tste (155) FI; a1 := NOT TRUE; a2 := NOT NOT FALSE; a3 := NOT NOT NOT TRUE; b1 := NOT TRUE AND FALSE; b2 := NOT NOT TRUE AND FALSE; b3 := TRUE OR NOT NOT NOT TRUE OR FALSE; tstb (156, FALSE, a1); tstb (157, FALSE, a2); tstb (158, FALSE, a3); tstb (159, TRUE, a4); tstb (160, FALSE, a5); tstb (161, TRUE, a6); tstb (162, FALSE, a7); tstb (163, TRUE, a8); tstb (164, TRUE, a9); tstb (165, FALSE, a10); tstb (166, FALSE, b1); tstb (167, FALSE, b2); tstb (168, TRUE, b3) END; print (("Test: EQ, NE, LT, LE, GT, GE", newline)); BEGIN IF -1 = -1 THEN SKIP ELSE tste (169) FI; tstb (170, TRUE, -LONG 1 = -LONG 1); IF -1 /= 1 THEN SKIP ELSE tste (171) FI; tstb (172, TRUE, -LONG 1 /= LONG 1); IF 1 /= -1 THEN SKIP ELSE tste (173) FI; tstb (174, TRUE, LONG 1 /= -LONG 1); IF 1 = 1 THEN SKIP ELSE tste (175) FI; tstb (176, TRUE, LONG 1 = LONG 1); IF 0 = 0.0 THEN SKIP ELSE tste (177) FI; tstb (178, TRUE, LONG 0 = LONG 0.0); IF 1.0 = 1 THEN SKIP ELSE tste (179) FI; tstb (180, TRUE, LONG 1.0 = LONG 1); IF -1.0 = -1.0 THEN SKIP ELSE tste (181) FI; tstb (182, TRUE, -LONG 1.0 = -LONG 1.0); IF -1.0 /= 1.0 THEN SKIP ELSE tste (183) FI; tstb (184, TRUE, LENG -1.0 /= LONG 1.0); IF 1.0 /= -1.0 THEN SKIP ELSE tste (185) FI; tstb (186, TRUE, LONG 1.0 /= LENG -1.0); BOOL a1 = 1 = 1, a2 = 1 /= 1, a3 = 1 > 1, a4 = 1 < 1, a5 = 1 <= 1, a6 = 1 >= 0, a7 = 1.0 = 2.0, a8 = 1.0 /= 2.0, a9 = 1.0 < 2.0, a10 = 1.0 > 0.0, a11 = 1.0 <= 1.0, a12 = 1.0 >= -1.0; tstb (187, TRUE, a1); tstb (188, FALSE, a2); tstb (189, FALSE, a3); tstb (190, FALSE, a4); tstb (191, TRUE, a5); tstb (192, TRUE, a6); tstb (193, FALSE, a7); tstb (194, TRUE, a8); tstb (195, TRUE, a9); tstb (196, TRUE, a10); tstb (197, TRUE, a11); tstb (198, TRUE, a12); IF 1 = 1 THEN SKIP ELSE tste (199) FI; tstb (200, TRUE, 1 = 1); IF NOT (1 /= 1) THEN SKIP ELSE tste (201) FI; tstb (202, TRUE, NOT NOT NOT (1 /= 1)); IF 1 /= 2 AND 2 /= 3 AND 4 /= 5 THEN SKIP ELSE tste (203) FI END; BEGIN REAL j; [-3 : 3] BOOL lt0; lt0[-3] := lt0[-2] := lt0[-1] := TRUE; lt0[0] := lt0[1] := lt0[2] := lt0[3] := FALSE; FOR i FROM -3 BY 1 TO 3 DO tstb (204, NOT (lt0[i] OR lt0[-i]), i = 0); tstb (205, lt0[i] OR lt0[-i], i /= 0); tstb (206, lt0[-i], i > 0); tstb (207, NOT lt0[i], i >= 0); tstb (208, lt0[i], i < 0); tstb (209, NOT lt0[-i], i <= 0); j := i; tstb (210, NOT (lt0[i] OR lt0[-i]), j = 0); tstb (211, lt0[i] OR lt0[-i], j /= 0); tstb (212, lt0[-i], j > 0); tstb (213, NOT lt0[i], j >= 0); tstb (214, lt0[i], j < 0); tstb (215, NOT lt0[-i], j <= 0) OD END; print (("Test: monadic -", newline)); BEGIN INT x0, x1, x2, x3; LONG INT z0, z1, z2, z3; REAL y0, y1, y2, y3; LONG REAL t0, t1, t2, t3; INT x4 = 10; LONG INT z4 = LONG 10; REAL y4 = x4; LONG REAL t4 = z4; z0 := --LONG 38; z1 := -LONG 1000000000; z2 := -z1; x0 := --79; x1 := -1; x2 := -x1; x3 := -SHORTEN z0; t0 := --LONG 8.7; t1 := -LONG 79.99e-2; t2 := -t1; y0 := --6.7e-4; y1 := -39.47e-2; y2 := -y1; y3 := -SHORTEN t2; tsti (216, +79, x0); tsti (217, -1, x1); tsti (218, +1, x2); tsti (219, -38, x3); tsti (220, +10, x4); tstli (221, +LONG 38, z0); tstli (222, -LONG 1000000000, z1); tstli (223, +LONG 1000000000, z2); tstli (224, +LONG 10, z4); tstr (225, +6.7e-4, y0); tstr (226, -3.947e-1, y1); tstr (227, +3.947e-1, y2); tstr (228, -7.999e-1, y3); tstr (229, +1e+1, y4); tstlr (230, +LONG 8.7e+0, t0); tstlr (231, -LONG 7.999e-1, t1); tstlr (232, +LONG 7.999e-1, t2); tstlr (233, +LONG 10e+0, t4) END; print (("Test: dyadic -", newline)); BEGIN tsti (234, -2, 1 - 3); tstli (235, +LONG 4, LONG 7 - LONG 3); tsti (236, -4, -1 - 3); tstli (237, -LONG 13, -LONG 8 - LONG 5); tsti (238, +4, 1 - -3); tstli (239, +LONG 7, LONG 4 - -LONG 3); tsti (240, +2, -1 - -3); tstli (241, -LONG 10, -LONG 5 - -LENG -5); tstr (242, -6.4e+0, 1 - 7.4); tstlr (243, +LONG 8e+0, LONG 4 - LENG -4.0); tstr (244, +6.4e+0, 7.4 - 1); tstlr (245, -LONG 1.2e+1, -LONG 6.0 - LONG 6); tstr (246, +1.22e+1, 6.1 - -6.1); tstlr (247, +LONG 8.6e+0, LONG 4.3 - -LONG 4.3); tsti (248, +29999, 30000 - 1); tstli (249, +LONG 999999998, LONG 1000000000 - LONG 2); tstr (250, +1e+0, -1.0 - (-1.0 - (-1.0 - (-1.0 - 1)))); tstlr (251, +LONG 0e+0, -LONG 1.0 - (-LONG 1.0 - (-LONG 1.0 - (-LONG 1.0 - (LONG 1 - LONG 1.0))))) END; print (("Test: dyadic +", newline)); BEGIN tsti (252, +4, 1 + 3); tstli (253, +LONG 10, LONG 7 + LONG 3); tsti (254, +2, -1 + 3); tstli (255, -LONG 3, -LONG 8 + LONG 5); tsti (256, -2, 1 + -3); tstli (257, +LONG 1, LONG 4 + -LONG 3); tsti (258, -4, -1 + -3); tstli (259, +LONG 0, -LONG 5 + -LENG -5); tstr (260, +8.4e+0, 1 + 7.4); tstlr (261, +LONG 0e+0, LONG 4 + LENG -4.0); tstr (262, +8.4e+0, 7.4 + 1); tstlr (263, +LONG 0e+0, -LONG 6.0 + LONG 6); tstr (264, +0e+0, 6.1 + -6.1); tstlr (265, +LONG 0e+0, LONG 4.3 + -LONG 4.3); tsti (266, -29999, -30000 + 1); tstli (267, -LONG 999999998, -LONG 1000000000 + LONG 2); tstr (268, -3e+0, -1.0 + (-1.0 + (-1.0 + (-1.0 + 1)))); tstlr (269, -LONG 2e+0, -LONG 1.0 + (-LONG 1.0 + (-LONG 1.0 + (-LONG 1.0 + (LONG 1 + LONG 1.0))))) END; print (("Test: ABS", newline)); BEGIN tsti (270, +19, ABS 19); tsti (271, +19, ABS -19); tsti (272, +0, ABS 0); tsti (273, +32, SHORTEN ABS LONG 32); tsti (274, +43, SHORTEN ABS -LONG 43); tsti (275, +0, SHORTEN ABS LONG 0); tstr (276, +1.97e+2, ABS 197.0); tstr (277, +4.97e+1, ABS -49.7); tstr (278, +0e+0, ABS 0.0); tstr (279, +1e+0, SHORTEN ABS LONG 1.0); tstr (280, +0e+0, SHORTEN ABS LONG 0.0e+7); tstr (281, +1.9e+0, SHORTEN ABS -LONG 1.9) END; print (("Test: * for integers", newline)); BEGIN tsti (282, +6, 2 * 3); tsti (283, -6, -2 * 3); tsti (284, -6, 2 * -3); tsti (285, +6, -2 * -3); tsti (286, +6, SHORTEN (-LONG 2 * -LONG 3)); tsti (287, -6, SHORTEN (LONG 2 * -LONG 3)); tsti (288, -6, SHORTEN (-LONG 2 * LONG 3)); tsti (289, +6, SHORTEN (LONG 2 * LONG 3)); tsti (290, +0, 0 * 10); tstli (291, +LONG 0, LONG 0 * -LONG 10); tsti (292, +0, 10 * 0); tstli (293, +LONG 0, -LONG 10 * LENG 0); tsti (294, +3, 1 * 3); tstli (295, +LONG 3, LONG 3 * LONG 1); tsti (296, +16384, 2 * (2 * (2 * (2 * (2 * (2 * (2 * (2 * (2 * (2 * (2 * (2 * (2 * (2)))))))))))))) END; print (("Test: * mixed", newline)); BEGIN REAL a1 = 1.0; LONG REAL a2 = -LONG 1.0; REAL a3; LONG REAL a4; tstr (297, +4.2e+1, 6.0 * 7.0); tstlr (298, +LONG 2.6e+1, LONG 13.0 * LONG 2.0); tstr (299, -4.2e+1, -6.0 * 7.0); tstlr (300, -LONG 6e+0, -LONG 2.0 * LONG 3.0); tstr (301, -5.6e+1, 7.0 * -8.0); tstlr (302, -LONG 4.8e+1, LONG 16.0 * -LENG 3.0); tstr (303, +5.6e+1, -8.0 * -7.0); tstlr (304, +LONG 2.5e+1, -LENG 5.0 * -LONG 5.0); tstr (305, +4.2e+1, 7 * 6.0); tstlr (306, +LONG 2.1e+1, LONG 3 * LONG 7.0); tstr (307, +4.2e+1, 6.0 * 7); tstlr (308, +LONG 3.6e+1, LONG 6.0 * LONG 6); tstr (309, +4.2e+1, -7 * -6.0); tstlr (310, +LONG 2.25e+2, -LONG 15 * -LONG 15.0); tstr (311, +4.2e+1, -6.0 * -7); tstlr (312, +LONG 1.9e+1, -LONG 19.0 * -LONG 1); a3 := 14.0; a4 := LENG -13.0; tstr (313, +1.4e+1, a3 * a1); tstlr (314, +LONG 1.3e+1, a2 * a4); tstr (315, +10e-43, 1.0e-20 * 1.0e-22); tstlr (316, +LONG 10e+39, LONG 1.0e+20 * LONG 1.0e+20) END; print (("Test: OVER, MOD", newline)); BEGIN tsti (317, +2, 12 OVER 6); tsti (318, -5, -20 OVER 4); tsti (319, -25, 100 OVER -4); tsti (320, +10, -10 OVER -1); tsti (321, +2, 7 OVER 3); tsti (322, -2, -8 OVER 3); tsti (323, -1, 10 OVER -7); tsti (324, +1, -49 OVER -27); tsti (325, +3, SHORTEN (LONG 10 OVER LONG 3)); tsti (326, -1, SHORTEN (-LONG 50 OVER LONG 50)); tsti (327, -1, -12 OVER 7); tsti (328, -1, 12 OVER -7); tsti (329, -1, SHORTEN (-LONG 50 OVER LONG 50)); tsti (330, +0, SHORTEN (LONG 0 OVER -LONG 25)); tsti (331, +0, 12 MOD 6); tsti (332, +0, -20 MOD 4); tsti (333, +0, 100 MOD -4); tsti (334, +0, -10 MOD -1); tsti (335, +1, 7 MOD 3); tsti (336, +1, -8 MOD 3); tsti (337, +3, 10 MOD -7); tsti (338, +5, -49 MOD -27); tsti (339, +1, SHORTEN (LONG 10 MOD LONG 3)); tsti (340, +0, SHORTEN (-LONG 50 MOD LONG 50)); tsti (341, +2, -12 MOD 7); tsti (342, +5, 12 MOD -7); tsti (343, +0, SHORTEN (-LONG 50 MOD LONG 50)); tsti (344, +0, SHORTEN (LONG 0 MOD -LONG 25)) END; print (("Test: /", newline)); BEGIN REAL a, b; LONG REAL c, d; REAL x = 127.0; FOR i FROM -3 BY 1 TO 3 DO FOR j FROM -3 BY 1 TO 3 DO IF j /= 0 THEN a := i / j; tstr (345, i, a * j); a := i; a := a / j; tstr (346, i, a * j); a := j; a := i / a; tstr (347, i, a * j); a := i; b := j; a := a / b; tstr (348, i, a * j); c := LENG i / LENG j; tstlr (349, LENG i, c * LENG j); c := LENG i; c := c / LENG j; tstlr (350, LENG i, c * LENG j); c := LENG j; c := LENG i / c; tstlr (351, LENG i, c * LENG j); c := LENG i; d := LENG j; c := c / d; tstlr (352, LENG i, c * LENG j) FI OD OD; tstr (353, -1e+0, 1.9e-7 / -1.9e-7); a := 19.74e+2; tstr (354, +1e+0, 19.74e+2 / a); tstr (355, +10e-5, 19.74e-2 / 19.74e+2); tstr (356, +1e+3, 127000.0 / x); tstr (357, +1e+2, x / 1.27); tstr (358, -1e+1, x / -12.7); tstr (359, +1e+0, x / x); a := 1270.0; tstr (360, +10e-2, x / a); a := 0.0149; tstr (361, +1e+0, a / 149e-4); tstr (362, +1e+0, a / a); tstr (363, +1.173228346456693e-4, a / x); tstr (364, -1e-2, a / -1.49); tstr (365, +1.27e+2, -x / -1.0); tstr (366, -1e+0, -x / x); tstr (367, -8.523489932885906e+3, -x / a); tstr (368, +1e+0, -x / -x) END; print (("Test: **", newline)); BEGIN INT a; tsti (369, +1, 1 ** 0); tsti (370, +1, 10 ** 0); tsti (371, +1, -20 ** 0); tsti (372, +1, 1 ** 1); tsti (373, +10, 10 ** 1); tsti (374, -10, -10 ** 1); tsti (375, +0, 0 ** 1); tsti (376, +0, 0 ** 30000); tsti (377, +1, 0 ** 0); tsti (378, +49, 7 ** 2); tsti (379, +1, 1 ** 2); tsti (380, +9, -3 ** 2); tsti (381, -27, -3 ** 3); tsti (382, +32, 2 ** 5); tsti (383, +81, SHORTEN (LONG 9 ** 2)); tsti (384, -19683, SHORTEN (-LONG 27 ** 3)); tstr (385, +2.7e+1, 3.0 ** 3); tstr (386, +6.5536e+4, 2.0 ** 16); tstr (387, -3.2768e+4, -2.0 ** 15); tstr (388, +3.6e+1, -6.0 ** 2); tstr (389, +2.5e-1, 2.0 ** -2); tstr (390, -10e-4, -10.0 ** -3); tstr (391, +1e+0, 3.0 ** -0); tstr (392, +1e+0, 3.0 ** -0); tstr (393, +4.9e+1, SHORTEN (LONG 7.0 ** 2)); tstr (394, +3.969e+1, SHORTEN (-LONG 6.3 ** 2)); tstr (395, +1.385019350059107e-8, SHORTEN (LONG 37.3 ** -5)); a := 1; FOR i FROM 1 BY 1 TO 10 DO tsti (396, a, (-1) ** (i - 1)); a := -a OD; a := 0; FOR i FROM 1 BY 1 TO 10 DO a := a + 1 ** 30000 OD; tsti (397, +10, a) END; print (("Test: SHORTEN, LENG", newline)); BEGIN LONG INT a1 = LONG 128; LONG INT a2; LONG REAL a3 = LONG 1.9999999999; LONG REAL a4; REAL a6; INT a5; a5 := 30000; a6 := 2 / 3; tstli (398, +LONG 179, LENG 179); tsti (399, +19, SHORTEN LONG 19); tsti (400, +30000, SHORTEN LONG 30000); tsti (401, -27, SHORTEN -LONG 27); tsti (402, -30000, SHORTEN -LONG 30000); tsti (403, +128, SHORTEN a1); a2 := LONG 0; tsti (404, +0, SHORTEN a2); tsti (405, +30000, SHORTEN LENG a5); tstr (406, +1.234566666e-1, SHORTEN LONG 0.1234566666); tstr (407, +1.9999999999e+0, SHORTEN a3); a4 := LONG 0.1111111111; tstr (408, +1.111111111e-1, SHORTEN a4); tstr (409, -3.333333333333333e-1, SHORTEN -LENG (1 / 3)); tstr (410, +6.666666666666667e-1, SHORTEN LENG a6) END; print (("Test: ODD", newline)); BEGIN IF ODD -1 THEN SKIP ELSE tste (411) FI; tstb (412, FALSE, ODD 2); IF NOT ODD -LONG 2 THEN SKIP ELSE tste (413) FI; tstb (414, TRUE, ODD LONG 1); BOOL a1, a2; a1 := FALSE; FOR i FROM -10 BY 1 TO 10 DO tstb (415, a1, ODD i); a1 := NOT a1 OD; a1 := ODD -3; a2 := ODD -LONG 0; BOOL b1 = NOT ODD -13; BOOL b2 = NOT NOT ODD -LONG 16; tstb (416, TRUE, a1); tstb (417, FALSE, a2); tstb (418, FALSE, b1); tstb (419, FALSE, b2); tstb (420, FALSE, NOT NOT NOT ODD 55); tstb (421, FALSE, NOT NOT NOT ODD LONG 1) END; print (("Test: SIGN", newline)); BEGIN tsti (422, +1, SIGN 7); tsti (423, +0, SIGN 0); tsti (424, -1, SIGN -7); tsti (425, +1, SIGN LONG 1000000000); tsti (426, +0, SIGN LONG 0); tsti (427, -1, SIGN -LONG 8); tsti (428, +1, SIGN 1.9); tsti (429, +0, SIGN 0.0); tsti (430, -1, SIGN -3.6); tsti (431, +1, SIGN LONG 67.0); tsti (432, +0, SIGN LONG 0.0); tsti (433, -1, SIGN -LONG 37.0) END; print (("Test: ROUND, ENTIER", newline)); BEGIN REAL a1 = 1.7; LONG REAL a2 = LONG 27.7; REAL a3; LONG REAL a4; tstli (434, -LONG 28, LENG ROUND -27.7); tstli (435, -LONG 28, LENG ENTIER -27.7); tstli (436, +LONG 2, LENG ROUND a1); tstli (437, +LONG 1, LENG ENTIER a1); tstli (438, +LONG 13, LENG ROUND 12.9); tstli (439, +LONG 12, LENG ENTIER 12.994); a3 := 134e+2; a4 := LONG 135.1e-1; tstli (440, +LONG 13400, LENG ROUND a3); tstli (441, +LONG 13400, LENG ENTIER a3); tstli (442, +LONG 14, LENG ROUND SHORTEN a4); tstli (443, +LONG 13, LENG ENTIER SHORTEN a4); tstli (444, -LONG 1, ROUND -LENG 127e-2); tstli (445, +LONG 1, ENTIER --LONG 127e-2); tstli (446, +LONG 28, ROUND a2); tstli (447, +LONG 27, ENTIER a2); tstli (448, +LONG 13, ROUND LONG 12.87); tstli (449, +LONG 12, ENTIER LONG 12.87); tstli (450, +LONG 14, ROUND a4); tstli (451, +LONG 13, ENTIER a4); tstli (452, -LONG 2, ROUND -LONG 1.5001); tstli (453, -LONG 2, ENTIER -LENG 1.5001); tstli (454, +LONG 6, LENG ROUND 6.499) END; print (("Test: EQ, NE, LT, LE, GT, GE for chars", newline)); BEGIN CHAR a = "1"; CHAR b = "2"; CHAR c; c := "1"; [1 : 1] CHAR d; d[1] := "$"; INT abs0 = ABS "0", abs1 = ABS "1", abs2 = ABS "2"; tstb (455, TRUE, "1" = "1"); tstb (456, FALSE, "1" /= "1"); tstb (457, TRUE, "1" <= "1"); tstb (458, FALSE, "1" < "1"); tstb (459, TRUE, "1" >= "1"); tstb (460, FALSE, "1" > "1"); tstb (461, FALSE, "1" = "2"); tstb (462, TRUE, "1" /= "2"); tstb (463, TRUE, "1" <= "2"); tstb (464, TRUE, "1" < "2"); tstb (465, FALSE, "1" >= "2"); tstb (466, FALSE, "1" > "2"); tstb (467, FALSE, "2" = "1"); tstb (468, TRUE, "2" /= "1"); tstb (469, FALSE, "2" <= "1"); tstb (470, FALSE, "2" < "1"); tstb (471, TRUE, "2" >= "1"); tstb (472, TRUE, "2" > "1"); tstb (473, TRUE, a = a); tstb (474, FALSE, a /= a); tstb (475, TRUE, a <= a); tstb (476, FALSE, a < a); tstb (477, TRUE, a >= a); tstb (478, FALSE, a > a); tstb (479, FALSE, a = b); tstb (480, TRUE, a /= b); tstb (481, TRUE, a <= b); tstb (482, TRUE, a < b); tstb (483, FALSE, a >= b); tstb (484, FALSE, a > b); tstb (485, FALSE, b = a); tstb (486, TRUE, b /= a); tstb (487, FALSE, b <= a); tstb (488, FALSE, b < a); tstb (489, TRUE, b >= a); tstb (490, TRUE, b > a); tstb (491, TRUE, REPR abs1 = REPR abs1); tstb (492, FALSE, REPR abs1 /= REPR abs1); tstb (493, TRUE, REPR abs1 <= REPR abs1); tstb (494, FALSE, REPR abs1 < REPR abs1); tstb (495, TRUE, REPR abs1 >= REPR abs1); tstb (496, FALSE, REPR abs1 > REPR abs1); tstb (497, FALSE, REPR abs1 = REPR abs2); tstb (498, TRUE, REPR abs1 /= REPR abs2); tstb (499, TRUE, REPR abs1 <= REPR abs2); tstb (500, TRUE, REPR abs1 < REPR abs2); tstb (501, FALSE, REPR abs1 >= REPR abs2); tstb (502, FALSE, REPR abs1 > REPR abs2); tstb (503, FALSE, REPR abs2 = REPR abs1); tstb (504, TRUE, REPR abs2 /= REPR abs1); tstb (505, FALSE, REPR abs2 <= REPR abs1); tstb (506, FALSE, REPR abs2 < REPR abs1); tstb (507, TRUE, REPR abs2 >= REPR abs1); tstb (508, TRUE, REPR abs2 > REPR abs1); tstb (509, TRUE, REPR abs1 = c); tstb (510, FALSE, REPR abs1 /= c); tstb (511, TRUE, REPR abs1 <= c); tstb (512, FALSE, REPR abs1 < c); tstb (513, TRUE, REPR abs1 >= c); tstb (514, FALSE, REPR abs1 > c); tstb (515, FALSE, REPR abs0 = c); tstb (516, TRUE, REPR abs0 /= c); tstb (517, TRUE, REPR abs0 <= c); tstb (518, TRUE, REPR abs0 < c); tstb (519, FALSE, REPR abs0 >= c); tstb (520, FALSE, REPR abs0 > c); tstb (521, FALSE, REPR abs2 = c); tstb (522, TRUE, REPR abs2 /= c); tstb (523, FALSE, REPR abs2 <= c); tstb (524, FALSE, REPR abs2 < c); tstb (525, TRUE, REPR abs2 >= c); tstb (526, TRUE, REPR abs2 > c); tstb (527, TRUE, c = REPR abs1); tstb (528, FALSE, c /= REPR abs1); tstb (529, TRUE, c <= REPR abs1); tstb (530, FALSE, c < REPR abs1); tstb (531, TRUE, c >= REPR abs1); tstb (532, FALSE, c > REPR abs1); tstb (533, FALSE, c = REPR abs0); tstb (534, TRUE, c /= REPR abs0); tstb (535, FALSE, c <= REPR abs0); tstb (536, FALSE, c < REPR abs0); tstb (537, TRUE, c >= REPR abs0); tstb (538, TRUE, c > REPR abs0); tstb (539, FALSE, c = REPR abs2); tstb (540, TRUE, c /= REPR abs2); tstb (541, TRUE, c <= REPR abs2); tstb (542, TRUE, c < REPR abs2); tstb (543, FALSE, c >= REPR abs2); tstb (544, FALSE, c > REPR abs2); tstb (545, TRUE, "$" = d[1]); tstb (546, FALSE, "$" /= d[1]); tstb (547, TRUE, "$" <= d[1]); tstb (548, FALSE, "$" < d[1]); tstb (549, TRUE, "$" >= d[1]); tstb (550, FALSE, "$" > d[1]); tstb (551, TRUE, "$" = d[1]) END ENDalgol68g-2.8/test-set/a68g.mc.032.coer04.a680000644000175000001440000000074612224301223014552 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer04# BEGIN # Coercion error, a unit is not a coercend # [] STRUCT (INT i, BOOL j) k = ((1), (TRUE)); SKIP END algol68g-2.8/test-set/a68g.mc.162.stan02.a680000644000175000001440000000736612224301273014603 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #stan02# BEGIN # Standard I/O # INT i = 1, INT ii := 1, REAL r = 1.0, CHAR c = "a", STRING s = "a"; # 10.3.1.2. Channels # CHANNEL ch = stand out channel; print(("10.3.1.2. Channels", newline)); print((estab possible(ch), newline)); print((estab possible(stand in channel), newline)); print((estab possible(stand out channel), newline)); print((estab possible(stand back channel), newline)); print(newline); # 10.3.1.3. Files # FILE f := stand out; PROC p = (REF FILE f) BOOL : TRUE # event routine #; PROC q = (REF FILE f, REF CHAR c) BOOL : TRUE # ch err #; print(("10.3.1.3. Files", newline)); print((get possible(f), newline)); print((put possible(f), newline)); print((bin possible(f), newline)); print((compressible(f), newline)); print((reset possible(f), newline)); print((set possible(f), newline)); print((reidf possible(f), newline)); print((estab possible(chan(f)), newline)); print(((make term(f, s); "make term"), newline)); print(((on logical file end(f, p); "on logical file end"), newline)); print(((on physical file end(f,p); "on physical file end"), newline)); print(((on page end(f, p); "on page end"), newline)); print(((on line end(f, p); "on line end"), newline)); print(((on format end(f, p); "on format end"), newline)); print(((on value error(f, p); "on value error"), newline)); print(((on char error(f, q); "on char error"), newline)); IF reidf possible(f) THEN print(((reidf(f, s); "reidf"), newline)) ELSE print(("no reidf", newline)) FI; print(newline); # 10.3.1.4. Opening and closing files # print(("10.3.1.4. Opening and closing files", newline)); print((establish(f, "a", ch, 1, 1, 1), newline)); print((create(f, ch), newline)); print((open(f, "b", ch), newline)); print(newline); # 10.3.1.5. Position enquiries # print(("10.3.1.5. Position enquiries", newline)); print((char number(f), newline)); print((line number(f), newline)); print((page number(f), newline)); print(newline); # 10.3.1.6. Layout routines # print(("10.3.1.6. Layout routines", newline)); print(((space(f); "space"), newline)); print(((backspace(f); "backspace"), newline)); print(((newline(f); "newline"), newline)); print(((newpage(f); "newpage"), newline)); IF set possible(f) THEN print(((set(f, 1, 1, 1); "set"), newline)) ELSE print(("no set", newline)) FI; IF reset possible(f) THEN print(((reset(f); "reset"), newline)) ELSE print(("no reset", newline)) FI; print(((set char number(f, 1); "set char number"), newline)); print(newline); # 10.3.2.1. Conversion routines # print((whole(r, i), newline)); print((whole(i, i), newline)); print((fixed(r, i, i), newline)); print((fixed(i, i, i), newline)); print((float(r, i, i, i), newline)); print((float(i, i, i, i), newline)); print((char in string(c, ii, s), newline)); print((int width, newline)); print((real width, newline)); print((exp width, newline)); print(newline); # 10.5.1. The particular prelude # print(("10.5.1. The particular prelude", newline)); print(((last random:= 1968; random), newline)); print((get possible(stand in), newline)); print((get possible(stand out), newline)); print((get possible(stand back), newline)); write(("write", newline)); print(((read(LOC [1:0] CHAR); "read"), newline)); stop END algol68g-2.8/test-set/a68g.mc.050.flex02.a680000644000175000001440000000142312224301225014551 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #flex02# BEGIN # Transiency tests, all OK # BOOL b = TRUE, y = FALSE; print(( IF b THEN LOC CHAR ELSE (LOC STRING)[1] FI:= "a", newline)); print(( IF b THEN LOC[1:3]CHAR ELSE (LOC STRING)[] FI:= "bcd", newline)); print(( IF y THEN LOC STRING ELSE LOC[1:1,1:3]CHAR FI:= "efg", newline)) # a bcd efg # END algol68g-2.8/test-set/a68g.mc.164.stow01.a680000644000175000001440000000270112224301273014617 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #stow01# BEGIN print (("Results must be:", newline, FALSE, TRUE, TRUE, FALSE, newline, 1, 1, TRUE, TRUE, newline, 2, 2, FALSE, FALSE, newline, newline, 1, newline, 2, 1, 2, newline, 3, 2, 3, newline, [] COMPL ((0, 0), (1, 1), (0, 0)), newline, newline, "Results are:", newline)); [1 : 2] PROC BOOL i; INT j; i[1] := BOOL: j = 2; i[2] := BOOL: j = 1; j := 1; print (i[1]); print (i[2]); j := 2; print (i[1]); print (i[2]); print (newline); [] STRUCT (INT i, BOOL j) k = ((1, TRUE), (2, FALSE)); FOR i TO UPB k DO print (((i OF k)[i], i OF k[i], (j OF k)[i], j OF k[i], newline)) OD; print (newline); print (a OF (STRUCT (INT a, b) s = (1, 0); s)); print (newline); [2 : 3] INT cc; print ((LWB cc, LWB cc[ : ], LWB cc[])); print (newline); print ((UPB cc, UPB cc[ : ], UPB cc[])); print (newline); [1 : 3] COMPL r := (0, (0, 1), 1); re OF r := im OF r; print (r); SKIP ENDalgol68g-2.8/test-set/a68g.mc.123.oper14.a680000644000175000001440000000301012224301255014561 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper14# BEGIN print (("Results must be:", newline, 4, 5, 5, 4, newline, 1, 2, 2, newline, 1, 1, 1, newline, 2, 1, 3, newline, 1, newline, 1, 1, 1, 1, newline, newline, "Results are:", newline)); print ((UPB [] INT (1, 2, 3, 4), UPB "abcde", UPB [] INT (SKIP, SKIP)[1 : 1@5], 2 UPB [, ] INT (1, 2)[, @4])); print (newline); # All declarers are of the mode row-of, so UPB/LWB should work # print ((UPB UNION ([] INT, [, ] INT) ([] INT (1)), UPB UNION ([] INT, [, ] INT) ([, ] INT (1, 1)), UPB UNION ([] STRING, STRING) ("ab"))); print (newline); print ((LWB UNION ([] INT, [, ] INT) ([] INT (1)), LWB UNION ([] INT, [, ] INT) ([, ] INT (1, 1)), LWB UNION ([] STRING, STRING) ("ab"))); print (newline); FOR i TO 3 DO print (i UPB [, , ] CHAR ("abc", "def")) OD; print (newline); print (LWB LOC STRING LWB LOC STRING); print (newline); # Balance # FOR n TO 4 DO print (n UPB CASE n IN [] INT (1), [, ] REAL (1), UNION ([] INT, [, , ] BOOL) ([, , ] BOOL (TRUE)), UNION ([] INT, UNION ([, ] REAL, [, , , ] CHAR)) ([, , , ] CHAR ("a")) ESAC) OD ENDalgol68g-2.8/test-set/a68g.mc.022.clau03.a680000644000175000001440000000344612224301221014542 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #clau03# BEGIN # Wrong clauses # INT i:= 1, BOOL b:= TRUE; UNION (INT, BOOL, REAL) ibr = SKIP; print(( i | 1, 2 |: i | 3, 4)); #OK# print(( i | 1 2 |: i | 3, 4)); #KO# print(( b | 1 2 |: i | 3, 4)); #KO# print(( b | 1 2 |: b | 3, 4)); #KO# print(( b | 1 2 |: b | 3 4)); #OK# print(( i | 1, 2 |: b | 3 4)); #KO# print(( i | 1, 2 |( b | 3 4))); #OK# print(( ibr | (INT): 1, (BOOL): 2 |: ibr | (REAL): 3 | 4)); #OK# print(( ibr | (INT): 1, 2 |: ibr | (REAL): 3 | 4)); #KO# print(( ibr | 1, (BOOL): 2 |: ibr | (REAL): 3 | 4)); #KO# print(( ibr | (INT): 1, (BOOL): 2 |: ibr | 3 | 4)); #KO# print(( ibr | (INT): 1, (BOOL): 2 |: b | 3 | 4)); #KO# print(( ibr | (INT): 1, (BOOL): 2 |( b | 3 | 4))); #OK# print(CASE ibr IN (INT):1, (BOOL):2 OUT 3 ESAC); #OK# print(CASE 1 IN (INT):1, (BOOL):2 OUT 3 ESAC); #KO# print(CASE "a" IN (INT):1, (BOOL):2 OUT 3 ESAC); #KO# CASE CASE ibr IN (UNION (INT, BOOL) ib) : ib ESAC IN (BOOL) : ibr ESAC; #OK# CASE CASE ibr IN (UNION (INT, REAL) ir) : ir ESAC IN (BOOL) : ibr ESAC; #KO# SKIP END algol68g-2.8/test-set/a68g.ur.194.r72a.a680000644000175000001440000010526012224301310014263 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r72a # (print (("identification a : identifiers from :", newline, "identity declaration,variable,case on union,loop index", newline)); INT nbcas = 9; INT vf = 11 * (48 + 5 * nbcas); INT ctr := 0, ctrt; MODE M = STRUCT (CHAR c, INT de), UNE = UNION (STRING, INT); # procedures de controle # PROC ce = (INT a, b) VOID: (a = b | ctr +:= 1 | print (("test n0", ctrt, " error :", a, b, newline))); PROC t = (M de, INT vrai) VOID: ce (de OF de, vrai); # declarations de servitude # INT valk := 0 - 1, [] UNE rune = ("vide", "", 1, SKIP); OP - = (UNE a) INT: (a | (STRING): 0, (INT a): 0 - a), STRUCT (UNE deux, STRUCT (UNE de) de) de := (0, (STRUCT (UNE de) of; de OF of := rune[2]; of)); # declarations et tests initiaux # # bloc 0 # M j = ("m", 109); M i = ("m", 108); M h := ("m", 107); M g = ("m", 106); M f = ("m", 105); M e = ("m", 104); M d = ("m", 103); M c := ("m", 102); M b = ("m", 101); M a := ("m", 100); INT k = 999; ctrt := 1; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 104); t (d, 103); t (c, 102); t (b, 101); t (a, 100); IF # bloc 1 # M b = ("m", 111); M c := ("m", 112); ctrt := 2; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 104); t (d, 103); t (c, 112); t (b, 111); t (a, 100); FALSE THEN SKIP ELIF # bloc 2 # UNE declident = (# bloc 3 # M c = ("m", 122); M d := ("m", 123); ctrt := 3; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 104); t (d, 123); t (c, 122); t (b, 111); t (a, 100) # fin 3 # ; ""); UNE declvariable := (# bloc 3 # M c = ("m", 222); M d := ("m", 223); ctrt := 4; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 104); t (d, 223); t (c, 222); t (b, 111); t (a, 100); (# bloc 4 # M d = ("m", 233); M e := ("m", 234); ctrt := 5; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 234); t (d, 233); t (c, 222); t (b, 111); t (a, 100) # fin 4 # ; "") # fin 3 # ); M c = ("m", 322); M d := ("m", 323); ctrt := 6; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 104); t (d, 323); t (c, 322); t (b, 111); t (a, 100); TRUE THEN # bloc 3 # ctrt := 7; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 104); t (d, 323); t (c, 322); t (b, 111); t (a, 100); CASE # bloc 4 # M valu = ("m", 345); UNION (UNE, M, STRUCT (CHAR c, INT d)) u := valu; M d = ("m", 333); M e := ("m", 334); ctrt := 8; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 334); t (d, 333); t (c, 322); t (b, 111); t (a, 100); e := ("m", 344); u IN ( # bloc 5 # M f): ((ctrt := 9; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 345); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100)), (# bloc 6 # M f = ("m", 355); M g := ("m", 356); ctrt := 10; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 356); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); FOR # bloc 7 # k FROM (M g = ("m", 466); M h := ("m", 467); ctrt := 11; ce (k, 999); t (j, 109); t (i, 108); t (h, 467); t (g, 466); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); 0) TO nbcas WHILE # bloc 8 # valk +:= 1; M g = ("m", 366); M h := ("m", 367); ctrt := 12; ce (k, valk); t (j, 109); t (i, 108); t (h, 367); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); TRUE DO # bloc 9 # M h = ("m", 377); M i := ("m", 378); ctrt := 13; ce (k, valk); t (j, 109); t (i, 378); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); CASE # bloc 10 # M i = ("m", 388); M j := ("m", 389); ctrt := 14; ce (k, valk); t (j, 389); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); k IN #k=1# (# bloc 11 # M j = ("m", 199); ctrt := 15; ce (k, valk); t (j, 199); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100) # fin 11 # ), #k=2# TO (M j = ("m", 299); ctrt := 16; ce (k, valk); t (j, 299); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); 1) DO ctrt := 17; ce (k, valk); t (j, 389); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100) OD, #k=3# (M j = ("m", 399); ctrt := 18; ce (k, valk); t (j, 399); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); HEAP UNE) := (M j = ("m", 499); ctrt := 19; ce (k, valk); t (j, 499); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); ""), #k=4# (M j = ("m", 599); ctrt := 20; ce (k, valk); t (j, 599); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); rune)[2 : (M j = ("m", 699); ctrt := 21; ce (k, valk); t (j, 699); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); 3)@(M j = ("m", 799); ctrt := 22; ce (k, valk); t (j, 799); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); 1)], #k=5# ((UNE x, y) VOID: (M j = ("m", 899); ctrt := 23; ce (k, valk); t (j, 899); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100))) ((M j = ("m", 999); ctrt := 24; ce (k, valk); t (j, 999); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); ""), SKIP), #k=6# LOC UNE :=: (M j = ("m", 1099); ctrt := 25; ce (k, valk); t (j, 1099); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); HEAP UNE), #k=7# 1 + -(M j = ("m", 1199); ctrt := 26; ce (k, valk); t (j, 1199); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); ""), #k=8# de OF de OF (M j = ("m", 1299); ctrt := 27; ce (k, valk); t (j, 1299); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); de), #k=9# UNE (M j = ("m", 1399); ctrt := 28; ce (k, valk); t (j, 1399); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); "") OUT # bloc 11 # # k=0 # M j = ("m", 1499); ctrt := 29; ce (k, valk); t (j, 1499); t (i, 388); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100) # fin 11 # # fin 10 # ESAC; IF # bloc 10 # ctrt := 30; ce (k, valk); t (j, 109); t (i, 378); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); k = 1 THEN # bloc 11 # M i = ("m", 88); M j := ("m", 89); ctrt := 31; ce (k, valk); t (j, 89); t (i, 88); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); CASE # bloc 12 # UNE u := (ctrt := 32; ce (k, valk); t (j, 89); t (i, 88); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); ""); u IN (INT): SKIP OUSE # bloc 13 # M j = ("m", 99); ctrt := 33; ce (k, valk); t (j, 99); t (i, 88); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100); u IN (STRING): (ctrt := 34; ce (k, valk); t (j, 99); t (i, 88); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100)) # fin 13 # # fin 12 # ESAC; ctrt := 35; ce (k, valk); t (j, 89); t (i, 88); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100) # fin 11 # # fin 10 # FI; ctrt := 36; ce (k, valk); t (j, 109); t (i, 378); t (h, 377); t (g, 366); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100) # fin 9 # # fin 8 # # fin 7 # OD; ctrt := 37; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 356); t (f, 355); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100) # fin 6 # ), (ctrt := 38; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 345); t (e, 344); t (d, 333); t (c, 322); t (b, 111); t (a, 100))) # fin 5 # # fin 4 # ESAC; ( # bloc 4 # UNE u = (ctrt := 39; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 104); t (d, 323); t (c, 322); t (b, 111); t (a, 100); ""); u | (INT): SKIP | # bloc 5 # M d = ("m", 433); M e := ("m", 434); ctrt := 40; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 434); t (d, 433); t (c, 322); t (b, 111); t (a, 100); ( # bloc 6 # [(# bloc 7 # M e = ("m", 444); M f := ("m", 445); ctrt := 41; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 445); t (e, 444); t (d, 433); t (c, 322); t (b, 111); t (a, 100); 0 # fin 7 # ) : 0] UNE u; LWB u < UPB u | SKIP | # bloc 7 # M e = ("m", 544); M f := ("m", 545); ctrt := 42; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 545); t (e, 544); t (d, 433); t (c, 322); t (b, 111); t (a, 100); ( # bloc 8 # 0 | 1, SKIP |: # bloc 9 # M f = ("m", 555); M g := ("m", 556); ctrt := 43; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 556); t (f, 555); t (e, 544); t (d, 433); t (c, 322); t (b, 111); t (a, 100); 2 | SKIP, (ctrt := 44; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 556); t (f, 555); t (e, 544); t (d, 433); t (c, 322); t (b, 111); t (a, 100)) # fin 9 # # fin 8 # ); ctrt := 45; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 545); t (e, 544); t (d, 433); t (c, 322); t (b, 111); t (a, 100) # fin 7 # # fin 6 # ); ctrt := 46; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 434); t (d, 433); t (c, 322); t (b, 111); t (a, 100) # fin 5 # # fin 4 # ); ctrt := 47; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 104); t (d, 323); t (c, 322); t (b, 111); t (a, 100) # fin 3 # # fin 2 # # fin 1 # FI; ctrt := 48; ce (k, 999); t (j, 109); t (i, 108); t (h, 107); t (g, 106); t (f, 105); t (e, 104); t (d, 103); t (c, 102); t (b, 101); t (a, 100) # fin 0 # ; print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.028.clau09.a680000644000175000001440000000370312224301222014553 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #clau09# # Optimisation correct ? # BEGIN print ((newline, "Prints errors only", newline)); PROC puti = (INT i, INT p, q) VOID: IF p /= q THEN print ((i, p, q)) FI; PROC putr = (INT i, REAL p, q) VOID: IF p /= q THEN print ((i, p, q)) FI; BEGIN [1 : 3] INT a; a[1] := 2; a[2] := 3; a[3] := 1; putr (1, 44.9104, (-1.0 + (-2.0 + (-3.0 + (-4.0 + 2)))) + ((-5.0 + (-2.0 - (-5.0 + (-2.0 - 7)))) - (a[a[a[a[a[2]]]]] + (a[a[a[a[a[1]]]]] - (a[a[a[a[a[3]]]]] + ((-1.0 * (-2.0 * (-3.0 * (-4.0 * 2)))) - ((-5.0 * (-2.0 * (-5.0 * (-2.0 * 7)))) * (128 * (-1.0 / (-2.0 / (-4.0 / (-4.0 / 2)))) / ((-10.0 / (-5.0 / (-5.0 / (-2.0 / 2)))) ** a[a[a[a[a[2]]]]] ** a[a[a[a[a[1]]]]] ** a[a[a[a[a[3]]]]]))))))))) END; BEGIN REAL x; [1 : 20] REAL a; FOR i FROM 1 BY 1 TO 20 DO a[i] := i - 10 OD; x := a[1] + (a[2] + (a[3] + (a[4] + (a[5] + (a[6] + (a[7] + (a[8] + (a[9] + (a[10] + (a[11] + (a[12] + (a[13] + (a[14] + (a[15] + (a[16] + (a[17] + (a[18] + (a[19] + (a[20]))))))))))))))))))) - 9.0; putr (2, 1.0, x) END; BEGIN [1 : 10] INT a; FOR i FROM 1 BY 1 TO 9 DO a[i] := i + 1 OD; a[10] := 1; FOR i FROM 1 BY 1 TO 10 DO puti (3, i, a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[i]]]]]]]]]]]]]]]]]]]]) OD END; print ((newline, "End of tests", newline)) ENDalgol68g-2.8/test-set/a68g.mc.151.smio01.a680000644000175000001440000000621112224301262014564 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio01# formatless transput: BEGIN #Formatless tests- create a file write on the file read the file The reading of the file should produce the same info as was written# FILE ti,to; #Use a channel with bi-directional properties# establish(ti, "ti", stand back channel, 10, 60, 136); to:= ti; # 'to' is now open; use it# #try something# [1:100] INT rj; INT j:= 505; REAL x:= 3.14159; COMPL c:= (2.01, 3.10); BOOL t:= TRUE; FOR i TO UPB rjDO rj[i]:=iOD; put (to, (newpage, newline, j,x,c,t,rj)); #try characters# put(to, ("*" # no preceding space#, newline, "*" #no preceding space again#)); put(to, (newline, "*", backspace, "x" #overwrite the *#)); #try string# STRING s:= "i am a string", s2:= "me too"; put(to, (newline, s)); TO UPB s DO backspace(to)OD; put(to, s2); backspace(to); put(to,s2); #write over last character# # yields "me tome toong" # #now let's check the file# reset(ti);# we have filled "to" and shall read from "ti" # [1:UPB rj] INT rj2; INT j2; REAL x2; COMPL c2; BOOL t2; STRING u,u2; get(ti,(newpage,newline,j2,x2,c2,t2,rj2)); FOR i TO UPB rj DO (rj[i] /= rj2[i] | print(("Error1", rj[i] - rj2[i], newline))) OD; IF j/=j2 OR x/=x2 OR c/=c2 OR t/= t2 THEN print(("Error2", x, x2, c, c2, t, t2, x-x2, c-c2, t=t2, newline)) FI; CHAR char1, char2; get(ti,(char1,newline,char2)); IF char1/= "*" OR char2/= "*" THEN print(("Error3", char 1, char 2, newline)) FI; get(ti,(newline, char1, backspace, char2)); IF char1 /= char2 OR char2 /= "x" THEN print(("Error4", char 1, char 2, newline)) FI; [] CHAR char5 = ("m","e"," ","t","o", "m", "e", " ", "t", "o", "o", "n", "g"); [1:UPB char5] CHAR char6; get(ti,(newline, char6 #at end of file#)); FOR i TO UPB char 5 DO (char5[i] /= char6[i] | print(("Error5", ABS char 5[i], ABS char 6[i], newline))) OD; #test EOF-stuff# on logical file end(ti,(REF FILE f)BOOL:okay); get(ti, char1); #should cause call to 'logical file end' to be generated # #if we continue here, then there was an error# print(("Error6", newline)); okay: print(("End of test",newline)) END algol68g-2.8/test-set/a68g.ur.196.r811.a680000644000175000001440000001452412224301311014210 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r811 # (print (("integral denotations", newline)); INT vf = 258; INT ctr := 0; PROC e = (INT a, b) VOID: (a = b | ctr +:= 1 | print (("er int", a, b, newline))); e (1 + 255, 256); e (1 + 256, 257); e (1 + 4095, 4096); e (1 + 10000, 10001); e (1 + 32768, 32769); e (1 - 255, -254); e (1 - 256, -255); e (1 - 4095, -4094); e (1 - 10000, -9999); e (1 - 32768, -32767); e (1 * 255, 255); e (1 * 256, 256); e (1 * 4095, 4095); e (1 * 10000, 10000); e (1 * 32768, 32768); e (0 + 255, 255); e (0 + 256, 256); e (0 + 4095, 4095); e (0 + 10000, 10000); e (0 + 32768, 32768); e (0 - 255, -255); e (0 - 256, -256); e (0 - 4095, -4095); e (0 - 10000, -10000); e (0 - 32768, -32768); e (0 * 255, 0); e (0 * 256, 0); e (0 * 4095, 0); e (0 * 10000, 0); e (0 * 32768, 0); e (0000 + 255, 255); e (0000 + 256, 256); e (0000 + 4095, 4095); e (0000 + 10000, 10000); e (0000 + 32768, 32768); e (0000 - 255, -255); e (0000 - 256, -256); e (0000 - 4095, -4095); e (0000 - 10000, -10000); e (0000 - 32768, -32768); e (0000 * 255, 0); e (0000 * 256, 0); e (0000 * 4095, 0); e (0000 * 10000, 0); e (0000 * 32768, 0); e (4 + 255, 259); e (4 + 256, 260); e (4 + 4095, 4099); e (4 + 10000, 10004); e (4 + 32768, 32772); e (4 - 255, -251); e (4 - 256, -252); e (4 - 4095, -4091); e (4 - 10000, -9996); e (4 - 32768, -32764); e (4 * 255, 1020); e (4 * 256, 1024); e (4 * 4095, 16380); e (4 * 10000, 40000); e (4 * 32768, 131072); e (10 + 255, 265); e (10 + 256, 266); e (10 + 4095, 4105); e (10 + 10000, 10010); e (10 + 32768, 32778); e (10 - 255, -245); e (10 - 256, -246); e (10 - 4095, -4085); e (10 - 10000, -9990); e (10 - 32768, -32758); e (10 * 255, 2550); e (10 * 256, 2560); e (10 * 4095, 40950); e (10 * 10000, 100000); e (10 * 32768, 327680); e (16 + 255, 271); e (16 + 256, 272); e (16 + 4095, 4111); e (16 + 10000, 10016); e (16 + 32768, 32784); e (16 - 255, -239); e (16 - 256, -240); e (16 - 4095, -4079); e (16 - 10000, -9984); e (16 - 32768, -32752); e (16 * 255, 4080); e (16 * 256, 4096); e (16 * 4095, 65520); e (16 * 10000, 160000); e (16 * 32768, 524288); e (64 + 255, 319); e (64 + 256, 320); e (64 + 4095, 4159); e (64 + 10000, 10064); e (64 + 32768, 32832); e (64 - 255, -191); e (64 - 256, -192); e (64 - 4095, -4031); e (64 - 10000, -9936); e (64 - 32768, -32704); e (64 * 255, 16320); e (64 * 256, 16384); e (64 * 4095, 262080); e (64 * 10000, 640000); e (64 * 32768, 2097152); e (00011 + 255, 266); e (00011 + 256, 267); e (00011 + 4095, 4106); e (00011 + 10000, 10011); e (00011 + 32768, 32779); e (00011 - 255, -244); e (00011 - 256, -245); e (00011 - 4095, -4084); e (00011 - 10000, -9989); e (00011 - 32768, -32757); e (00011 * 255, 2805); e (00011 * 256, 2816); e (00011 * 4095, 45045); e (00011 * 10000, 110000); e (00011 * 32768, 360448); e (255 + 1, 256); e (255 + 0, 255); e (255 + 0000, 255); e (255 + 4, 259); e (255 + 10, 265); e (255 + 16, 271); e (255 + 64, 319); e (255 + 00011, 266); e (255 - 1, 254); e (255 - 0, 255); e (255 - 0000, 255); e (255 - 4, 251); e (255 - 10, 245); e (255 - 16, 239); e (255 - 64, 191); e (255 - 00011, 244); e (255 * 1, 255); e (255 * 0, 0); e (255 * 0000, 0); e (255 * 4, 1020); e (255 * 10, 2550); e (255 * 16, 4080); e (255 * 64, 16320); e (255 * 00011, 2805); e (256 + 1, 257); e (256 + 0, 256); e (256 + 0000, 256); e (256 + 4, 260); e (256 + 10, 266); e (256 + 16, 272); e (256 + 64, 320); e (256 + 00011, 267); e (256 - 1, 255); e (256 - 0, 256); e (256 - 0000, 256); e (256 - 4, 252); e (256 - 10, 246); e (256 - 16, 240); e (256 - 64, 192); e (256 - 00011, 245); e (256 * 1, 256); e (256 * 0, 0); e (256 * 0000, 0); e (256 * 4, 1024); e (256 * 10, 2560); e (256 * 16, 4096); e (256 * 64, 16384); e (256 * 00011, 2816); e (4095 + 1, 4096); e (4095 + 0, 4095); e (4095 + 0000, 4095); e (4095 + 4, 4099); e (4095 + 10, 4105); e (4095 + 16, 4111); e (4095 + 64, 4159); e (4095 + 00011, 4106); e (4095 - 1, 4094); e (4095 - 0, 4095); e (4095 - 0000, 4095); e (4095 - 4, 4091); e (4095 - 10, 4085); e (4095 - 16, 4079); e (4095 - 64, 4031); e (4095 - 00011, 4084); e (4095 * 1, 4095); e (4095 * 0, 0); e (4095 * 0000, 0); e (4095 * 4, 16380); e (4095 * 10, 40950); e (4095 * 16, 65520); e (4095 * 64, 262080); e (4095 * 00011, 45045); e (10000 + 1, 10001); e (10000 + 0, 10000); e (10000 + 0000, 10000); e (10000 + 4, 10004); e (10000 + 10, 10010); e (10000 + 16, 10016); e (10000 + 64, 10064); e (10000 + 00011, 10011); e (10000 - 1, 9999); e (10000 - 0, 10000); e (10000 - 0000, 10000); e (10000 - 4, 9996); e (10000 - 10, 9990); e (10000 - 16, 9984); e (10000 - 64, 9936); e (10000 - 00011, 9989); e (10000 * 1, 10000); e (10000 * 0, 0); e (10000 * 0000, 0); e (10000 * 4, 40000); e (10000 * 10, 100000); e (10000 * 16, 160000); e (10000 * 64, 640000); e (10000 * 00011, 110000); e (32768 + 1, 32769); e (32768 + 0, 32768); e (32768 + 0000, 32768); e (32768 + 4, 32772); e (32768 + 10, 32778); e (32768 + 16, 32784); e (32768 + 64, 32832); e (32768 + 00011, 32779); e (32768 - 1, 32767); e (32768 - 0, 32768); e (32768 - 0000, 32768); e (32768 - 4, 32764); e (32768 - 10, 32758); e (32768 - 16, 32752); e (32768 - 64, 32704); e (32768 - 00011, 32757); e (32768 * 1, 32768); e (32768 * 0, 0); e (32768 * 0000, 0); e (32768 * 4, 131072); e (32768 * 10, 327680); e (32768 * 16, 524288); e (32768 * 64, 2097152); e (32768 * 00011, 360448); e (1 + 131001, 131002); e (1 + 1000000000, 1000000001); e (1 + 2147483646, 2147483647); e (1 - 131001, -131000); e (1 - 1000000000, -999999999); e (1 - 2147483646, -2147483645); e (1 * 131001, 131001); e (1 * 1000000000, 1000000000); e (1 * 2147483646, 2147483646); e (131001 + 1, 131002); e (131001 - 1, 131000); e (131001 * 1, 131001); e (1000000000 + 1, 1000000001); e (1000000000 - 1, 999999999); e (1000000000 * 1, 1000000000); e (2147483646 + 1, 2147483647); e (2147483646 - 1, 2147483645); e (2147483646 * 1, 2147483646); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.007.appl07.a680000644000175000001440000000630012224301216014555 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl07# BEGIN # Tag list algorithm # MODE TAG = STRUCT (STRING tag, REF TAG chain, REF INFO info); [1 : 11] STRUCT (INT number, REF TAG chain) hashlist; FOR i TO UPB hashlist DO hash list[i] := (0, NIL) OD; PROC find tag = (STRING tag) REF INFO: BEGIN REF STRUCT (INT number, REF TAG chain) handle = hash list[(INT h := 0; FOR i TO UPB tag DO h := (2 * h + ABS tag[i]) MOD UPB hashlist OD; h + 1)]; REF REF TAG ptag := chain OF handle; WHILE IF ptag :=: REF TAG (NIL) THEN REF REF TAG (ptag) := HEAP TAG := (tag, NIL, HEAP INFO); FALSE ELIF tag OF ptag < tag THEN ptag := chain OF ptag; TRUE ELIF tag OF ptag = tag THEN FALSE ELSE REF TAG (ptag) := (tag, HEAP TAG := ptag, HEAP INFO); FALSE FI DO SKIP OD; info OF ptag END # find tag # ; PROC lex order = (PROC (STRING, INFO) VOID act) VOID: ([1 : UPB hashlist] REF TAG entry := chain OF hashlist; WHILE REF REF TAG entry1 := NIL; FOR i TO UPB entry DO REF REF TAG entry i = entry[i]; IF entry i :/=: REF TAG (NIL) THEN IF (entry1 :=: REF REF TAG (NIL) | TRUE | tag OF entry i < tag OF entry1) THEN entry1 := entry i FI FI OD; entry1 :/=: REF REF TAG (NIL) DO act (tag OF entry1, info OF entry1); REF REF TAG (entry1) := chain OF entry1 OD); COMMENT PROC test = VOID : (print(("Debug;", newline)); FOR i TO UPB hashlist DO REF TAG rrt:= chain OF hashlist[i]; WHILE rrt ISNT REF TAG (NIL) DO print((tag OF rrt, info OF rrt, newline)); rrt:= chain OF rrt OD; print(("End hash;", newline)) OD; print(("End debug;", newline)) ); COMMENT MODE INFO = INT; find tag ("aap") := 1; find tag ("noot") := 4; find tag ("mies") := 3; find tag ("wim") := 5; find tag ("zus") := 6; find tag ("jet") := 2; print (find tag ("aap")); print (find tag ("jet")); print (find tag ("mies")); print (find tag ("noot")); print (find tag ("wim")); print (find tag ("zus")); print (newline); lex order ((STRING st, INFO i) VOID: print ((st, i, newline))) ENDalgol68g-2.8/test-set/a68g.mc.075.jump05.a680000644000175000001440000000421312224301231014575 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #jump05# BEGIN # Test stack jump in ALGOL 68, Dick Grune, 24-07-73. A bit-pattern is decomposed on the stack into a sequence of PROC VOID's, the bit-pattern is re-assembled by calling the deepest PROC VOID and the resulting pattern is compared to the original. # INT max width = 12; # Additional BITS-operators # INT conv = bits width - max width; BITS one = BIN 1 SHL (bits width - 1); OP SET = (INT i, REF BITS rb) REF BITS: rb := rb OR one SHR (i - 1); OP NEXT = (BITS b) BITS: BIN (ABS (b SHR conv) + 1) SHL conv; PRIO SET = 9; BITS max bits = BIN (2 ** max width - 1) SHL conv; # End # PROC dive = (INT level, PROC VOID back) VOID: (IF level > max width THEN back ELSE dive (level + 1, IF level ELEM bits THEN here ELSE back FI) FI; here: level SET acc; back) # dive # ; # Try all (4096) bit-patterns # BITS bits # proposed pattern # := BIN 0, acc # assembled pattern # ; INT cnt := 0; WHILE acc := BIN 0; (dive (1, out); out: SKIP # it just happened # ); IF bits NE acc THEN print (("Stack jump test failed. Bits: ", bits, " acc: ", acc, newline)); stop FI; bits NE max bits # WHILE # DO bits := NEXT bits; cnt +:= 1 OD; IF cnt /= 2 ** max width - 1 THEN print (("Something wrong", cnt, 2 ** max width - 1)); stop FI; print (("Stack jump test successful", newline)) ENDalgol68g-2.8/test-set/a68g.mc.036.coer08.a680000644000175000001440000000157212224301223014560 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer08# BEGIN # Soft balance # print ((HEAP REAL x := 3.14; CASE 3 IN SKIP, IF x < 0 THEN GOTO stop ELSE REF [] REAL: NIL FI, IF x > 0 THEN x ELSE x +:= 1 FI ESAC := pi)[1]) # 3.14159265...# ENDalgol68g-2.8/test-set/a68g.mc.025.clau06.a680000644000175000001440000000074012224301222014543 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #clau06# BEGIN # Vacuum # [] INT i = (); print (i[1]) # runtime error, subscript overflow # ENDalgol68g-2.8/test-set/a68g.mc.159.smio10.a680000644000175000001440000000265212224301263014602 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio10# # Binary transput of structure # BEGIN STRING alphabet = "abcdefghijklmnopqrstuvwxyz"; INT size = 1000; [0 : size] STRUCT (CHAR c, REAL r) str; FOR i FROM 0 TO UPB str DO str[i] := (alphabet[i MOD 26 + 1], 1 / (i + 1)) OD; putbin (standback, str); print (("File written", newline)); reset (standback); print (("File rewound", newline)); getbin (standback, str); print (("File read", newline)); BOOL bad := FALSE; FOR i FROM 0 TO UPB str DO bad := bad OR IF c OF str[i] /= alphabet[i MOD 26 + 1] THEN print (("Char bad in struct ", whole (i, 0), ", char is ", c OF str[i], ", char must be ", alphabet[i MOD 26 + 1], newline)); TRUE ELIF r OF str[i] /= 1 / (i + 1) THEN print (("Real bad in struct ", whole (i, 0), ", real is ", r OF str[i], ", real must be ", 1 / (i + 1), newline)); TRUE ELSE FALSE FI OD; IF NOT bad THEN print ("Contents of file correct") FI ENDalgol68g-2.8/test-set/a68g.mc.141.simp06.a680000644000175000001440000000444512224301260014576 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp06# bits bytes strings and other noise: BEGIN #Don't just stand there, do something!# print (("The following are some of the environment enquiries", newline)); print (("integer", int lengths, max int, newline, "real ", real lengths, max real, small real, newline, "bits ", bits lengths, bits width, newline, "bytes ", bytes lengths, bytes width, newline, "null character """, nullcharacter, """", ABS null character, newline, newline)); #bits# BITS a := BIN 63 #i.e., 6 ones in a row# ; BITS b := BIN 1; print (#Let's add them and see what happens# ("Addition of two BITS quantities", newline, ABS a, ABS b, newline, "Answer should be: ")); STRING s := IF bits width > 6 THEN "64" ELSE "0" FI; BITS c := BIN (ABS a + ABS b); print ((s, newline, "Answer is", ABS c, newline, newline)); IF 2r111111 = BIN 63 THEN SKIP ELSE print ("Error in BIN things") FI; # reduced bytes test # #bytes are fixed-length strings# BYTES s1 := bytes pack ("ab"); [1 : bytes width] CHAR cs; #to contain what the answer should be# cs[1 : byteswidth] := s1; s := "ab"; FOR i TO bytes width DO IF IF i <= UPB s THEN s[i] ELSE null character FI /= cs[i] THEN print (("Bytes fault, values are: ", i, cs, STRING (s1))) ELSE print (("Character", i, " okay", newline)) FI OD; print (newline) # Print all character values print("All character values, in lines of 64 "); FOR i FROM 0 TO max abs char DO IF i MOD 64 = 0 THEN print((newline, whole(i, -4), "-", whole(i+63, -4), " ")) FI; print(REPR i) OD # ENDalgol68g-2.8/test-set/a68g.mc.060.idef04.a680000644000175000001440000000130112224301227014522 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef04# BEGIN INT i = 1, j = -1; PROC a = VOID: (INT i = 2, j = -2; b); PROC b = VOID: (INT j = -3; PROC c = VOID: print (i + j); d (c)); PROC d = (PROC VOID e) VOID: (INT i = 4, j = -4; e); a # -2 # ENDalgol68g-2.8/test-set/a68g.mc.069.idrl01.a680000644000175000001440000000117312224301231014555 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idrl01# BEGIN # Identity relations # REAL x; REF REAL y := x; print ((x :=: y, y :=: x, newline)) # TRUE, TRUE # ; print ((x :=: REF [] REAL (x)[1], newline)) # TRUE # ; print ((x :=: REF [] REAL (x), newline)) # FALSE # ENDalgol68g-2.8/test-set/a68g.mc.117.oper08.a680000644000175000001440000000174512224301254014603 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper08# (# A complicated formula relying totally on priorities # OP I = (INT i, j) COMPL: (i, j); OP ** = (INT i, COMPL z) INT: ROUND (i + RE z + IM z); OP < = (INT i, j) INT: (i - j) * 2; OP = = (INT i, j) INT: (i + j) * 2; OP AND = (INT i, j) INT: (i + i - j) * 3; OP OR = (INT i, j) INT: (i - j - j) * 3; INT loc int; # Note: all operators are followed by their priorities # print ((loc int := 0) -:= 1 OR 2 AND 3 = 4 < 5 + 6 * 7 ** 8 I 9 -:= 1 ** 8 OR 2 * 7 AND 3 + 6 = 4 < 5) # The implied parenthesis structure is : (1(2(3(4(5(6(7(8(9)))))))))1((8)2((7)3((6)4(5)))) and it yields 10650 # )algol68g-2.8/test-set/a68g.mc.065.idef09.a680000644000175000001440000000155512224301230014541 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef09# (# Obscuring LWB and UPB # print (("Should not run", newline)); (OP LWB = (INT i) INT: 1; LWB [] REAL (1) # OK # ); (OP UPB = ([] INT i) INT: 1; UPB [] REAL (1) # KO # ); (OP LWB = (REF [] INT i) INT: 1; LWB [] REAL (1) # KO # ); (OP UPB = (REF UNION ([] INT, [] BOOL) i) INT: 1; UPB [] REAL (1) # KO # ); (OP LWB = (REF UNION (REF [] INT, [] BOOL) i) INT: 1; LWB [] REAL (1) # OK # ); (OP UPB = (UNION (REF [] INT, [] BOOL) i) INT: 1; UPB [] REAL (1) # KO # ); SKIP)algol68g-2.8/test-set/a68g.mc.008.appl08.a680000644000175000001440000002721512224301217014570 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl08# rat: # Dik Winter, 141075# BEGIN #Handling of rationals# MODE RAT = STRUCT (INT n, d); #Preliminary routines# OP GCD = (INT i, j) INT: IF i = 0 THEN ABS j ELIF j = 0 THEN ABS i ELSE INT ii := ABS i, jj := ABS j, k; ll: k := ii - ii % jj * jj; ii := jj; jj := k; IF jj = 0 THEN ii ELSE ll FI FI; PRIO GCD = 8; OP / = (INT i, j) RAT: BEGIN INT k = i GCD j; IF j >= 0 THEN (i % k, j % k) ELSE (-i % k, -j % k) FI END; OP INV = (INT i) RAT: IF i >= 0 THEN (1, i) ELSE (-1, -i) FI; #Basic operators# OP INV = (RAT q) RAT: IF n OF q >= 0 THEN (d OF q, n OF q) ELSE (-d OF q, -n OF q) FI; OP + = (RAT q) RAT: q; OP - = (RAT q) RAT: (-n OF q, d OF q); OP ABS = (RAT q) RAT: (ABS n OF q, d OF q); OP + = (RAT q, p) RAT: BEGIN INT k = d OF q GCD d OF p; INT dq = d OF q % k, dp = d OF p % k; INT n = n OF q * dp + n OF p * dq; INT l = n GCD k, d = dp * dq; (n % l, k % l * d) END; OP - = (RAT q, p) RAT: BEGIN INT k = d OF q GCD d OF p; INT dq = d OF q % k, dp = d OF p % k; INT n = n OF q * dp - n OF p * dq; INT l = n GCD k, d = dp * dq; (n % l, k % l * d) END; OP * = (RAT q, p) RAT: BEGIN INT nq = n OF q, np = n OF p; INT dq = d OF q, dp = d OF p; INT i = nq GCD dp, j = np GCD dq; ((nq % i) * (np % j), (dq % j) * (dp % i)) END; OP / = (RAT q, p) RAT: BEGIN INT nq = n OF q, np = n OF p; INT dq = d OF q, dp = d OF p; INT i = nq GCD np, j = dp GCD dq; IF np >= 0 THEN ((nq % i) * (dp % j), (dq % j) * (np % i)) ELSE (-(nq % i) * (dp % j), -(dq % j) * (np % i)) FI END; OP +:= = (REF RAT q, RAT p) REF RAT: BEGIN INT k = d OF q GCD d OF p; INT dq = d OF q % k, dp = d OF p % k; INT n = n OF q * dp + n OF p * dq; INT l = n GCD k, d = dp * dq; q := (n % l, k % l * d) END; OP -:= = (REF RAT q, RAT p) REF RAT: BEGIN INT k = d OF q GCD d OF p; INT dq = d OF q % k, dp = d OF p % k; INT n = n OF q * dp - n OF p * dq; INT l = n GCD k, d = dp * dq; q := (n % l, k % l * d) END; OP *:= = (REF RAT q, RAT p) REF RAT: BEGIN INT nq = n OF q, np = n OF p; INT dq = d OF q, dp = d OF p; INT i = nq GCD dp, j = np GCD dq; q := ((nq % i) * (np % j), (dq % j) * (dp % i)) END; OP /:= = (REF RAT q, RAT p) REF RAT: BEGIN INT nq = n OF q, np = n OF p; INT dq = d OF q, dp = d OF p; INT i = nq GCD np, j = dp GCD dq; q := IF np >= 0 THEN ((nq % i) * (dp % j), (dq % j) * (np % i)) ELSE (-(nq % i) * (dp % j), -(dq % j) * (np % i)) FI END; #Rationals mixed with integers# OP + = (RAT q, INT i) RAT: (n OF q + d OF q * i, d OF q); OP - = (RAT q, INT i) RAT: (n OF q - d OF q * i, d OF q); OP * = (RAT q, INT i) RAT: BEGIN INT dq = d OF q; INT k = dq GCD i; (i % k * n OF q, dq % k) END; OP / = (RAT q, INT i) RAT: BEGIN INT nq = n OF q; INT k = nq GCD i; IF i >= 0 THEN (nq % k, i % k * d OF q) ELSE (-nq % k, -i % k * d OF q) FI END; OP +:= = (REF RAT q, INT i) REF RAT: q := (n OF q + d OF q * i, d OF q); OP -:= = (REF RAT q, INT i) REF RAT: q := (n OF q - d OF q * i, d OF q); OP *:= = (REF RAT q, INT i) REF RAT: BEGIN INT dq = d OF q; INT k = dq GCD i; q := (i % k * n OF q, dq % k) END; OP /:= = (REF RAT q, INT i) REF RAT: BEGIN INT nq = n OF q; INT k = nq GCD i; q := IF i >= 0 THEN (nq % k, i % k * d OF q) ELSE (-nq % k, -i % k * d OF q) FI END; OP + = (INT i, RAT q) RAT: (i * d OF q + n OF q, d OF q); OP - = (INT i, RAT q) RAT: (i * d OF q - n OF q, d OF q); OP * = (INT i, RAT q) RAT: BEGIN INT dq = d OF q; INT k = dq GCD i; (i % k * n OF q, dq % k) END; OP / = (INT i, RAT q) RAT: BEGIN INT nq = n OF q; INT k = nq GCD i; IF nq >= 0 THEN (i % k * d OF q, nq % k) ELSE (-i % k * d OF q, -nq % k) FI END; #Rationals mixed with reals# OP VAL = (RAT q) REAL: REAL (n OF q) / REAL (d OF q); OP + = (REAL r, RAT q) REAL: r + VAL q; OP - = (REAL r, RAT q) REAL: r - VAL q; OP * = (REAL r, RAT q) REAL: r * VAL q; OP / = (REAL r, RAT q) REAL: r / VAL q; OP +:= = (REF REAL r, RAT q) REF REAL: r +:= VAL q; OP -:= = (REF REAL r, RAT q) REF REAL: r -:= VAL q; OP *:= = (REF REAL r, RAT q) REF REAL: r *:= VAL q; OP /:= = (REF REAL r, RAT q) REF REAL: r /:= VAL q; OP + = (RAT q, REAL r) REAL: VAL q + r; OP - = (RAT q, REAL r) REAL: VAL q - r; OP * = (RAT q, REAL r) REAL: VAL q * r; OP / = (RAT q, REAL r) REAL: VAL q / r; #Comparing rationals# OP = = (RAT q, p) BOOL: n OF q = n OF p AND d OF q = d OF p; OP /= = (RAT q, p) BOOL: n OF q /= n OF p OR d OF q /= d OF p; OP >= = (RAT q, p) BOOL: n OF q * d OF p >= n OF p * d OF q; OP > = (RAT q, p) BOOL: n OF q * d OF p > n OF p * d OF q; OP < = (RAT q, p) BOOL: n OF q * d OF p < n OF p * d OF q; OP <= = (RAT q, p) BOOL: n OF q * d OF p <= n OF p * d OF q; #Comparing rationals with integers# OP = = (RAT q, INT i) BOOL: n OF q = i AND d OF q = 1; OP /= = (RAT q, INT i) BOOL: n OF q /= i OR d OF q /= 1; OP >= = (RAT q, INT i) BOOL: n OF q >= i * d OF q; OP > = (RAT q, INT i) BOOL: n OF q > i * d OF q; OP < = (RAT q, INT i) BOOL: n OF q < i * d OF q; OP <= = (RAT q, INT i) BOOL: n OF q <= i * d OF q; OP = = (INT i, RAT q) BOOL: i = n OF q AND d OF q = 1; OP /= = (INT i, RAT q) BOOL: i /= n OF q OR d OF q /= 1; OP >= = (INT i, RAT q) BOOL: i * d OF q >= n OF q; OP > = (INT i, RAT q) BOOL: i * d OF q > n OF q; OP < = (INT i, RAT q) BOOL: i * d OF q < n OF q; OP <= = (INT i, RAT q) BOOL: i * d OF q <= n OF q; #Comparing rationals with reals# OP = = (REAL r, RAT q) BOOL: r = VAL q; OP /= = (REAL r, RAT q) BOOL: r /= VAL q; OP >= = (REAL r, RAT q) BOOL: r >= VAL q; OP > = (REAL r, RAT q) BOOL: r > VAL q; OP < = (REAL r, RAT q) BOOL: r < VAL q; OP <= = (REAL r, RAT q) BOOL: r <= VAL q; OP = = (RAT q, REAL r) BOOL: VAL q = r; OP /= = (RAT q, REAL r) BOOL: VAL q /= r; OP >= = (RAT q, REAL r) BOOL: VAL q >= r; OP > = (RAT q, REAL r) BOOL: VAL q > r; OP < = (RAT q, REAL r) BOOL: VAL q < r; OP <= = (RAT q, REAL r) BOOL: VAL q <= r; #Converting rationals to a number string# PROC rat = (RAT q, INT width) STRING: IF STRING s = (q < 0 | "-(" |: width > 0 | "+(" | "(") + whole (ABS n OF q, 0) + "/" + whole (d OF q, 0) + ")"; width = 0 THEN s ELSE IF INT us = UPB s, aw = ABS width; us > aw THEN aw * (q < 0 | "-" | "+") ELSE (aw - us) * " " + s FI FI; #Innerproduct of two arrays of rationals# OP +* = (REF [] RAT a, b) RAT: BEGIN RAT s := (0, 1); FOR i TO UPB a DO s +:= a[i] * b[i] OD; s END; #LU-decomposition of a matrix of rationals# PROC decrat = (REF [, ] RAT a, REF [] INT p) VOID: BEGIN INT n = 1 UPB a; FOR k TO n DO RAT piv := (0, 1), INT k1 := k - 1; REF INT pk = p[k]; REF [] RAT aik = a[, k], aki = a[k, ]; FOR i FROM k TO n DO aik[i] -:= a[i, 1 : k1] +* aik[1 : k1]; IF piv = 0 AND aik[i] /= 0 THEN piv := aik[i]; pk := i FI OD; IF piv = 0 THEN print ((newline, newline, "Singular matrix")); stop FI; IF pk /= k THEN FOR i TO n DO RAT r = aki[i]; aki[i] := a[pk, i]; a[pk, i] := -r OD FI; FOR i FROM k + 1 TO n DO aki[i] -:= aki[1 : k1] +* a[1 : k1, i] /:= piv OD OD END; #Calculation of the determinant of a decomposed matrix# PROC determrat = (REF [, ] RAT a) RAT: BEGIN RAT d := (1, 1); FOR i TO 1 UPB a DO d *:= a[i, i] OD; d END; FOR n TO 5 DO [1 : n, 1 : n] RAT a; FOR i TO n DO a[i, i] := INV (i * 2 - 1); FOR j FROM i + 1 TO n DO a[i, j] := a[j, i] := INV (i + j - 1) OD OD; decrat (a, LOC [1 : n] INT); print (("Order: ", whole (n, -1), "; determinant: ", rat (determrat (a), 0), newline)) OD ENDalgol68g-2.8/test-set/a68g.mc.009.appl09.a680000644000175000001440000000371112224301217014565 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl09# BEGIN # Bubble sort, ALGOL 68 version # PROC sort = (REF [] INT a) VOID: BEGIN INT p = LWB a; FOR dp FROM p + 1 TO UPB a DO INT bp := dp; INT bubble = a[bp]; WHILE INT prev; IF bp = p THEN FALSE ELSE prev := a[bp - 1]; prev > bubble FI DO a[bp] := prev; bp -:= 1 OD; a[bp] := bubble OD END # sort # ; PROC shuffle = (REF [] INT a) VOID: BEGIN INT p = LWB a, q = UPB a; FOR i FROM q BY -1 TO p + 1 DO REF INT t = a[ENTIER (random * (i - p + 1)) + p], u = a[i]; INT h = t; t := u; u := h # swap # OD END # shuffle # ; INT max = 8; [1 : max] INT p; PROC test = (PROC (INT) INT a) VOID: (FOR i TO max DO p[i] := a (i) OD; shuffle (p); print (("Shuffled:", newline, p, newline)); sort (p); print (("Sorted:", newline, p, newline, newline))); test ((INT p) INT: p); test ((INT p) INT: ENTIER (p / 5)); test ((INT p) INT: 0) ENDalgol68g-2.8/test-set/a68g.mc.053.garb01.a680000644000175000001440000000112012224301226014523 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #garb01# BEGIN # Test garbage collector # TO 1000 DO HEAP [1000] REAL OD; print (("collections, garbage, collect seconds:", newline)); print ((collections, garbage, collect seconds, newline)) ENDalgol68g-2.8/test-set/a68g.mc.082.misc01.a680000644000175000001440000000172612224301232014556 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #misc01# BEGIN # Comments # print("Should print 1:"); INT i:= 1; #huppeldepupCO i:= 2; CO puppup # print(i) #1# ; print(newline); #Denotation, test precision# IF 3.14159265358979323846264338327 /= pi THEN print("3.14159265358979323846264338327 /= pi") FI; print(newline); #Denotations # print( ( "0 to 3:", 0, 1, 02, 000000000000000000003, newline, 01.02, .0102, 01.02e0, .0102e0, newline, 01 0 . 2e -0 1, 0102e-04, 01.02e-0000000000000000000000000, .0102e+00, newline, "T", "h", "e", " above two lines ", "should be id" "entical. ", """did that work?""")) END algol68g-2.8/test-set/a68g.mc.122.oper13.a680000644000175000001440000000316112224301255014566 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper13# BEGIN # Operator test, illegal # OP +=<== (INT a) INT :-a; # bad # OP <==(INTi) INT : -i; # <= is dyadic only # OP +==(INTa,b,c)INT:1; # incorrect # OP +==:=(INTa,b,c)INT:1; # incorrect # OP ===(INTa)INT:1; # incorrect # OP ==:=(INTa)INT:1; # incorrect # # The ##= is intended as the "differs from symbol" which is not available in the Standard Hardware Representation # INTa,b; (a:=b); # correct, assignation # (a:##=b); # correct, label, mon. op # (a:/=b); # incorrect # (a:=:b); # correct, IS # (a:##=:b); # correct, ISNT # (a:/=:b); # correct, ISNT # (a:=:=b); # incorrect # (a:##=:=b); # correct, label, mon. op # (a:/=:=b); # incorrect # OP +:= = (INT a,b) INT : a+b; OP +:= = (INT a, REAL b) INT :ROUND(a-b); UNION(INT, REAL) i:= 1; print(2+:= i) # error, operator cannot be identified # END algol68g-2.8/test-set/a68g.mc.070.idrl02.a680000644000175000001440000000114712224301231014547 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idrl02# BEGIN REAL a; a :=: (l); # correct, l = REF REAL # a :=: l; # incorrect, l is a unit, not a tertiary # l: SKIP; IF INT i, j, k, l; i:=:j AND k:=:l # illegal formula # THEN SKIP FI END algol68g-2.8/test-set/a68g.mc.023.clau04.a680000644000175000001440000000147312224301221014542 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #clau04# BEGIN # Vacuum # print (LWB [] INT BEGIN END); #1# print (UPB [] INT ()); #0# print (UPB ([] INT ())[1 : 0]); #0# print (2 UPB [, ] INT ([] INT (print ("here "); ()))); #0# print (1 UPB [, ] INT ([] INT (print ("there"); ()))); #1# print (2 UPB [, ] INT (())); #0# print (2 UPB [, ] INT ((), (1))) # runtime error, wrong length # ENDalgol68g-2.8/test-set/a68g.mc.062.idef06.a680000644000175000001440000000261312224301227014535 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef06# BEGIN # Operators # STRING int = "INT ", real = "REAL ", rreal = "[]REAL"; PROC (REF FILE) VOID n = newline; print (("Results must be:", n, int, 1, n, real, 1.0, n, rreal, 1.0, n, real, 3.0, n, rreal, 3.0, n, rreal, 2.0, n, rreal, 2.0, n, int, 3, n, real, 3.0, n, rreal, 3.0, n, real, 4.0, n, rreal, 4.0, n, real, 4.0, n, rreal, 4.0, n, n, "Results are:", n)); OP AA = (UNION (INT, REAL, [] REAL) p) UNION (REAL, [] REAL): CASE p IN (INT i): (print ((int, i, n)); AA REAL (i)), (REAL r): (print ((real, r, n)); AA [] REAL (r)) OUSE print ((rreal, p, n)); p IN ([] REAL rr): CASE ROUND rr[1] IN 3.0, rr OUT 4.0 ESAC OUT error ESAC; FOR i TO 3 DO AA AA CASE i IN UNION (REAL, INT) (1), UNION (INT, [] REAL) ([] REAL (2)), AA 3 ESAC OD EXIT error: print ("Error in united-case-clause") ENDalgol68g-2.8/test-set/a68g.mc.124.oper15.a680000644000175000001440000000104612224301255014572 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper15# BEGIN # Incorrect, since not all declarers are of the mode row-of # print(UPB UNION ([] INT, BOOL) ([] INT (1))); print(LWB UNION (REF [,] STRING, STRING) ("ab")) END algol68g-2.8/test-set/a68g.mc.179.synt08.a680000644000175000001440000001050512224301275014640 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #synt08# # Straight from the key punch; where does it get stuck? # BEGIN FILE program; # contains the program# establist(program,"program", z type channel,1,10000,80); FILE result; # will centain the mineed program# establish(result,"result", z type channel, 1810000,80); INT line width = 72; INT c pos:= 0, STRING line; CHAR quote= """", bold= REPR 39 # apostrophe #, PROC in item STRING: (STRING st= in item or comment; comment(st) | skip comment(st); in item| st); >PROC comment= (STRING s) BOOL: s= "#" OR s= bold + "co" OR s= bold + "co" + bold OR s= bold + "comment" FOR s= bold + "comment" + bold; PROC skip comment= (STRING s) BOOL: WHILE in item 2/= s DO OD; PROC in item2= STRING: BEGIN more real input; CHAR ch= line[c pos]; STRUCT(STRING item, INT new pos) res:= IF letter(ch) THEN INT p= last(letgit); (line[c pos: p], p+1) ELIF ch= quote >THEN INT p= last ((CHAR c) BOOL: cf= quote); (line[cpos: p] q quote, p+2) ELIF digit(ch) THEN INT p= last (digit); nline[c pos: p], p + 1) >ELIF ch = bold THEN INT p= last (letgit); (line[c pos: pb q bold, p q (p = UPB line| 1 |: line[p+1] = bold| 2 | 1)) ELIF indicant (ch) >THEN INT p = last (indicant); (line[c pos: p], p + 1) ELSE (line[c pos], cpos + 1) FI; c pos:= new pos OF res; item OF res END # in item 2 #; PROC last = (PROC (CHAR) BOOL cond) INT: (INT p:= cpos; FOR d FROM cpos + 1 TO UPB line WHILE cond(line[d]) DO p=: d >OD ; p ); PROC letter= (CHAR ch) BOOL: "a" <= ch AND ch <= "z"; PROC digit= (CHAR ch) BOOL: "0" <= ch AND ch < = "9"; PROC letgit = (CHAR ch) BOOL: letter (ch) OR digit (ch); PROC indicant = (CHAR ch) BOOL: char in string (ch, "+-*/=<>:", LOC INT); >PROC move real input = VOID: (skip: cpos + := 1; IF c pos > UPB line THEN get line; skip FI; IF line [cpos]= " " THEN skip FI ); >PROC get line = VOID: nget(program, nnewline, line)); >if UPB line > line width THEN line:= line [1: linewidth] FI; cpos:= 0 ); >PROC out item= (STRING s) VOID: (IF char pos (result) + UPB s > line width >THEN newline (result) FI; put(result, s) ); # reading the program text # MODE TEXT = STRUCT (STRING string, REF TEXT next); >REF TEXT no text = NIL; REF TEXT first text:= no text, last text:= no text; on logical file end (program, (REF FILE f) BOOL rum); #initialize # get(program, line); DO # until end-of-file # STRING st= in item; last text:= (last text:=: no text| first text| next >OF last text):= HEAP TEXT= (st, no text) OD; run: DO # until input exhausted # INT mean= (INT i; read(i); i); MODE CHUNK= STRUCT (STRUCT (INT length, REF TEXT text) chunk, REF CHUNK next); REF CHUNK no chunk = NIL; REF CHUNK first chunk = no chun, last chunk = no chunk; INT n chunks:= 0; last text:= first text; WHILE last text :/=; no text DO INF cnt:= 0, REF TEXT p:= last text; TO range (2 * mean -1) DO (p:/=: no text y p;= next >OF p; cnt +:=1) >OD # determine chunk #; # enter into chunk chain # last chunk:= (last chunk:=: no chunk y first chunk | next OF last chunk):= HEAP >CHUNK ;= nncnt, last text), NIL); n chunk +:= 1; last text:= p OD # chunk chain ready #; # tie full-circle # next OF last chunk:= first chunk; # mix the chunks # FOR length FROM n chunks BY -1 TO 1 >DO TO range (length) DO first chunk:= next OF first chunk OD; # random chunk found, now write it # REF TEXT pd= text OF chunk OF next OF first chunk; >TO length OF chunk OF next OF first chunk DO out item (string OF p); p:= next OF p >OD ; # remove chunk # next FF first chunk:= next OF next OF first chunk >OD ; newline(resultef close (result); printf(($"produced" 4 zdx, "chunks of mean length" 3zdl$, n chunks, mean)); open (result, "result", z type channel) END END algol68g-2.8/test-set/a68g.mc.005.appl05.a680000644000175000001440000000777612224301215014572 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl05# BEGIN # Collateral sorting # PROC quicksort = (REF [] ITEM a) VOID: # quicksort requires the operator < to be defined for two ITEM's # IF INT m = LWB a, n = UPB a; m < n THEN STRUCT (INT left, right) l = # 'l' is a border running from 'left' to 'right' such that: 1. all elements left of the border are smaller than those right of the border, 2. the border contains at least one element. # BEGIN INT f = # random # ENTIER ((n - m + 1) * random + m); ITEM x = a[f]; PROC swap = (REF ITEM a, b) VOID: BEGIN ITEM h = a; a := b; b := h END; INT i := m, j := n; # a[m-1] < a[f] < a[n+1] # split: FOR k FROM i BY 1 TO n DO IF x < a[k] THEN i := k; end_left FI OD; i := n + 1; end_left: # a[f] < a[i] -> i /= f # FOR k FROM j BY -1 TO m DO IF a[k] < x THEN j := k; end_right FI OD; j := m - 1; end_right: # a[j] < a[f] -> f /= j # # a[j] < a[i] -> i /= j # IF i < j THEN swap (a[i], a[j]); i +:= 1; j -:= 1; split # i => j, i /= j -> i > j -> i - j > 0 # ELIF i < f THEN swap (a[i], a[f]); i +:= 1 # i - j > 1 # # i >= f, i /= f -> i > f # ELIF f < j THEN swap (a[f], a[j]); j -:= 1 # i - j > 1 # # f >= j, f /= j -> f > j; i>f,j>f -> i>f>j -> # # i-j > f-j > 0 -> i-j > 0 # FI; (j, i) # i - j > 1 # END; (quicksort (a[ : left OF l]), quicksort (a[right OF l : ])) FI; MODE ITEM = REAL; PROC test = (INT max) VOID: BEGIN [1 : max] REAL a; FOR i TO max DO a[i] := random OD; REAL time := clock; quicksort (a); time := clock - time; # print(("Sorted", max, " numbers, time taken", time, " sec., i. e.,", time / (max * ln(max) / ln(2)), " per n ln n.", newline)); # print (("Sorted", max, " numbers.", newline)); FOR i TO max - 1 DO IF a[i] > a[i + 1] THEN print ("Error ") FI OD END # test # ; test (100); test (1 000); test (10 000) ENDalgol68g-2.8/test-set/a68g.mc.027.clau08.a680000644000175000001440000001401012224301222014542 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #clau08# BEGIN stop; # no errors, but loops if not stopped here # # A: Statements in the context of a BEGIN block # BEGIN label: SKIP; l1: BEGIN SKIP; SKIP END; BEGIN GOTO label; GO TO label END; BEGIN INT a1, a2, a3; l4: FOR i FROM a1 BY a2 TO a3 DO SKIP OD; FOR i FROM a1 BY a2 TO a3 DO SKIP OD END; l2: BEGIN BOOL a; IF a THEN SKIP FI; l5: IF a THEN SKIP FI END; BEGIN PROC VOID a; l6: a; a END; l3: BEGIN PROC (INT) VOID a; INT b; a (b); l7: a (b) END; BEGIN REAL a; a := a; a := a END; BEGIN REF [] REAL a; INT i; l8: a[i] := i; a[i] := i END; BEGIN BEGIN SKIP END; BEGIN SKIP END END END; # B: Statements in the context of a ( block # (label: SKIP; l1: (SKIP; SKIP); (GOTO label; GO TO label); (INT a1, a2, a3; l4: FOR i FROM a1 BY a2 TO a3 DO SKIP OD; FOR i FROM a1 BY a2 TO a3 DO SKIP OD); l2: (BOOL a; IF a THEN SKIP FI; l5: IF a THEN SKIP FI); (PROC VOID a; l6: a; a); l3: (PROC (INT) VOID a; INT b; a (b); l7: a (b)); (REAL a; a := a; a := a); (REF [] REAL a; INT i; l8: a[i] := i; a[i] := i); ((SKIP); (SKIP))); # C: Statements in the context of IF statement # BEGIN BOOL true; IF true THEN SKIP; SKIP FI; IF true THEN SKIP ELSE SKIP; SKIP FI; IF true THEN IF true THEN SKIP FI FI; IF true THEN IF true THEN SKIP FI ELSE SKIP FI; IF true THEN IF true THEN SKIP ELSE SKIP FI FI; IF true THEN IF true THEN SKIP ELSE SKIP FI ELSE SKIP FI; IF true THEN SKIP ELSE IF true THEN SKIP FI FI; IF true THEN SKIP ELSE IF true THEN SKIP ELSE SKIP FI; IF true THEN SKIP FI; SKIP FI END; # D: Statements in the context of a FOR statement # BEGIN INT a1, a2, a3; BOOL true; PROC VOID proc1; PROC (INT) VOID proc2; REAL aa; REF [] REAL bb; FOR i FROM a1 BY a2 TO a3 DO SKIP; SKIP OD; FOR i FROM a1 BY a2 TO a3 DO GOTO stop; GOTO stop OD; FOR i FROM a1 BY a2 TO a3 DO IF true THEN SKIP FI; IF true THEN SKIP FI OD; FOR i FROM a1 BY a2 TO a3 DO FOR i FROM a1 BY a2 TO a3 DO SKIP OD; FOR i FROM a1 BY a2 TO a3 DO SKIP OD OD; FOR i FROM a1 BY a2 TO a3 DO proc1; proc1 OD; FOR i FROM a1 BY a2 TO a3 DO proc2 (a1); proc2 (a1) OD; FOR i FROM a1 BY a2 TO a3 DO aa := aa; aa := aa OD; FOR i FROM a1 BY a2 TO a3 DO bb[i] := a1; bb[i] := a1 OD; FOR i FROM a1 BY a2 TO a3 DO BEGIN SKIP END; BEGIN SKIP END OD END; # E: Statements in the context of a routine declaration # BEGIN BOOL true; INT a1, a2, a3; REF [] INT a4 = a1; REAL a5; PROC a = VOID: SKIP; PROC b = VOID: IF TRUE THEN SKIP FI; PROC c = VOID: FOR i FROM a1 BY a2 TO a3 DO SKIP OD; PROC d = VOID: d; PROC (INT) VOID e = (INT f) VOID: e (f); PROC f = VOID: a5 := a5; PROC g = VOID: a4[a1] := a1; PROC h = VOID: BEGIN SKIP END; SKIP END ENDalgol68g-2.8/test-set/a68g.mc.148.simp13.a680000644000175000001440000000134012224301261014573 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp13# BEGIN # continued fraction # OP / = ([] REAL a, b) REAL: (UPB a = 0 | 0 | a[1] / (b[1] + a[2 : ] / b[2 : ])), [1 : 20] REAL x, y; FOR i TO 20 DO x[i] := (i - 1) ** 2; y[i] := 2 * i - 1 OD; x[1] := 1; FOR i TO 20 DO print (4 * (x[1 : i] / y[1 : i])) OD # approximations of pi # ENDalgol68g-2.8/test-set/a68g.mc.044.decl03.a680000644000175000001440000000240512224301224014526 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #decl03# BEGIN # P.G. Hibbard, Proc. Int. Conf. A68 III, Winnipeg, June, 1974: applied occurrence of mode-indication in actual-bounds of its actual-declarer # INT n := 4; CHAR a := "a", b := "b", c := "c", d; PROC swap = (REF CHAR c1, c2) VOID: (d := c1; c1 := c2; c2 := d); MODE HANOI = [IF n > 0 THEN n -:= 1; swap (b, c); HANOI h1; swap (b, c); print ((newline, "move ", whole (LWB h1 + 1, -1), " from ", a, " to ", c, ".")); swap (a, b); HANOI h2; swap (a, b); n +:= 1 ELSE 0 FI : 1] INT; LOC HANOI ENDalgol68g-2.8/test-set/a68g.mc.111.oper02.a680000644000175000001440000000124412224301253014560 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper02# BEGIN # Operator # OP + = (UNION (INT, BOOL) a) INT: (a | (BOOL): 1, (INT): 2); print (+IF TRUE THEN TRUE ELSE 0 FI); # 1 # print (+IF FALSE THEN TRUE ELSE 0 FI) # 2 # ENDalgol68g-2.8/test-set/a68g.mc.046.decl05.a680000644000175000001440000000113212224301225014527 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #decl05# BEGIN # Application of a virtually useless mode # print (("Result should be: ppp", newline, newline)); MODE P = PROC (P) P; P p = (P p) P: (print ("p"); p); (p (p (p (p)))) ENDalgol68g-2.8/test-set/a68g.mc.163.stan03.a680000644000175000001440000001067312224301273014600 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #stan03# BEGIN # All format items # INT i = 2; UNION (INT, REAL) uir = 2; print (("10.3.4.1. Literals and insertions", newline)); printf (($dl$, 1)); printf (($ # comment # dl$, 1)); printf (($ CO comment CO dl$, 1)); printf (($ COMMENT comment COMMENT dl$, 1)); printf (($x2(d)l$, 1)); printf (($xkdl$, 1)); printf (($xxdl$, 1)); printf (($xydl$, 1)); printf (($xpdl$, 1)); printf (($xqdl$, 1)); printf (($x"one"dl$, 1)); printf (($x2"one"dl$, 1)); printf (($x"one"2"two"dl$, 1)); printf (($x"one""two"dl$, 1)); printf (($x"one"1"two"2x"three"dl$, 1)); printf (($x"one"1"two"2y"three"dl$, 1)); printf (($x"aa"n(i)ydl$, 1)); printf (($x"aa"nBEGIN i ENDydl$, 1)); printf (($x"aa"n(TRUE | i)ydl$, 1)); printf (($x"aa"nIF TRUE THEN i FIydl$, 1)); printf (($x"aa"n(i | i, i)ydl$, 1)); printf (($x"aa"nCASE i IN i, i ESACydl$, 1)); printf (($x"aa"n(uir | (INT): i)ydl$, 1)); printf (($x"aa"nCASE uir IN (INT): i ESACydl$, 1)); printf (($x"aa"n(HEAP INT := i)ydl$, 1)); printf (($x"Do not show"n(INT: jmp n)y"Do not show"dl$, 1)); jmp n: printf (($x"a"dl$, 1)); print (newline); print (("10.3.4.2. Integral patterns", newline)); printf (($xdl$, 1)); printf (($xsdl$, 1)); printf (($xzl$, 1)); printf (($xszl$, 1)); printf (($xzdzdl$, 1)); printf (($xz2dzdl$, 1)); printf (($xz2sdzdl$, 1)); printf (($xz2sdsz"a"dl$, 1)); printf (($xz+sdsz"a"dl$, 1)); print (newline); print (("10.3.4.3. Real patterns", newline)); printf (($xd.dl$, 1.0)); printf (($xds.dl$, 1.0)); printf (($xd"s"s.dl$, 1.0)); printf (($xd.l$, 1.0)); printf (($xd.de+dl$, 1.0)); printf (($xd.dse+dl$, 1.0)); printf (($xd.d"a"se+dl$, 1.0)); printf (($xd.e+dl$, 1.0)); printf (($xde+dl$, 1.0)); print (newline); print (("10.3.4.4. Boolean patterns", newline)); printf (($xbl$, TRUE)); print (newline); print (("10.3.4.5. Complex patterns", newline)); printf (($xd.did.dl$, COMPL (1, 1))); printf (($xd.dsid.dl$, COMPL (1, 1))); printf (($xd.d"a"sid.dl$, COMPL (1, 1))); print (newline); print (("10.3.4.6. String patterns", newline)); printf (($xaal$, "xx")); printf (($xasal$, "xx")); printf (($x2al$, "xx")); printf (($xa"a"sal$, "xx")); print (newline); print (("10.3.4.7. Bits patterns", newline)); printf (($x2rdl$, 2r1)); printf (($x4rdl$, 2r1)); printf (($x8rdl$, 2r1)); printf (($x16rdl$, 2r1)); printf (($x2rsdl$, 2r1)); printf (($x"a"2rdl$, 2r1)); print (newline); print (("10.3.4.8. Choice patterns", newline)); printf (($xc("a", CO c CO 2"a"1"p", "bcd")l$, 2)); printf (($x"z"c("a", CO c CO 2"a"1"p", "bcd")l$, 2)); printf (($xb("a", CO c CO 2"a"1"p")l$, FALSE)); printf (($x"z"b("a", CO c CO 2"a"1"p")l$, FALSE)); print (newline); print (("10.3.4.9. Format patterns", newline)); printf (($xf($dl$)$, 1)); printf (($xfIF TRUE THEN $dl$ FI$, 1)); printf (($xfCASE 1 IN $dl$, SKIP ESAC$, 1)); printf (($xfCASE uir IN (INT): $dl$ ESAC$, 1)); print (newline); print (("10.3.4.10. General patterns", newline)); printf (($xgl$, 1)); printf (($x"z"gl$, 1)); printf (($xg(2)l$, 1)); printf (($xg(4, 1)l$, 1)); printf (($xg(7, 1, 2)l$, 1)); printf (($xgl$, 1.0)); printf (($x"z"gl$, 1.0)); printf (($xg(2)l$, 1.0)); printf (($xg(4, 1)l$, 1.0)); printf (($xg(7, 1, 2)l$, 1.0)); printf (($xg(HEAP INT := 7, HEAP INT := 1, HEAP INT := 2)l$, 1)); printf (($x"Show"g(INT: jmp g)"Do not show"l$, 1)); jmp g: print (("End of show", newline)); SKIP ENDalgol68g-2.8/test-set/a68g.mc.174.synt03.a680000644000175000001440000000060112224301275014622 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #synt03# : algol68g-2.8/test-set/a68g.mc.093.null06.a680000644000175000001440000000060712224301246014606 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #null06# BY 0 DO stop ODalgol68g-2.8/test-set/a68g.mc.051.flex03.a680000644000175000001440000000143212224301225014553 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #flex03# BEGIN # All erroneous # MODE STRENG = FLEX [1:1] CHAR; LOC REF CHAR:= (LOC STRENG)[1]; # nontrans # # trans # LOC REF CHAR := (TRUE | LOC CHAR | (LOC STRENG)[1]); # nontrans # # nontrans # # trans # (TRUE | LOC[1:3]CHAR | LOC STRENG):= "abc"; # nonflex # # flex # (LOC STRENG)[] :=: (LOC STRENG)[] # trans # # trans # END algol68g-2.8/test-set/a68g.mc.067.idef11.a680000644000175000001440000000142212224301230014525 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef11# BEGIN # More operators and uniting # MODE UN = UNION (INT, REAL); OP + = (UNION (REF UN, REF CHAR) a) VOID: (CASE a IN (REF UN ru): (ru | (INT i): print (("integer", i)), (REAL r): print (("real ", r))), (REF CHAR ch): print (("char ", ch)) ESAC; print (newline)); +(HEAP UN := 1); +(HEAP UN := 2.0); +(HEAP CHAR := "3") ENDalgol68g-2.8/test-set/a68g.mc.118.oper09.a680000644000175000001440000000766712224301254014616 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper09# BEGIN # Monadic operators, non-bold monads # INT decls := 0; OP + = (INT a) INT: a + 1; decls +:= 1; OP +< = (INT a) INT: a + 1; decls +:= 1; OP +> = (INT a) INT: a + 1; decls +:= 1; OP +/ = (INT a) INT: a + 1; decls +:= 1; OP += = (INT a) INT: a + 1; decls +:= 1; OP +* = (INT a) INT: a + 1; decls +:= 1; OP +:= = (INT a) INT: a + 1; decls +:= 1; OP +<:= = (INT a) INT: a + 1; decls +:= 1; OP +>:= = (INT a) INT: a + 1; decls +:= 1; OP +/:= = (INT a) INT: a + 1; decls +:= 1; OP +=:= = (INT a) INT: a + 1; decls +:= 1; OP +*:= = (INT a) INT: a + 1; decls +:= 1; OP +=: = (INT a) INT: a + 1; decls +:= 1; OP +<=: = (INT a) INT: a + 1; decls +:= 1; OP +>=: = (INT a) INT: a + 1; decls +:= 1; OP +/=: = (INT a) INT: a + 1; decls +:= 1; OP +==: = (INT a) INT: a + 1; decls +:= 1; OP +*=: = (INT a) INT: a + 1; decls +:= 1; OP - = (INT a) INT: a + 1; decls +:= 1; OP -< = (INT a) INT: a + 1; decls +:= 1; OP -> = (INT a) INT: a + 1; decls +:= 1; OP -/ = (INT a) INT: a + 1; decls +:= 1; OP -= = (INT a) INT: a + 1; decls +:= 1; OP -* = (INT a) INT: a + 1; decls +:= 1; OP -:= = (INT a) INT: a + 1; decls +:= 1; OP -<:= = (INT a) INT: a + 1; decls +:= 1; OP ->:= = (INT a) INT: a + 1; decls +:= 1; OP -/:= = (INT a) INT: a + 1; decls +:= 1; OP -=:= = (INT a) INT: a + 1; decls +:= 1; OP -*:= = (INT a) INT: a + 1; decls +:= 1; OP -=: = (INT a) INT: a + 1; decls +:= 1; OP -<=: = (INT a) INT: a + 1; decls +:= 1; OP ->=: = (INT a) INT: a + 1; decls +:= 1; OP -/=: = (INT a) INT: a + 1; decls +:= 1; OP -==: = (INT a) INT: a + 1; decls +:= 1; OP -*=: = (INT a) INT: a + 1; decls +:= 1; OP % = (INT a) INT: a + 1; decls +:= 1; OP %< = (INT a) INT: a + 1; decls +:= 1; OP %> = (INT a) INT: a + 1; decls +:= 1; OP %/ = (INT a) INT: a + 1; decls +:= 1; OP %= = (INT a) INT: a + 1; decls +:= 1; OP %* = (INT a) INT: a + 1; decls +:= 1; OP %:= = (INT a) INT: a + 1; decls +:= 1; OP %<:= = (INT a) INT: a + 1; decls +:= 1; OP %>:= = (INT a) INT: a + 1; decls +:= 1; OP %/:= = (INT a) INT: a + 1; decls +:= 1; OP %=:= = (INT a) INT: a + 1; decls +:= 1; OP %*:= = (INT a) INT: a + 1; decls +:= 1; OP %=: = (INT a) INT: a + 1; decls +:= 1; OP %<=: = (INT a) INT: a + 1; decls +:= 1; OP %>=: = (INT a) INT: a + 1; decls +:= 1; OP %/=: = (INT a) INT: a + 1; decls +:= 1; OP %==: = (INT a) INT: a + 1; decls +:= 1; OP %*=: = (INT a) INT: a + 1; decls +:= 1; print (("Should print two equal integers (number of non-bold monads)", newline, ++<+>+/+=+*+:=+<:=+>:=+/:=+=:=+*:=+=:+<=:+>=:+/=:+==:+*=:--<->-/-=-*-:=-<:=->:=-/:=-=:=-*:=-=:-<=:->=:-/=:-==:-*=:%%<%>%/%=%*%:=%<:=%>:=%/:=%=:=%*:=%=:%<=:%>=:%/=:%==:%*=:0, decls)) ENDalgol68g-2.8/test-set/a68g.mc.052.flex04.a680000644000175000001440000000127412224301225014561 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #flex04# (print (("Ghost element test. Results should be:", newline, 3, " 3", newline, "followed by error in multiple assignation", newline, newline, "Results are:", newline)); FOR k FROM 3 TO 4 DO FLEX [1 : 0] [1 : 3] CHAR flex fix; flex fix := " 34"[ : k]; print (k); print (flex fix); print (newline) OD)algol68g-2.8/test-set/a68g.mc.079.mdeq04.a680000644000175000001440000000147012224301232014556 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #mdeq04# BEGIN # Unions # MODE N = UNION (REAL, UNION (BOOL, INT)), M = UNION (UNION (REAL, BOOL), INT); PROC M (PROC N (SKIP)); PROC N (PROC M (SKIP)); # both okay, since 'M' and 'N' are the same # MODE U = UNION (INT, PROC (U) INT), V = UNION (U, PROC (V) INT); PROC U (PROC V (SKIP)); PROC V (PROC U (SKIP)); # both okay, since 'U' and 'V' are the same # SKIP ENDalgol68g-2.8/test-set/a68g.mc.095.null08.a680000644000175000001440000000063112224301247014610 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #null08# CASE INT (SKIP) IN SKIP, SKIP ESACalgol68g-2.8/test-set/a68g.ur.180.r31.a680000644000175000001440000011413312224301276014122 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r31 # (print (("closed clauses", newline)); INT vf = ((27 + 4 + 5 + 2) * 2 + 7) * 6; INT ctr := 0, ctrt, mem; PROC controle = (INT incr) VOID: (ctr /= mem + incr | print (("count er in test", ctrt, ctr, mem + incr, newline))); PROC test = INT: (ctr +:= 1; 1), rre = [] PROC INT: (ctr +:= 1; test), pche = PROC (STRING) PROC INT: (ctr +:= 1; (STRING a) PROC INT: test); UNION (INT, STRING) vu := 1; # servitudes pour contextes # MODE MSTR = STRUCT (COMPL de, of), PRIO += = 5, ? = 9, OP ?= = (INT x) VOID: x, += = (INT a) PROC INT: test, += = (UNION (INT, BOOL) a, INT b) BOOL: (ctr +:= 1) = b, += = (UNION (REF INT, REF BOOL) a, REAL b) MSTR: SKIP, += = (MSTR a, b) REF INT: ctr +:= 1; # declarations pour unites du mode PROC INT # OP ? = (INT a, PROC INT b) PROC INT: (ctr +:= 1; test), STRUCT (INT of, PROC INT de) structa = (0, test), PROC proca = ([] INT a) PROC INT: (ctr +:= 1; test), identa = PROC INT: (ctr +:= 1; test), [] PROC PROC INT ranga = identa; # declarations pour unites du mode PROC REF BOOL # OP ? = (INT a, PROC REF BOOL b) PROC REF BOOL: (ctr +:= 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)), STRUCT (INT of, PROC REF BOOL de) structb = (0, REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)), PROC procb = ([] INT a) PROC REF BOOL: (ctr +:= 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)), identb = PROC REF BOOL: (ctr +:= 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)), [] PROC PROC REF BOOL rangb = identb; # declarations pour unites du mode PROC MSTR # OP ? = (INT a, PROC MSTR b) PROC MSTR: (ctr +:= 1; MSTR: ((0, 0), ctr +:= 1)), STRUCT (INT of, PROC MSTR de) structc = (0, MSTR: ((0, 0), ctr +:= 1)), PROC procc = ([] INT a) PROC MSTR: (ctr +:= 1; MSTR: ((0, 0), ctr +:= 1)), identc = PROC MSTR: (ctr +:= 1; MSTR: ((0, 0), ctr +:= 1)), [] PROC PROC MSTR rangc = identc; # declarations pour unites du mode PROC [] PROC INT # OP ? = (INT a, PROC [] PROC INT b) PROC [] PROC INT: (ctr +:= 1; rre), STRUCT (INT of, PROC [] PROC INT de) structd = (0, rre), PROC procd = ([] INT a) PROC [] PROC INT: (ctr +:= 1; rre), identd = PROC [] PROC INT: (ctr +:= 1; rre), [] PROC PROC [] PROC INT rangd = identd; # declarations pour unites du mode PROC PROC ( STRING ) PROC INT # OP ? = (INT a, PROC PROC (STRING) PROC INT b) PROC PROC (STRING) PROC INT: (ctr +:= 1; pche), STRUCT (INT of, PROC PROC (STRING) PROC INT de) structe = (0, pche), PROC proce = ([] INT a) PROC PROC (STRING) PROC INT: (ctr +:= 1; pche), idente = PROC PROC (STRING) PROC INT: (ctr +:= 1; pche), [] PROC PROC PROC (STRING) PROC INT range = idente; # contextes # ctrt := 1; mem := ctr; (FOR ident FROM BEGIN ctr +:= 1; vu := 1; test END BY BEGIN ctr +:= 1; vu := 1; test END TO BEGIN ctr +:= 1; vu := 1; test END WHILE BEGIN ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) END DO [BEGIN ctr +:= 1; vu := 1; test END : 4, -ident : BEGIN ctr +:= 1; vu := 1; test END] INT ent; ent[BEGIN ctr +:= 1; vu := 1; test END, 0] := ent[ident, BEGIN ctr +:= 1; vu := 1; test END] := BEGIN ctr +:= 1; vu := 1; test END OD; INT alfa, INT par = (SKIP; BEGIN ctr +:= 1; vu := 1; test END; REAL pp = 1.00001; BEGIN ctr +:= 1; vu := 1; test END); alfa := 1 + BEGIN ctr +:= 1; vu := 1; test END; INT ident = BEGIN ctr +:= 1; vu := 1; test END, INT loc := CASE BEGIN ctr +:= 1; vu := 1; test END IN BEGIN ctr +:= 1; vu := 1; test END, SKIP ESAC, tas := BEGIN ctr +:= 1; vu := 1; test END, PROC proc = INT: BEGIN ctr +:= 1; vu := 1; test END, STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), (BEGIN ctr +:= 1; vu := 1; test END, (0, 0e1))); [] INT apd = (ident, par, loc, BEGIN ctr +:= 1; vu := 1; test END, proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: BEGIN ctr +:= 1; vu := 1; test END; UNION (REAL, INT, COMPL) union := pr (proc, BEGIN ctr +:= 1; vu := 1; test END, proc); (INT BEGIN BEGIN ctr +:= 1; vu := 1; test END END, ?=(union; BEGIN ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) END | BEGIN ctr +:= 1; vu := 1; test END), BEGIN ctr +:= 1; vu := 1; test END, (BOOL bool = TRUE; union | (INT): BEGIN ctr +:= 1; vu := 1; test END, (COMPL complex): SKIP)); controle (27 * 2); ctrt := 2; mem := ctr; BEGIN ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) END := BEGIN ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) END := BEGIN ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) END :=: BEGIN ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) END; controle (4 * 2); ctrt := 3; mem := ctr; +=BEGIN ctr +:= 1; vu := 1; test END += (BEGIN ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) END += re OF de OF BEGIN ctr +:= 1; vu := 1; MSTR: ((0, 0), ctr +:= 1) END += BEGIN ctr +:= 1; vu := 1; MSTR: ((0, 0), ctr +:= 1) END) += +=BEGIN ctr +:= 1; vu := 1; test END; controle (5 * 2 + 5); ctrt := 4; mem := ctr; BEGIN ctr +:= 1; vu := 1; rre END[1]; BEGIN ctr +:= 1; vu := 1; pche END (""); controle (2 * 2 + 2)); ctrt := 5; mem := ctr; (FOR ident FROM (INT x = 1; ctr +:= x; test) BY (INT x = 1; ctr +:= x; test) TO (INT x = 1; ctr +:= x; test) WHILE (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) DO [(INT x = 1; ctr +:= x; test) : 4, -ident : (INT x = 1; ctr +:= x; test)] INT ent; ent[(INT x = 1; ctr +:= x; test), 0] := ent[ident, (INT x = 1; ctr +:= x; test)] := (INT x = 1; ctr +:= x; test) OD; INT alfa, INT par = (SKIP; (INT x = 1; ctr +:= x; test); REAL pp = 1.00001; (INT x = 1; ctr +:= x; test)); alfa := 1 + (INT x = 1; ctr +:= x; test); INT ident = (INT x = 1; ctr +:= x; test), INT loc := CASE (INT x = 1; ctr +:= x; test) IN (INT x = 1; ctr +:= x; test), SKIP ESAC, tas := (INT x = 1; ctr +:= x; test), PROC proc = INT: (INT x = 1; ctr +:= x; test), STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), ((INT x = 1; ctr +:= x; test), (0, 0e1))); [] INT apd = (ident, par, loc, (INT x = 1; ctr +:= x; test), proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: (INT x = 1; ctr +:= x; test); UNION (REAL, INT, COMPL) union := pr (proc, (INT x = 1; ctr +:= x; test), proc); (INT BEGIN (INT x = 1; ctr +:= x; test) END, ?=(union; (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) | (INT x = 1; ctr +:= x; test)), (INT x = 1; ctr +:= x; test), (BOOL bool = TRUE; union | (INT): (INT x = 1; ctr +:= x; test), (COMPL complex): SKIP)); controle (27 * 2); ctrt := 6; mem := ctr; (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) := (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) := (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) :=: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)); controle (4 * 2); ctrt := 7; mem := ctr; +=(INT x = 1; ctr +:= x; test) += ((INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) += re OF de OF (INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1)) += (INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1))) += +=(INT x = 1; ctr +:= x; test); controle (5 * 2 + 5); ctrt := 8; mem := ctr; (INT x = 1; ctr +:= x; rre)[1]; (INT x = 1; ctr +:= x; pche) (""); controle (2 * 2 + 2)); ctrt := 9; mem := ctr; (FOR ident FROM BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END BY BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END TO BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END WHILE BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) END DO [BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END : 4, -ident : BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END] INT ent; ent[BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END, 0] := ent[ident, BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END] := BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END OD; INT alfa, INT par = (SKIP; BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END; REAL pp = 1.00001; BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END); alfa := 1 + BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END; INT ident = BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END, INT loc := CASE BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END IN BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END, SKIP ESAC, tas := BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END, PROC proc = INT: BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END, STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), (BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END, (0, 0e1))); [] INT apd = (ident, par, loc, BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END, proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END; UNION (REAL, INT, COMPL) union := pr (proc, BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END, proc); (INT BEGIN BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END END, ?=(union; BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) END | BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END), BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END, (BOOL bool = TRUE; union | (INT): BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END, (COMPL complex): SKIP)); controle (27 * 2); ctrt := 10; mem := ctr; BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) END := BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) END := BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) END :=: BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) END; controle (4 * 2); ctrt := 11; mem := ctr; +=BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END += (BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) END += re OF de OF BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; MSTR: ((0, 0), ctr +:= 1)) END += BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; MSTR: ((0, 0), ctr +:= 1)) END) += +=BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) END; controle (5 * 2 + 5); ctrt := 12; mem := ctr; BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; rre) END[1]; BEGIN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; pche) END (""); controle (2 * 2 + 2)); ctrt := 13; mem := ctr; (FOR ident FROM ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test) BY ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test) TO ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test) WHILE ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) DO [((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test) : 4, -ident : ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test)] INT ent; ent[((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), 0] := ent[ident, ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test)] := ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test) OD; INT alfa, INT par = (SKIP; ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test); REAL pp = 1.00001; ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test)); alfa := 1 + ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test); INT ident = ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), INT loc := CASE ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test) IN ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), SKIP ESAC, tas := ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), PROC proc = INT: ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), (((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), (0, 0e1))); [] INT apd = (ident, par, loc, ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test); UNION (REAL, INT, COMPL) union := pr (proc, ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), proc); (INT BEGIN ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test) END, ?=(union; ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) | ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test)), ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), (BOOL bool = TRUE; union | (INT): ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), (COMPL complex): SKIP)); controle (27 * 2); ctrt := 14; mem := ctr; ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) := ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) := ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) :=: ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)); controle (4 * 2); ctrt := 15; mem := ctr; +=((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test) += (((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) += re OF de OF ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: MSTR: ((0, 0), ctr +:= 1)) += ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: MSTR: ((0, 0), ctr +:= 1))) += +=((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test); controle (5 * 2 + 5); ctrt := 16; mem := ctr; ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: rre)[1]; ((INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: pche) (""); controle (2 * 2 + 2)); ctrt := 17; mem := ctr; (FOR ident FROM BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END BY BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END TO BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END WHILE BEGIN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP END DO [BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END : 4, -ident : BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END] INT ent; ent[BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END, 0] := ent[ident, BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END] := BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END OD; INT alfa, INT par = (SKIP; BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END; REAL pp = 1.00001; BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END); alfa := 1 + BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END; INT ident = BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END, INT loc := CASE BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END IN BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END, SKIP ESAC, tas := BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END, PROC proc = INT: BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END, STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), (BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END, (0, 0e1))); [] INT apd = (ident, par, loc, BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END, proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END; UNION (REAL, INT, COMPL) union := pr (proc, BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END, proc); (INT BEGIN BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END END, ?=(union; BEGIN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP END | BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END), BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END, (BOOL bool = TRUE; union | (INT): BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END, (COMPL complex): SKIP)); controle (27 * 2); ctrt := 18; mem := ctr; BEGIN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP END := BEGIN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP END := BEGIN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP END :=: BEGIN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP END; controle (4 * 2); ctrt := 19; mem := ctr; +=BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END += (BEGIN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP END += re OF de OF BEGIN INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1) EXIT e: SKIP END += BEGIN INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1) EXIT e: SKIP END) += +=BEGIN INT x = 1; ctr +:= x; test EXIT e: SKIP END; controle (5 * 2 + 5); ctrt := 20; mem := ctr; BEGIN INT x = 1; ctr +:= x; rre EXIT e: SKIP END[1]; BEGIN INT x = 1; ctr +:= x; pche EXIT e: SKIP END (""); controle (2 * 2 + 2)); ctrt := 21; mem := ctr; (FOR ident FROM (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) BY (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) TO (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) WHILE (GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e) DO [(GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) : 4, -ident : (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e)] INT ent; ent[(GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), 0] := ent[ident, (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e)] := (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) OD; INT alfa, INT par = (SKIP; (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e); REAL pp = 1.00001; (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e)); alfa := 1 + (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e); INT ident = (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), INT loc := CASE (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) IN (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), SKIP ESAC, tas := (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), PROC proc = INT: (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), ((GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), (0, 0e1))); [] INT apd = (ident, par, loc, (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e); UNION (REAL, INT, COMPL) union := pr (proc, (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), proc); (INT BEGIN (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) END, ?=(union; (GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e) | (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e)), (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), (BOOL bool = TRUE; union | (INT): (GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), (COMPL complex): SKIP)); controle (27 * 2); ctrt := 22; mem := ctr; (GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e) := (GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e) := (GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e) :=: (GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e); controle (4 * 2); ctrt := 23; mem := ctr; +=(GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) += ((GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e) += re OF de OF (GOTO f EXIT e: (INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1) EXIT e: SKIP) EXIT f: GOTO e) += (GOTO f EXIT e: (INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1) EXIT e: SKIP) EXIT f: GOTO e)) += +=(GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e); controle (5 * 2 + 5); ctrt := 24; mem := ctr; (GOTO f EXIT e: (INT x = 1; ctr +:= x; rre EXIT e: SKIP) EXIT f: GOTO e)[1]; (GOTO f EXIT e: (INT x = 1; ctr +:= x; pche EXIT e: SKIP) EXIT f: GOTO e) (""); controle (2 * 2 + 2)); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.072.jump02.a680000644000175000001440000000077412224301231014577 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #jump02# BEGIN REAL a; GOTO l; INT i := 1; l: print (i) # the declaration of 'i' has not been elaborated # ENDalgol68g-2.8/test-set/a68g.mc.066.idef10.a680000644000175000001440000000070012224301230014521 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef10# BEGIN FOR i FROM 1 BY i DO SKIP OD # second 'i' is unknown # END algol68g-2.8/test-set/a68g.mc.113.oper04.a680000644000175000001440000000162612224301253014570 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper04# BEGIN # Operator identification # MODE M = UNION ([] INT, BOOL, STRING); OP + = (REAL a) INT: 2, OP + = (CHAR a) INT: 3, OP + = (M a) INT: 1; PROC prpm = REF PROC M: HEAP PROC M := M: "aap"; UNION (BOOL, STRING) b = "b "; FOR n TO 5 DO print (+CASE n IN SKIP, TRUE, IF FALSE THEN "aa" ELSE b FI, prpm OUT LOC [1 : 1] INT := 1 ESAC) OD # yields 11111 # ENDalgol68g-2.8/test-set/a68g.mc.090.null02.a680000644000175000001440000000057212224301246014600 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #null02# (0)algol68g-2.8/test-set/a68g.mc.116.oper07.a680000644000175000001440000000130512224301254014571 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper07# (# Operator declarations # OP SQ = (REAL x) REAL: x * x, RD = (INT i) REAL: random, OP (REAL) REAL SIN = (print ("Print ten times 1"); sin), COS = cos; print (newline); TO 10 DO print (BEGIN REAL x = RD 1; SQ SIN x + SQ COS x END) OD)algol68g-2.8/test-set/a68g.mc.175.synt04.a680000644000175000001440000000057712224301275014640 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #synt04# END algol68g-2.8/test-set/a68g.mc.057.idef01.a680000644000175000001440000000072212224301227014533 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef01# l1: IF INT i := 1; FALSE THEN INT i := 2; print (i) ELSE print (i) #1# FIalgol68g-2.8/test-set/a68g.mc.155.smio05.a680000644000175000001440000000356112224301262014601 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio05# BEGIN # 10/08/73, R van Vliet; 30/09/75, revised. Test the print and putroutines.# # Assumes pages more than twice as wide as they are high.# INT max ch n = # actual max char, formerly max char[standout channel] # (FILE f:= standout; INT i; on line end(f, (REF FILE f)BOOL: GOTO out); DO put(f, space) OD; out: i:= char number(f) -1; TO i DO put(f, backspace) OD; i); print(("Some tests on PROC(REF FILE)VOID''s", newline)); ( PROC triangle =(REF FILE f)VOID: BEGIN FILE rf:=( line number(f) = 1 AND char number(f) = 1 | f | FILE ff:=f; on page end(ff, (REF FILE f)BOOL : GOTO out); ff); PROC nlp =(REF FILE f) VOID: new line(f); nlp(rf); INT half width = max ch n OVER 2; INT i:=1; FOR k FROM half width -1 BY -1 TO 0 DO TO k DO space(rf) OD; TO i DO put(rf, ".") OD; i +:= 2; new line(rf) OD EXIT out: new line(f) END; print(("First print the full triangle", new page)); print(triangle); print((new line, "Now a part of it, to check some administration.", new line, "The triangle should be chopped at the end of the page.", newline)); print(triangle); print(( "Now print the triangle as part of a more complicated call.", new line, triangle, "Did it stop at end of page again ?", newline)) ) END algol68g-2.8/test-set/a68g.mc.127.scop02.a680000644000175000001440000000105712224301256014573 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #scop02# BEGIN #Scope error# print(("Need not run", newline)); PROC VOID pv= (l: VOID: (MODE M1= [1:($n((l; HEAP INT):= 3) "a" $; 1)] INT; M1 x:= 1; SKIP )); pv END algol68g-2.8/test-set/a68g.mc.014.appl14.a680000644000175000001440000000707012224301220014551 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl14# # JKok, 770822, 'n' queens on chess board using prepared bit patterns for forbidden fields # FOR n FROM 3 TO 8 DO INT maxbord = n * n, nflds = (n * n - 1) OVER bits width; # Bit pattern prelude # MODE BORD = [0 : nflds] BITS; # BORD = [0 : maxbord - 1] BOOL packed in [ ] BITS # OP OR = (BORD a, b) BORD: (BORD c; FOR i FROM 0 TO nflds DO c[i] := a[i] OR b[i] OD; c); OP ELEM = (INT i, BORD a) BOOL: IF i < 0 OR i >= max bord THEN FALSE ELSE (i MOD bits width + 1) ELEM a[i OVER bits width] FI; OP BTOB = (INT i) BORD: # true -->> i-th bool of bord # BEGIN BORD a; FOR k FROM 0 TO nflds DO a[k] := 2r0 OD; IF i >= 0 AND i < max bord THEN a[i OVER bits width] := 2r1 UP ((-i - 1) MOD bits width) FI; a END # of op bool to bits # ; OP ORAB = (REF BORD a, INT i) REF BORD: BEGIN IF i >= 0 AND i < max bord THEN REF BITS ai = a[i OVER bits width]; ai := (2r1 UP ((-i - 1) MOD bits width)) OR ai FI; a END # of op or a b # ; PRIO ORAB = 1; # Initialize # INT aantal := 0, [1 : n] INT shift, [1 : n, 1 : n] BORD erase; FOR i TO n DO shift[i] := (i - 1) * n - 1 OD; FOR r TO n DO FOR k TO n DO BORD ds := BTOB -1; FOR i TO n - r DO INT sh = shift[i + r] + k; ds ORAB sh; IF k + i <= n THEN ds ORAB sh + i FI; IF k > i THEN ds ORAB sh - i FI OD; erase[r, k] := ds OD OD; # Find all solutions # [1 : n] INT dame; PROC zet = (INT row, col, BORD stand) VOID: IF dame[row] := col; row = n THEN out sol ELSE INT r = row + 1, sh = shift[r], dame1 = dame[1]; FOR k FROM (dame1 = 1 | 2 |: dame1 < r AND n - dame1 > r - 2 | 1 | 2) TO (dame1 <= r AND n - dame1 >= r | n | n - 1) DO IF NOT ((k + sh) ELEM stand) THEN zet (r, k, erase[r, k] OR stand) FI OD FI; PROC outsol = VOID: BEGIN print ((newline, " ")); PROC line = VOID: FOR i TO 4 * n - 1 DO print ("-") OD; line; FOR i TO n DO INT k = dame[i]; print (newline); FOR j TO n DO print (IF j = k THEN "| q " ELSE "| " FI) OD; print (("|", newline, " ")); line OD; print ((newline, " #", whole (aantal +:= 1, -4))); TO 2 DO print (newline) OD END # out solution # ; FOR i TO n OVER 2 DO zet (1, i, erase[1, i]) OD; print ((" Number of solutions is ", whole (aantal, -4), " for n = ", whole (n, -3), newline, newline)) ODalgol68g-2.8/test-set/a68g.mc.139.simp04.a680000644000175000001440000000473412224301260014604 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp04# multiples:structures: BEGIN #Multiple values# print (("Multiple values", newline)); [1 : 100] INT i, j, k; FOR l TO 100 DO i[l] := j[l] := k[l] := l OD; FOR l TO 100 DO IF i[l] /= l OR j[l] /= l OR k[l] /= l THEN print ("Bad multiple assignation") FI OD; [1 : 100] REAL p; p[1] := 1.0; p[1 : 5] := (2.0, 3.0, 4.0, 5.0, 6.0); print ((newline, "Values are 2.0 - 6.0", newline, p[1 : 5])); print (newline); #Test the @ workings# p[2 : 6 #implicit @1# ] := (2.0, 3.0, 4.0, 5.0, 6.0); print ((newline, "Values are 2.0, 2.0 - 6.0", newline, p[1 : 6], newline)); p[2 : 3@8] := p[3 : 4@8]; print ((newline, "Values are 2.0, 3.0, 4.0, 4.0", newline, p[1 : 4@7], newline)); print ((newline, "Values are 11, 4", UPB p[1 : 3@9], UPB p[1 : 0@5], newline)); [1 : 10, 1 : 10] INT l; FOR i TO 10 DO FOR j TO 10 DO l[i, j] := 100 OD OD; FOR i TO 2 DO FOR j TO 10 DO l[1 : 2, 1 : 10][i, j] := 11 OD OD; print ((newline, "Values are 20 instances of 11 followed by ", "80 of 100", newline, l, newline)); #Structures# STRUCT ([1 : 2] INT m, [1 : i[5] # whose value is 5 from above# ] REAL g, BOOL t) s1, s2; t OF s1 := t OF s2 := l[1, 1] = l[1 : 1, 1 : 2][1, 1]; #true# FOR m TO UPB m OF s1 DO (m OF s1)[m] := ((m OF s2)[3 - m] := 50) + 1 OD; g OF s1 := (g OF s2)[] := (1.0, 2.0, 3.0, 4.0, 5.0); print ((newline, "Structures:", newline, "Values are 51, 51, 1.0 to 5.0, TRUE:", newline, s1, newline, newline, "Values are 50, 50, 1.0 to 5.0, TRUE:", newline, s2, newline)); #REF STRUCT's# [1 : 2] REF STRUCT ([] INT m, [] REAL g, BOOL t) ss1 := (s1, s2); print ((newline, "Values same as last two lines:", newline, ss1[1], newline, ss1[2], newline)); t OF ss1[2] := FALSE; print ((newline, "Values are TRUE, FALSE: ", t OF s1, t OF s2)) ENDalgol68g-2.8/test-set/a68g.ur.188.r542c.a680000644000175000001440000001574712224301305014370 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r542c # (print (("dyadic formulas", newline)); INT vf = 10 + 5 * (4 * 8 + 15 + 14); INT ctrt := 0, ctr := 0, ctrloc; PROC ctrl = (INT inc) VOID: (ctr /= ctrloc + inc | print (("count er in test", ctrt, ctr, ctrloc + inc, newline))); MODE R = INT; PROC test = (INT a) VOID: (a = 1 | ctr +:= 1 | print (("er", ctrt, ctr - ctrloc, newline))); OP ?=:= = (INT x) INT: (test (x); x); # servitudes pour secondaires # INT b = 2, c = 3, d = 4, e = 5, f = 6, g = 7, h = 8, i = 9, j = 10; STRUCT (INT d2, d3, d4, d5, d6, d7, d8, d9, d0) str = (2, 3, 4, 5, 6, 7, 8, 9, 10); [, ] INT t = ((0, b, c, d, e, f, g, h, i, j), (1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), PROC call = (INT a) INT: (a = 0 | 10 | a), OP & = (BOOL a, INT b) STRUCT (INT a, b): (b, 0), & = (CHAR a, STRUCT (INT a, b) b) INT: a OF b; PRIO & = 3; PRIO A = 1, B = 2, C = 3, D = 4, E = 5, F = 6, G = 7, H = 8, I = 9; PROC dyad = (INT a, b) INT: ((a = b | ctr +:= 1 | print (("er.prio", ctrt, ctr - ctrloc, a, b, newline))); a - 1); # contextes demandant un mode : rep # (OP M = (INT a) REF INT: HEAP INT := (ctr +:= 1; a - 1); PROC rep = (INT a, b) REF INT: HEAP INT := dyad (a, b); OP (INT, INT) REF INT A = rep, B = rep, C = rep, D = rep, E = rep, F = rep, G = rep, H = rep, I = rep; # nombre de operateurs : 4 # ctrt := 11; ctrloc := ctr; test (M 3 D M M 4 := M 3 D M M 4 := (M 3 D M M 4 :/=: M 3 D M M 4 | M 3 D M M 4)); ctrl (1 + 5 * 4); ctrt := 12; ctrloc := ctr; test (M c D M M d := M c D M M d := (M c D M M d :/=: M c D M M d | M c D M M d)); ctrl (1 + 5 * 4); ctrt := 13; ctrloc := ctr; test (M d3 OF str D M M d4 OF str := M d3 OF str D M M d4 OF str := (M d3 OF str D M M d4 OF str :/=: M d3 OF str D M M d4 OF str | M d3 OF str D M M d4 OF str)); ctrl (1 + 5 * 4); ctrt := 14; ctrloc := ctr; test (M t[, c][2] D M M t[, d][2] := M t[, c][2] D M M t[, d][2] := (M t[, c][2] D M M t[, d][2] :/=: M t[, c][2] D M M t[, d][2] | M t[, c][2] D M M t[, d][2])); ctrl (1 + 5 * 4); ctrt := 15; ctrloc := ctr; test (M call (3) D M M call (4) := M call (3) D M M call (4) := (M call (3) D M M call (4) :/=: M call (3) D M M call (4) | M call (3) D M M call (4))); ctrl (1 + 5 * 4); ctrt := 16; ctrloc := ctr; test (M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI := M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI := (M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI :/=: M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI | M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI)); ctrl (1 + 5 * 4); ctrt := 17; ctrloc := ctr; test (M (INT x := c; x) D M M (INT x := d; x) := M (INT x := c; x) D M M (INT x := d; x) := (M (INT x := c; x) D M M (INT x := d; x) :/=: M (INT x := c; x) D M M (INT x := d; x) | M (INT x := c; x) D M M (INT x := d; x))); ctrl (1 + 5 * 4); ctrt := 18; ctrloc := ctr; test (M ("#" & (TRUE & PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI)) D M M ("#" & (TRUE & d4 OF str)) := M ("#" & (TRUE & PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI)) D M M ("#" & (TRUE & 4)) := (M ("#" & (TRUE & d3 OF str)) D M M ("#" & (TRUE & (INT x := d; x))) :/=: M ("#" & (TRUE & call (3))) D M M ("#" & (TRUE & ("#" & (TRUE & d4 OF str)))) | M ("#" & (TRUE & t[, c][2])) D M M ("#" & (TRUE & d)))); ctrl (1 + 5 * 4); # nombre de operateurs : 15 # ctrt := 19; ctrloc := ctr; test (call (2) A M t[, e][2] C 6 E M M 10 G j I j H (INT x := i; x) F M M call (9) D e B M call (4) := ("#" & (TRUE & (INT x := b; x))) A M 5 C d6 OF str E M M call (0) G call (0) I d0 OF str H i F M M PROC INT IF 9 = 0 THEN INT: 10 ELSE INT: 9 FI D call (5) B M d := (call (2) A M e C f E M M PROC INT IF 0 = 0 THEN INT: 10 ELSE INT: 0 FI G j I ("#" & (TRUE & j)) H d9 OF str F M M i D PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI B M call (4) :/=: t[, b][2] A M (INT x := e; x) C ("#" & (TRUE & d6 OF str)) E M M t[, j][2] G ("#" & (TRUE & j)) I (INT x := j; x) H (INT x := i; x) F M M ("#" & (TRUE & t[, i][2])) D PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI B M (INT x := d; x) | call (2) A M call (5) C PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI E M M call (0) G t[, j][2] I 10 H 9 F M M PROC INT IF 9 = 0 THEN INT: 10 ELSE INT: 9 FI D (INT x := e; x) B M (INT x := d; x))); ctrl (1 + 5 * 15); # nombre de operateurs : 14 # ctrt := 20; ctrloc := ctr; test (M PROC INT IF 8 = 0 THEN INT: 10 ELSE INT: 8 FI H g E M t[, g][2] E t[, e][2] C M M (INT x := f; x) C (INT x := c; x) C PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI E ("#" & (TRUE & 4)) E M PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI H ("#" & (TRUE & d)) := M t[, h][2] H t[, g][2] E M g E ("#" & (TRUE & PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI)) C M M d6 OF str C call (3) C d E t[, d][2] E M PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI H d4 OF str := (M h H d7 OF str E M call (7) E call (5) C M M d6 OF str C call (3) C ("#" & (TRUE & 4)) E call (4) E M t[, e][2] H 4 :/=: M d8 OF str H d7 OF str E M PROC INT IF 7 = 0 THEN INT: 10 ELSE INT: 7 FI E call (5) C M M PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI C 3 C d4 OF str E (INT x := d; x) E M ("#" & (TRUE & t[, e][2])) H PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI | M ("#" & (TRUE & d8 OF str)) H (INT x := g; x) E M call (7) E t[, e][2] C M M (INT x := f; x) C c C d4 OF str E t[, d][2] E M PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI H d4 OF str)); ctrl (1 + 5 * 14); SKIP); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.002.appl02.a680000644000175000001440000000304012224301215014540 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl02# BEGIN # ALGOL 68 program, TJD 730706. Calculates all increasing sequences adding up to a given integer from 1 to 10. See ALGOL 68 program TJD 730705 # MODE LIST = STRUCT (INT summand, REF LIST link); HEAP LIST zero := (0, NIL); PROC print solution = VOID: print ((straighten (link OF zero), newline)); PROC straighten = (REF LIST l) [] INT: IF l :=: NIL THEN (# empty # ) ELSE [] INT st = straighten (link OF l); [0 : UPB st] INT r; r[0] := summand OF l; r[1 : UPB st] := st; r[@1] FI #straighten# ; PROC build = (REF LIST p, INT rest) VOID: IF rest = 0 THEN print solution ELSE FOR k FROM summand OF p + 1 TO rest DO (HEAP LIST q := (k, NIL); link OF p := q; build (q, rest - k)) OD FI; FOR g TO 10 DO print ((newline, g, " =", newline)); build (zero, g) OD ENDalgol68g-2.8/test-set/a68g.mc.167.stow04.a680000644000175000001440000000100712224301274014624 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #stow04# BEGIN print ([] [] BOOL (TRUE, 2r1)); # TF...FT # print (newline); print ([, ] BOOL (TRUE, 2r1)) # runtime error, wrong length # ENDalgol68g-2.8/test-set/a68g.mc.033.coer05.a680000644000175000001440000000073012224301223014545 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer05# BEGIN # Row display cannot be united # print(UPB IF FALSE THEN []INT(1) ELSE (1,2,3) FI) END algol68g-2.8/test-set/a68g.mc.161.smio12.a680000644000175000001440000004501412224301263014574 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio12# BEGIN # Test 'fixed' # PROC fixed 1 = (REAL v, INT width, after) STRING: BEGIN PROC subfixed = # This procedure attempts a machine-independent conversion from REAL to []CHAR. The conversion will be exact if 'b' is given a value such that the following conditions hold: b is integer, x is real 1 < b < maxint OVER 10 if x < 0 then -x > 0 if x < 0 then --x = x if x >= 1 then x / b * b = x if 0 < x < 1 then x * b / b = x if 0 <= x < b then 0 <= entier(x) < b if 0 <= x < b then x - entier(x) < 1 if 0 <= x < b then x - entier(x) + entier(x) = x if x > 1 then "ln(x)" * .9 < ln(x) < "ln(x)" * 1.1 where "ln(x)" is the mathematical log nat of x Here the arithmetic operators are meant as implemented, the relational operators are meant in an absolute sense. The text contains tests for these conditions, where, of course, the relational operators are implemented by their ALGOL 68 counter- parts. Discrepancies caused by tests which do not test what they should test may cause the message "Sloppy arithmetic". This procedure is not as inefficient as it might have been. # (REAL v, INT after, REF INT point, REF BOOL neg, BOOL floating) STRING: BEGIN INT b = 16 # replace by suitable value # ; # Reports on arithmetic troubles # PROC warning = (UNION (REAL, INT, CHAR, STRING) l, oper, r, res, ch) VOID: print (("Warning: ", l, oper, r, " is ", res, ", should be ", ch, " .", new line)); PROC sloppy = (REAL x, STRING s, INT lim) VOID: print (("Sloppy arithmetic: ", x, " is still ", s, " after", lim, " iterations.", newline)); # Determining accuracy # # Each decimal operation may cause a loss of at most 1 unit in the last decimal. If we now make pessimistic guesses at the number of operations, we can calculate the number of extra digits needed. # PRIO LN = 9; OP LN = (INT a, REAL b) INT: (b < 1 | 0 | ENTIER (ln (b) / ln (a))) + 1; INT max exp = b LN max real, max mant = b LN (1 / small real) + 1; # Floating decimal arithmetic # MODE DEC = STRUCT (REF [] INT d, INT p); # The value is * 10 ** p, where is d considered as a decimal fraction with the point in the (non-existent) position 0 # PROC zero = (INT size) DEC: BEGIN HEAP [size] INT d; FOR i TO UPB d DO d[i] := 0 OD; (d, 0) END; OP +:= = (REF DEC dc, INT a) VOID: BEGIN REF [] INT d = d OF dc, REF INT p = p OF dc; INT upb = UPB d; INT carry := a, i := p; WHILE carry > 0 DO WHILE i <= 0 DO d[2 : ] := d[1 : upb - 1]; d[1] := 0; p +:= 1; i +:= 1 OD; IF i > upb THEN carry OVERAB 10 ELSE REF INT di = d[i]; INT val = di + carry; (di := val MOD 10, carry := val OVER 10) FI; i -:= 1 OD END; OP *:= = (REF DEC dc, INT a) VOID: BEGIN REF [] INT d = d OF dc, REF INT p = p OF dc; INT upb = UPB d; INT carry := 0, i := upb; WHILE i > 0 OR carry > 0 DO WHILE i <= 0 DO d[2 : ] := d[1 : upb - 1]; d[1] := 0; p +:= 1; i +:= 1 OD; REF INT di = d[i]; INT val = di * a + carry; (di := val MOD 10, carry := val OVER 10); i -:= 1 OD END; OP /:= = (REF DEC dc, INT a) VOID: BEGIN REF [] INT d = d OF dc, REF INT p = p OF dc; INT upb = UPB d; INT carry := 0, i := 1; WHILE (i <= upb | TRUE | carry > 0 AND d[1] = 0) DO WHILE i > upb DO d[1 : upb - 1] := d[2 : ]; d[upb] := 0; p -:= 1; i -:= 1 OD; REF INT di = d[i]; INT val = di + carry * 10; (di := val OVER a, carry := val MOD a); i +:= 1 OD END; # Actual subfixed # neg := v < 0; REAL x := IF neg THEN REAL x = -v; IF -x /= v THEN warning ("", "-", x, -x, v) FI; x ELSE v FI, INT exp := 0; DEC dc := zero ((INT m = 10 LN x + after + 1; m > real width | m | real width) + 10 LN REAL (max exp * 1 + max mant * 2) + 1); # We keep the following invariant: |v| = (x + |dc|) * b ** exp # # First we make 'x' zero # IF x > 0 THEN TO max exp WHILE x < 1 DO REAL y = x * b; exp -:= 1; IF y / b /= x THEN warning (y, "/", b, y / b, x) FI; x := y OD; IF x < 1 THEN sloppy (x, "< 1", max exp) FI; TO max exp WHILE NOT (x < 1) DO REAL y = x / b; exp +:= 1; IF y * b /= x THEN warning (y, "*", b, y * b, x) FI; x := y OD; IF NOT (x < 1) THEN sloppy (x, ">= 1", max exp) FI; # Now 1/b <= x < 1 # TO max mant WHILE x > 0 DO (x := x * b, dc *:= b, exp -:= 1); INT dig = ENTIER x; IF dig < 0 THEN warning ("", "ENTIER", x, dig, ">= 0") FI; IF dig >= b THEN warning ("", "ENTIER", x, dig, "< b") FI; REAL y = x - dig; dc +:= dig; IF y >= 1 THEN warning (x, "-", dig, y, "< 1") FI; IF y + dig /= x THEN warning (y, "+", dig, y + dig, x) FI; x := y OD; IF x > 0 THEN sloppy (x, "> 0", max mant) FI FI; # Now x = 0, and consequently |v| = |dc| * b ** exp # # Second we make 'exp' 0 # WHILE exp > 0 DO (dc *:= b, exp -:= 1) OD; WHILE exp < 0 DO (dc /:= b, exp +:= 1) OD; # Now |v| = |dc|, i.e. 'v' has been converted to decimal # # We shall now fill 's' from 'dc' in the required format # OP ELEM = (INT i, REF [] INT d) CHAR: "0123456789"[(i < 1 | 0 |: i > UPB d | 0 | d[i]) + 1]; IF floating THEN print ((newline, "Floating version not implemented", newline)); SKIP ELSE REF [] INT d = d OF dc, INT p = p OF dc; [UPB d] CHAR s; INT i := 0; FOR k TO p DO CHAR ch = k ELEM d; IF i = 0 AND ch = "0" THEN SKIP ELSE s[i +:= 1] := ch FI OD; point := i; FOR k FROM p + 1 TO p + after + 1 DO s[i +:= 1] := k ELEM d OD; s[1 : point + after + 1] FI END # subfixed # ; PROC round = (INT k, REF STRING s) BOOL: IF BOOL carry := char dig (s[k + 1]) >= 5; s := s[ : k]; carry THEN FOR j FROM k BY -1 TO 1 WHILE carry DO INT d = char dig (s[j]) + 1; carry := d = 10; s[j] := (carry | "0" | "0123456789"[d + 1]) OD; (carry | "1" PLUSTO s); carry ELSE FALSE FI; PROC char dig = (CHAR c) INT: (INT i; char in string (c, i, "0123456789"); i - 1); # Actual fixed # IF # no value can be converted legally with these parameters: # after < 0 OR width < 0 AND after > -width - 1 OR width > 0 AND after > width - 2 THEN (width = 0 | 1 | ABS width) * error char ELIF INT point, BOOL neg; STRING s := subfixed (v, after, point, neg, FALSE); STRING sign = (neg | "-" |: width > 0 | "+" | ""); width = 0 THEN (round (UPB s - 1, s) | point +:= 1); (UPB s = 0 | s := "0"; point := 1); sign + (point = UPB s | s | s[ : point] + "." + s[point + 1 : ]) ELSE INT w = ABS width - UPB sign; INT tail = (INT lim = w - point - 1 + (w = point AND point > 0 | 1 | 0); (lim < after | lim | after)); IF tail < 0 THEN ABS width * error char ELSE s := s[ : point + tail + 1]; (round (UPB s - 1, s) | point +:= 1); (UPB s = 0 | s := "0"; point := 1); INT space = w - UPB s - (point = UPB s | 0 | 1); IF space < 0 AND tail = 0 THEN ABS width * error char ELSE IF space < 0 THEN s := s[ : UPB s - 1] ELIF space >= 1 AND point = 0 THEN "0" PLUSTO s; point +:= 1 FI; s := sign + (point = UPB s | s | s[ : point] + "." + s[point + 1 : ]); (ABS width - UPB s) * " " + s FI FI FI END # fixed 1 # ; # Testing equipment # PROC t0 = VOID: BEGIN FOR v TO UPB vals DO REAL value = vals[v]; t1 (value); IF value > 0 THEN t1 (DOWN value); t1 (UP value) FI OD; TO 20 DO t4 (wild real) OD; t4 (max real) END; PROC t1 = (REAL v) VOID: FOR width FROM -4 TO 9 DO t2 (-v, -width); t2 (v, -width) OD; PROC t2 = (REAL v, INT width) VOID: BEGIN FOR after FROM -1 TO 4 DO t3 (v, width, after) OD; IF width = 0 THEN t4 (v) FI END; PROC t3 = (REAL v, INT width, after) VOID: IF STRING s1 = fixed (v, width, after), s2 = fixed 1 (v, width, after); s1 /= s2 THEN print ((v, whole (width, -4), whole (after, -4), ", is """, s1, """, must be """, s2, """", newline)) FI; PROC t4 = (REAL v) VOID: t3 (v, 0, real width + 1); OP DOWN = (REAL x) REAL: (REAL y := x; FOR i WHILE x = y DO y := x * (1 - i * small real) OD; y); OP UP = (REAL x) REAL: (REAL y := x; FOR i WHILE x = y DO y := x * (1 + i * small real) OD; y); PROC wild real = REAL: exp (random * real width + ln (10)); [] REAL vals = (0.0, 0.01, 0.0449, 0.4449, 0.9945, 9.945, 99.45, 100); t0 ENDalgol68g-2.8/test-set/a68g.mc.136.simp01.a680000644000175000001440000000116212224301257014574 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp01# BEGIN #ALGOL68 test to see if the compiler exists# INT i, j, k; INT s = 17; INT t := 3; i := 0; FOR l FROM 0 BY 2 TO 13 DO i +:= l OD; print (("Value should be 42", i, newline)) ENDalgol68g-2.8/test-set/a68g.ur.181.r33d.a680000644000175000001440000002246512224301276014277 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r33d # (print (("void collateral clauses", newline)); INT vf = 718 * 2; INT ctr := 0, mem, ctrt; PROC controle = (INT incr) VOID: (ctr /= mem + incr | print (("count er in test", ctrt, ctr, mem + incr, newline))); BOOL boo := TRUE, INT decr, k, vi, MODE M = UNION (INT, STRING), M vu := "vide", PROC p1 = INT: 1, [] M tre = (1, "vide", "vide"), STRUCT (M a, b) srm = ("vide", 2); (ctrt := 1; mem := ctr; REF INT xx, INT incr = 0; ((boo | boo := FALSE; ctr +:= 7); BEGIN boo := TRUE, ctr +:= 15 END; ctr +:= 7; ea: ctrt := 2; IF (boo | boo := FALSE; ctr +:= 7); BEGIN boo := TRUE, ctr +:= 15 END; TRUE THEN ctr +:= 7 FI; eb: ctrt := 3; ((boo | boo := FALSE; ctr +:= 7); BEGIN boo := TRUE, ctr +:= 15 END; 1 | ctr +:= 7, "vide"); ec: ctrt := 4; CASE (boo | boo := FALSE; ctr +:= 7); BEGIN boo := TRUE, ctr +:= 15 END; vu IN (INT): SKIP ESAC; ctr +:= 7; ed: ctrt := 5; FOR i WHILE (boo | boo := FALSE; ctr +:= 7); BEGIN boo := TRUE, ctr +:= 15 END; FALSE DO REF INT xx; SKIP OD; ctr +:= 7; ee: ctrt := 6; TO 4 DO (boo | boo := FALSE; ctr +:= 7); BEGIN boo := TRUE, ctr +:= 15 END; ctr +:= 7 OD; ef: ctrt := 7; IF (boo | boo := FALSE; ctr +:= 7); TRUE THEN BEGIN boo := TRUE, ctr +:= 15 END; ctr +:= 7 FI; eg: ctrt := 8; ((boo | boo := FALSE; ctr +:= 7); FALSE | SKIP | BEGIN boo := TRUE, ctr +:= 15 END; ctr +:= 7); eh: ctrt := 9; CASE 0 IN 1, 2 OUT (boo | boo := FALSE; ctr +:= 7); BEGIN boo := TRUE, ctr +:= 15 END; ctr +:= 7 ESAC; ei: ctrt := 10; (SKIP; (boo | boo := FALSE; ctr +:= 7); vu | (INT): SKIP | SKIP; BEGIN boo := TRUE, ctr +:= 15 END; ctr +:= 7); ej: ctrt := 11; decr := 2; FOR i TO 7 WHILE BOOL b = (decr -:= 1) >= 0; (b | (boo | boo := FALSE; ctr +:= 7)); REF INT xx; b DO SKIP; BEGIN boo := TRUE, ctr +:= 15 END OD; ctr +:= 7; ek: ctrt := 12; (boo | boo := FALSE; ctr +:= 7); (TRUE | BEGIN boo := TRUE, ctr +:= 15 END | "vide"); ctr +:= 7; el: ctrt := 13; IF (boo | boo := FALSE; ctr +:= 7); FALSE THEN REF INT xx; SKIP ELSE BEGIN boo := TRUE, ctr +:= 15 END FI; ctr +:= 7; em: ctrt := 14; ((boo | boo := FALSE; ctr +:= 7); -1 | "vide", "vide" | REF INT xx; BEGIN boo := TRUE, ctr +:= 15 END); ctr +:= 7; en: ctrt := 15; CASE REF INT xx; vu IN (INT a): "vide" OUT (boo | boo := FALSE; ctr +:= 7); BEGIN boo := TRUE, ctr +:= 15 END ESAC; ctr +:= 7; eo: ctrt := 16; (boo | boo := FALSE; ctr +:= 7); (SKIP, BEGIN boo := TRUE, ctr +:= 15 END, (1.0, 0)); ctr +:= 7; ep: ctrt := 17; CASE (boo | boo := FALSE; ctr +:= 7); 3 IN (0, 1, 2), "vide", BEGIN boo := TRUE, ctr +:= 15 END ESAC; ctr +:= 7; eq: ctrt := 18; ((boo | boo := FALSE; ctr +:= 7); vu | (STRING): BEGIN boo := TRUE, ctr +:= 15 END, (INT): "vide"); ctr +:= 7; er: ctrt := 19; (PROC p = (REF INT kk) VOID: BEGIN boo := TRUE, ctr +:= 15 END; p ((boo | boo := FALSE; ctr +:= 7))); ctr +:= 7; es: ctrt := 20; (boo | boo := FALSE; ctr +:= 7); VOID: BEGIN boo := TRUE, ctr +:= 15 END; ctr +:= 7; et: ctrt := 21; (boo | boo := FALSE; ctr +:= 7); BEGIN boo := TRUE, ctr +:= 15 END); ctr +:= 7; eu: controle (718)); (ctrt := 22; mem := ctr; REF INT xx, INT incr = 0; (SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); ctr +:= 7; ea: ctrt := 23; IF SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); TRUE THEN ctr +:= 7 FI; eb: ctrt := 24; (SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); 1 | ctr +:= 7, "vide"); ec: ctrt := 25; CASE SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); vu IN (INT): SKIP ESAC; ctr +:= 7; ed: ctrt := 26; FOR i WHILE SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); FALSE DO REF INT xx; SKIP OD; ctr +:= 7; ee: ctrt := 27; TO 4 DO SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); ctr +:= 7 OD; ef: ctrt := 28; IF SKIP; TRUE THEN (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); ctr +:= 7 FI; eg: ctrt := 29; (SKIP; FALSE | SKIP | (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); ctr +:= 7); eh: ctrt := 30; CASE 0 IN 1, 2 OUT SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); ctr +:= 7 ESAC; ei: ctrt := 31; (SKIP; SKIP; vu | (INT): SKIP | SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); ctr +:= 7); ej: ctrt := 32; decr := 2; FOR i TO 7 WHILE BOOL b = (decr -:= 1) >= 0; (b | SKIP); REF INT xx; b DO SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100) OD; ctr +:= 7; ek: ctrt := 33; SKIP; (TRUE | (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100) | "vide"); ctr +:= 7; el: ctrt := 34; IF SKIP; FALSE THEN REF INT xx; SKIP ELSE (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100) FI; ctr +:= 7; em: ctrt := 35; (SKIP; -1 | "vide", "vide" | REF INT xx; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100)); ctr +:= 7; en: ctrt := 36; CASE REF INT xx; vu IN (INT a): "vide" OUT SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100) ESAC; ctr +:= 7; eo: ctrt := 37; SKIP; (SKIP, (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100), (1.0, 0)); ctr +:= 7; ep: ctrt := 38; CASE SKIP; 3 IN (0, 1, 2), "vide", (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100) ESAC; ctr +:= 7; eq: ctrt := 39; (SKIP; vu | (STRING): (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100), (INT): "vide"); ctr +:= 7; er: ctrt := 40; (PROC p = (REF INT kk) VOID: (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); p (SKIP)); ctr +:= 7; es: ctrt := 41; SKIP; VOID: (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100); ctr +:= 7; et: ctrt := 42; SKIP; (BEGIN SKIP, REF M (NIL), HEAP M END, LOC M := 5, ctr :=: mem, (1, 2, ctr + 100), (REAL x := 3.14; ctr - mem * 5 / x), -p1, ctr +:= 22, tre[3], a OF srm, (INT a) VOID: ctr -:= 100)); ctr +:= 7; eu: controle (718)); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.176.synt05.a680000644000175000001440000000056712224301275014641 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #synt05# algol68g-2.8/test-set/a68g.mc.096.null09.a680000644000175000001440000000065212224301247014615 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #null09# CASE UNION (BOOL, VOID) (SKIP) IN (VOID): SKIP ESACalgol68g-2.8/test-set/a68g.mc.107.numr11.a680000644000175000001440000001636612224301252014613 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr11# BEGIN #Test trig functions 1# #N.B. This test should not be considered as certification of trig functions, but only as an indication that trig functions have the right properties# # Value checks # REAL eps = 100.0 * smallreal; PROC warn = (STRING s) VOID: BEGIN print ((newline, "++++test error: ", s, newline)) END; REAL zero = 0, half = 0.5, one = 1, two = 2, three = 3, four = 4, five = 5, six = 6, seven = 7, eight = 8, twelve = 12, sixteen = 16, thirtytwo = 32; [] REAL theta = [] REAL (zero, pi / two, pi, three * pi / two, pi + pi, five * pi / two, three * pi)[ : AT 0], phi = [] REAL (zero, pi / six, pi / four, pi / three, pi / two)[ : AT 0], sphi = [] REAL (zero, half, sqrt (half), sqrt (0.75), one)[ : AT 0], tphi = [] REAL (zero, sqrt (one / three), one, sqrt (three), maxreal)[ : AT 0], [] STRING angle = [] STRING ("0", "pi/6", "pi/4", "pi/3", "pi/2")[ : AT 0]; INT upb = UPB phi; PROC test = (REAL a, INT i, j, REAL s, c, t) VOID: BEGIN PROC printangle = VOID: BEGIN IF a < zero THEN print ("-(") FI; IF ODD j THEN IF j = 1 THEN print ("pi/2") ELSE print (whole (j, 0)); print ("*pi/2") FI ELSE IF j /= 0 THEN IF j = 1 THEN print ("pi") ELSE print (whole (j % 2, 0)); print ("*pi") FI FI FI; IF i = 0 THEN IF j = 0 THEN print ("0") FI ELSE IF j /= 0 THEN print ("+") FI; print (angle[i]) FI; IF a < 0 THEN print (")") FI END; IF ABS (sin (a) - s) > eps THEN print ((newline, newline, "sin(")); printangle; print ((") =", sin (a))); print ((newline, "expected =", s)); warn ("probable error in ''sin''") FI; IF ABS (cos (a) - c) > eps THEN print ((newline, newline, "cos(")); printangle; print ((") =", cos (a))); print ((newline, "expected =", c)); warn ("probable error in ''cos''") FI; IF (ODD j | i /= 0 | i /= upb) THEN IF t = maxreal THEN SKIP ELIF ABS (tan (a) - t) > two * eps THEN print ((newline, newline, "tan(")); printangle; print ((") =", tan (a))); print ((newline, "expected =", t)); warn ("probable error in ''tan''") FI FI END; FOR j FROM 0 TO UPB theta DO FOR i FROM 0 TO upb - 1 DO REAL a = theta[j] + phi[i]; REAL s1 = sphi[(ODD j | upb - i | i)], c1 = sphi[(ODD j | i | upb - i)], t = (ODD j | -tphi[upb - i] | tphi[i]); REAL s = (ODD (j % 2) | -s1 | s1), c = (ODD ((j + 1) % 2) | -c1 | c1); test (a, i, j, s, c, t); test (-a, i, j, -s, c, -t) OD OD; #Check identities: sin(x) = 2*tan(x/2)/(1+tan(x/2)**2), cos(x) = (1-tan(x/2)**2)/(1+tan(x/2)**2), tan(x) = 2*tan(x/2)/(1-tan(x/2)**2).# REAL sums := zero, sumc := zero, sumt := zero, sumsqs := zero, sumsqc := zero, sumsqt := zero, maxs := zero, maxc := zero, maxt := zero, ats, atc, att, INT cs := 0, cc := 0, ct := 0; TO 200 DO REAL a = random; REAL aby2 = a / 2; REAL tanaby2 = tan (aby2); REAL tanaby2sq = tanaby2 * tanaby2; REAL snum = tanaby2 + tanaby2, cnum = 1 - tanaby2sq, denom = 1 + tanaby2sq; REAL s = snum / denom, c = cnum / denom, t = (cnum < 2 / maxreal | -1 | snum / cnum); IF REAL sina = sin (a); REAL d1 = 2 * ABS (sina - s), d2 = ABS sina + ABS s; d2 /= zero THEN REAL d = (d1 / d2) / smallreal; sums +:= d; sumsqs +:= d * d; cs +:= 1; (d > maxs | maxs := d; ats := a) FI; IF REAL cosa = cos (a); REAL d1 = 2.0 * ABS (cosa - c), d2 = ABS cosa + ABS c; d2 /= zero THEN REAL d = (d1 / d2) / smallreal; sumc +:= d; sumsqc +:= d * d; cc +:= 1; (d > maxc | maxc := d; atc := a) FI; IF t >= zero THEN REAL tana = tan (a); REAL d1 = 2 * ABS (tana - t), d2 = ABS tana + ABS t; IF d2 /= zero THEN REAL d = (d1 / d2) / smallreal; sumt +:= d; sumsqt +:= d * d; ct +:= 1; (d > maxt | maxt := d; att := a) FI FI OD; PROC p = (STRING s, REAL max, at, sum, sumsq, INT c) VOID: (print ((newline, newline, s)); print ((newline, "Max. relative error = smallreal*")); print (fixed (max, -(realwidth % 2 + 1), realwidth % 2 - 1)); (max /= zero | print ((newline, "Occurred at x = ", at))); print ((newline, "Average relative error = smallreal*")); print (fixed (sum / c, -(realwidth % 2 + 1), realwidth % 2 - 1)); print ((newline, "R.M.S. relative error = smallreal*")); print (fixed (sqrt (sumsq / c), -(realwidth % 2 + 1), realwidth % 2 - 1))); p ("Checks on sin(a)=2*tan(a/2)/(1+tan(a/2)*2):", maxs, ats, sums, sumsqs, cs); p ("Checks on cos(a)=(1-tan(a/2)*2)/(1+tan(a/2)*2):", maxc, atc, sumc, sumsqc, cc); p ("Checks on tan(a)=2*tan(a/2)/(1-tan(a/2)*2):", maxt, att, sumt, sumsqt, ct) ENDalgol68g-2.8/test-set/a68g.mc.040.coer13.a680000644000175000001440000000147312224301224014550 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer13# BEGIN # Soft balance with EXIT's # INT i; [1 : 1] INT ri, rj; PROC pri = REF [] INT: rj; FOR c TO 3 DO ([] PROC VOID switch = (lrri, li, lpri); switch[c]; SKIP # hip # EXIT lrri: LOC REF [] INT := ri # deref # EXIT li: i # row # EXIT lpri: pri # deproc # ) := c OD; print ((ri, i, pri, newline)) # 1 2 3 # ENDalgol68g-2.8/test-set/a68g.mc.089.null01.a680000644000175000001440000000060512224301246014604 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #null01# BEGIN SKIP ENDalgol68g-2.8/test-set/a68g.ur.186.r542a.a680000644000175000001440000004511312224301303014350 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r542a # (print (("monadic formulas", newline)); INT vf = 18 * (8 + 2) + 33 * (8 + 2 + 5); INT ctrt := 0, ctr := 0, ctrloc; PROC ctrl = (INT inc) VOID: (ctr /= ctrloc + inc | print (("count er in test", ctrt, ctr, ctrloc + inc, newline))); MODE R = INT; PROC test = (INT a) VOID: (a = 1 | ctr +:= 1 | print (("er", ctrt, ctr - ctrloc, newline))); OP ?=:= = (INT x) INT: (test (x); x); # servitudes pour secondaires # INT b = 2, c = 3, d = 4, e = 5, f = 6, g = 7, h = 8, i = 9, j = 10; STRUCT (INT d2, d3, d4, d5, d6, d7, d8, d9, d0) str = (2, 3, 4, 5, 6, 7, 8, 9, 10); [, ] INT t = ((0, b, c, d, e, f, g, h, i, j), (1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), PROC call = (INT a) INT: (a = 0 | 10 | a), OP & = (BOOL a, INT b) STRUCT (INT a, b): (b, 0), & = (CHAR a, STRUCT (INT a, b) b) INT: a OF b; PRIO & = 3; # contextes demandant un mode : ent # (# definition des operateurs # OP M = (INT a) INT: (ctr +:= 1; a - 1); # nombre de monadiques : 1 # (ctrt := 1; ctrloc := ctr; test (M 2); FOR ident FROM M 2 BY M 2 TO M 2 WHILE 1 = (M 2) DO [M 2 : 4, -1 : M 2] R ent; ent[M 2, 0] := ent[1, M 2] := M 2; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M 2; REAL pi = 0.12345; M 2); test (par); alfa := ?=:=M 2; R ident = M 2, R loc := CASE M 2 IN M 2, SKIP ESAC, tas := M 2; test (ident); test (loc); test (tas); PROC proc = R: M 2, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M 2, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M 2, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M 2); UNION (R, CHAR) union := pr (proc, M 2, proc); test ((union | (R a): a)); (test (R BEGIN M 2 END), ?=:=(union; 1 = (M 2) | M 2), M 2, test ((BOOL bool = FALSE; union | (R): M 2, (CHAR car): SKIP))); ctrl (17 + 28 * 1)); (ctrt := 2; ctrloc := ctr; test (M b); FOR ident FROM M b BY M b TO M b WHILE 1 = (M b) DO [M b : 4, -1 : M b] R ent; ent[M b, 0] := ent[1, M b] := M b; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M b; REAL pi = 0.12345; M b); test (par); alfa := ?=:=M b; R ident = M b, R loc := CASE M b IN M b, SKIP ESAC, tas := M b; test (ident); test (loc); test (tas); PROC proc = R: M b, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M b, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M b, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M b); UNION (R, CHAR) union := pr (proc, M b, proc); test ((union | (R a): a)); (test (R BEGIN M b END), ?=:=(union; 1 = (M b) | M b), M b, test ((BOOL bool = FALSE; union | (R): M b, (CHAR car): SKIP))); ctrl (17 + 28 * 1)); (ctrt := 3; ctrloc := ctr; test (M d2 OF str); FOR ident FROM M d2 OF str BY M d2 OF str TO M d2 OF str WHILE 1 = (M d2 OF str) DO [M d2 OF str : 4, -1 : M d2 OF str] R ent; ent[M d2 OF str, 0] := ent[1, M d2 OF str] := M d2 OF str; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M d2 OF str; REAL pi = 0.12345; M d2 OF str); test (par); alfa := ?=:=M d2 OF str; R ident = M d2 OF str, R loc := CASE M d2 OF str IN M d2 OF str, SKIP ESAC, tas := M d2 OF str; test (ident); test (loc); test (tas); PROC proc = R: M d2 OF str, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M d2 OF str, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M d2 OF str, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M d2 OF str); UNION (R, CHAR) union := pr (proc, M d2 OF str, proc); test ((union | (R a): a)); (test (R BEGIN M d2 OF str END), ?=:=(union; 1 = (M d2 OF str) | M d2 OF str), M d2 OF str, test ((BOOL bool = FALSE; union | (R): M d2 OF str, (CHAR car): SKIP))); ctrl (17 + 28 * 1)); (ctrt := 4; ctrloc := ctr; test (M t[, b][2]); FOR ident FROM M t[, b][2] BY M t[, b][2] TO M t[, b][2] WHILE 1 = (M t[, b][2]) DO [M t[, b][2] : 4, -1 : M t[, b][2]] R ent; ent[M t[, b][2], 0] := ent[1, M t[, b][2]] := M t[, b][2]; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M t[, b][2]; REAL pi = 0.12345; M t[, b][2]); test (par); alfa := ?=:=M t[, b][2]; R ident = M t[, b][2], R loc := CASE M t[, b][2] IN M t[, b][2], SKIP ESAC, tas := M t[, b][2]; test (ident); test (loc); test (tas); PROC proc = R: M t[, b][2], STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M t[, b][2], (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M t[, b][2], proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M t[, b][2]); UNION (R, CHAR) union := pr (proc, M t[, b][2], proc); test ((union | (R a): a)); (test (R BEGIN M t[, b][2] END), ?=:=(union; 1 = (M t[, b][2]) | M t[, b][2]), M t[, b][2], test ((BOOL bool = FALSE; union | (R): M t[, b][2], (CHAR car): SKIP))); ctrl (17 + 28 * 1)); (ctrt := 5; ctrloc := ctr; test (M call (2)); FOR ident FROM M call (2) BY M call (2) TO M call (2) WHILE 1 = (M call (2)) DO [M call (2) : 4, -1 : M call (2)] R ent; ent[M call (2), 0] := ent[1, M call (2)] := M call (2); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M call (2); REAL pi = 0.12345; M call (2)); test (par); alfa := ?=:=M call (2); R ident = M call (2), R loc := CASE M call (2) IN M call (2), SKIP ESAC, tas := M call (2); test (ident); test (loc); test (tas); PROC proc = R: M call (2), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M call (2), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M call (2), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M call (2)); UNION (R, CHAR) union := pr (proc, M call (2), proc); test ((union | (R a): a)); (test (R BEGIN M call (2) END), ?=:=(union; 1 = (M call (2)) | M call (2)), M call (2), test ((BOOL bool = FALSE; union | (R): M call (2), (CHAR car): SKIP))); ctrl (17 + 28 * 1)); (ctrt := 6; ctrloc := ctr; test (M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI); FOR ident FROM M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI BY M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI TO M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI WHILE 1 = (M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI) DO [M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI : 4, -1 : M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI] R ent; ent[M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI, 0] := ent[1, M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI] := M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI; REAL pi = 0.12345; M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI); test (par); alfa := ?=:=M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI; R ident = M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI, R loc := CASE M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI IN M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI, SKIP ESAC, tas := M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI; test (ident); test (loc); test (tas); PROC proc = R: M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI); UNION (R, CHAR) union := pr (proc, M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI, proc); test ((union | (R a): a)); (test (R BEGIN M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI END), ?=:=(union; 1 = (M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI) | M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI), M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI, test ((BOOL bool = FALSE; union | (R): M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI, (CHAR car): SKIP))); ctrl (17 + 28 * 1)); (ctrt := 7; ctrloc := ctr; test (M (INT x := b; x)); FOR ident FROM M (INT x := b; x) BY M (INT x := b; x) TO M (INT x := b; x) WHILE 1 = (M (INT x := b; x)) DO [M (INT x := b; x) : 4, -1 : M (INT x := b; x)] R ent; ent[M (INT x := b; x), 0] := ent[1, M (INT x := b; x)] := M (INT x := b; x); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M (INT x := b; x); REAL pi = 0.12345; M (INT x := b; x)); test (par); alfa := ?=:=M (INT x := b; x); R ident = M (INT x := b; x), R loc := CASE M (INT x := b; x) IN M (INT x := b; x), SKIP ESAC, tas := M (INT x := b; x); test (ident); test (loc); test (tas); PROC proc = R: M (INT x := b; x), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M (INT x := b; x), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M (INT x := b; x), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M (INT x := b; x)); UNION (R, CHAR) union := pr (proc, M (INT x := b; x), proc); test ((union | (R a): a)); (test (R BEGIN M (INT x := b; x) END), ?=:=(union; 1 = (M (INT x := b; x)) | M (INT x := b; x)), M (INT x := b; x), test ((BOOL bool = FALSE; union | (R): M (INT x := b; x), (CHAR car): SKIP))); ctrl (17 + 28 * 1)); (ctrt := 8; ctrloc := ctr; test (M ("#" & (TRUE & 2))); FOR ident FROM M 2 BY M 2 TO M 2 WHILE 1 = (M 2) DO [M 2 : 4, -1 : M 2] R ent; ent[M 2, 0] := ent[1, M 2] := M 2; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M 2; REAL pi = 0.12345; M 2); test (par); alfa := ?=:=M 2; R ident = M 2, R loc := CASE M 2 IN M 2, SKIP ESAC, tas := M 2; test (ident); test (loc); test (tas); PROC proc = R: M 2, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M 2, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M 2, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M 2); UNION (R, CHAR) union := pr (proc, M 2, proc); test ((union | (R a): a)); (test (R BEGIN M 2 END), ?=:=(union; 1 = (M 2) | M 2), M 2, test ((BOOL bool = FALSE; union | (R): M 2, (CHAR car): SKIP))); ctrl (17 + 28 * 1)); # nombre de monadiques : 2 # (ctrt := 9; ctrloc := ctr; test (M M c); FOR ident FROM M M call (3) BY M M t[, c][2] TO M M t[, c][2] WHILE 1 = (M M d3 OF str) DO [M M 3 : 4, -1 : M M ("#" & (TRUE & c))] R ent; ent[M M (INT x := c; x), 0] := ent[1, M M 3] := M M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M M c; REAL pi = 0.12345; M M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI); test (par); alfa := ?=:=M M d3 OF str; R ident = M M t[, c][2], R loc := CASE M M call (3) IN M M c, SKIP ESAC, tas := M M (INT x := c; x); test (ident); test (loc); test (tas); PROC proc = R: M M (INT x := c; x), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M M call (3)); UNION (R, CHAR) union := pr (proc, M M call (3), proc); test ((union | (R a): a)); (test (R BEGIN M M call (3) END), ?=:=(union; 1 = (M M d3 OF str) | M M d3 OF str), M M d3 OF str, test ((BOOL bool = FALSE; union | (R): M M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI, (CHAR car): SKIP))); ctrl (17 + 28 * 2)); # nombre de monadiques : 5 # (ctrt := 10; ctrloc := ctr; test (M M M M M ("#" & (TRUE & d6 OF str))); FOR ident FROM M M M M M t[, f][2] BY M M M M M PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI TO M M M M M PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI WHILE 1 = (M M M M M 6) DO [M M M M M (INT x := f; x) : 4, -1 : M M M M M (INT x := f; x)] R ent; ent[M M M M M t[, f][2], 0] := ent[1, M M M M M call (6)] := M M M M M t[, f][2]; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M M M M M PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI; REAL pi = 0.12345; M M M M M t[, f][2]); test (par); alfa := ?=:=M M M M M f; R ident = M M M M M (INT x := f; x), R loc := CASE M M M M M (INT x := f; x) IN M M M M M (INT x := f; x), SKIP ESAC, tas := M M M M M (INT x := f; x); test (ident); test (loc); test (tas); PROC proc = R: M M M M M f, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M M M M M call (6), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M M M M M call (6), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M M M M M call (6)); UNION (R, CHAR) union := pr (proc, M M M M M PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI, proc); test ((union | (R a): a)); (test (R BEGIN M M M M M t[, f][2] END), ?=:=(union; 1 = (M M M M M t[, f][2]) | M M M M M f), M M M M M f, test ((BOOL bool = FALSE; union | (R): M M M M M t[, f][2], (CHAR car): SKIP))); ctrl (17 + 28 * 5)); SKIP); # contextes demandant un mode : rep # (OP M = (INT a) REF INT: HEAP INT := (ctr +:= 1; a - 1); # nombre de operateurs : 1 # ctrt := 11; ctrloc := ctr; test (M 2 := M 2 := (M 2 :/=: M 2 | M 2)); ctrl (1 + 5 * 1); ctrt := 12; ctrloc := ctr; test (M b := M b := (M b :/=: M b | M b)); ctrl (1 + 5 * 1); ctrt := 13; ctrloc := ctr; test (M d2 OF str := M d2 OF str := (M d2 OF str :/=: M d2 OF str | M d2 OF str)); ctrl (1 + 5 * 1); ctrt := 14; ctrloc := ctr; test (M t[, b][2] := M t[, b][2] := (M t[, b][2] :/=: M t[, b][2] | M t[, b][2])); ctrl (1 + 5 * 1); ctrt := 15; ctrloc := ctr; test (M call (2) := M call (2) := (M call (2) :/=: M call (2) | M call (2))); ctrl (1 + 5 * 1); ctrt := 16; ctrloc := ctr; test (M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI := M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI := (M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI :/=: M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI | M PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI)); ctrl (1 + 5 * 1); ctrt := 17; ctrloc := ctr; test (M (INT x := b; x) := M (INT x := b; x) := (M (INT x := b; x) :/=: M (INT x := b; x) | M (INT x := b; x))); ctrl (1 + 5 * 1); ctrt := 18; ctrloc := ctr; test (M ("#" & (TRUE & call (2))) := M call (2) := (M call (2) :/=: M call (2) | M call (2))); ctrl (1 + 5 * 1); # nombre de operateurs : 2 # ctrt := 19; ctrloc := ctr; test (M M t[, c][2] := M M ("#" & (TRUE & t[, c][2])) := (M M d3 OF str :/=: M M call (3) | M M c)); ctrl (1 + 5 * 2); # nombre de operateurs : 5 # ctrt := 20; ctrloc := ctr; test (M M M M M f := M M M M M PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI := (M M M M M t[, f][2] :/=: M M M M M t[, f][2] | M M M M M 6)); ctrl (1 + 5 * 5); SKIP); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.154.smio04.a680000644000175000001440000000617712224301262014605 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio04# BEGIN # 10/08/73, R van Vliet; 30/09/75, revised. Test the print and putroutines.# INT max ch n = # actual max char, formerly max char[standout channel] # (FILE f:= standout; INT i; on line end(f, (REF FILE f)BOOL: GOTO out); DO put(f, space) OD; out: i:= char number(f) -1; TO i DO put(f, backspace) OD; i); print(("Test 2", new line, "Test layout-procedures", new line, newline)); print((new line, "Check space, backspace and character number", newline)); BEGIN INT inspect, k; PROC ilchcount =VOID: (INT i =char number(standout); print((newline, "Illegal character number", i, "at position", k, newline)); GOTO printdots ); BOOL line end; FILE auxout:=standout; on line end ( auxout ,(REF FILE f)BOOL: ( inspect :=char number(standout); print(backspace); line end := TRUE) ); BEGIN k:= 1; line end := FALSE #'on line end' not called yet#; WHILE NOT line end DO IF char number (standout) NE k #Check the character count. Be aware that 'auxout' and 'standout' refer to the same book.# THEN ilchcount ELSE k +:=1; put(auxout, space) FI #end of line reached# OD; IF max ch n /= inspect -1 THEN print((newline, "Not all lines of standout have the same length", newline)) FI; k -:= 1; line end := FALSE; TO max ch n DO IF k NE char number(standout) THEN ilchcount ELSE k -:=1; put(auxout, backspace) FI # back at the beginning of the line# OD; print((new line, "This line should be preceded by one blank line")); print((new line, "Char number of standout is at most", max ch n, new line)) END; printdots: print((new line, "Print 3 lines, having a dot at every second position", newline)); (BY 2 TO max ch n -1 DO print((space, ".")) OD; print(new line); TO (ODD max ch n | max ch n -1 | max ch n) DO print(space) OD; FROM char number(standout) BY -2 TO 3 DO print((backspace, ".", backspace, backspace)) OD; print(new line); BY 2 TO max ch n -1 DO print((space, space, backspace, backspace, space, ".")) OD; print(new line) ) END; print((new line, "A check on lines and pages", newline)); BEGIN PROC print lp = VOID: print(("Line number", line number(standout), ", page number", page number(standout), ".", new line)); print lp; print(new line); print lp; print(new page); print lp END END algol68g-2.8/test-set/a68g.ur.187.r542b.a680000644000175000001440000011046312224301304014354 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r542b # (print (("dyadic formulas", newline)); INT vf = 17 * (8 + 2) + 28 * (8 * 4 + 15 + 14); INT ctrt := 0, ctr := 0, ctrloc; PROC ctrl = (INT inc) VOID: (ctr /= ctrloc + inc | print (("count er in test", ctrt, ctr, ctrloc + inc, newline))); MODE R = INT; PROC test = (INT a) VOID: (a = 1 | ctr +:= 1 | print (("er", ctrt, ctr - ctrloc, newline))); OP ?=:= = (INT x) INT: (test (x); x); # servitudes pour secondaires # INT b = 2, c = 3, d = 4, e = 5, f = 6, g = 7, h = 8, i = 9, j = 10; STRUCT (INT d2, d3, d4, d5, d6, d7, d8, d9, d0) str = (2, 3, 4, 5, 6, 7, 8, 9, 10); [, ] INT t = ((0, b, c, d, e, f, g, h, i, j), (1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), PROC call = (INT a) INT: (a = 0 | 10 | a), OP & = (BOOL a, INT b) STRUCT (INT a, b): (b, 0), & = (CHAR a, STRUCT (INT a, b) b) INT: a OF b; PRIO & = 3; PRIO A = 1, B = 2, C = 3, D = 4, E = 5, F = 6, G = 7, H = 8, I = 9; # contextes demandant un mode : ent # (# definition des operateurs # OP M = (INT a) INT: (ctr +:= 1; a - 1); PROC dyad = (INT a, b) INT: ((a = b | ctr +:= 1 | print (("er.prio", ctrt, ctr - ctrloc, a, b, newline))); a - 1); OP (INT, INT) INT A = dyad, B = dyad, C = dyad, D = dyad, E = dyad, F = dyad, G = dyad, H = dyad, I = dyad; # nombre de operateurs : 4 # (ctrt := 1; ctrloc := ctr; test (M 3 D M M 4); FOR ident FROM M 3 D M M 4 BY M 3 D M M 4 TO M 3 D M M 4 WHILE 1 = (M 3 D M M 4) DO [M 3 D M M 4 : 4, -1 : M 3 D M M 4] R ent; ent[M 3 D M M 4, 0] := ent[1, M 3 D M M 4] := M 3 D M M 4; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M 3 D M M 4; REAL pi = 0.12345; M 3 D M M 4); test (par); alfa := ?=:=(M 3 D M M 4); R ident = M 3 D M M 4, R loc := CASE M 3 D M M 4 IN M 3 D M M 4, SKIP ESAC, tas := M 3 D M M 4; test (ident); test (loc); test (tas); PROC proc = R: M 3 D M M 4, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M 3 D M M 4, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M 3 D M M 4, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M 3 D M M 4); UNION (R, CHAR) union := pr (proc, M 3 D M M 4, proc); test ((union | (R a): a)); (test (R BEGIN M 3 D M M 4 END), ?=:=(union; 1 = (M 3 D M M 4) | M 3 D M M 4), M 3 D M M 4, test ((BOOL bool = FALSE; union | (R): M 3 D M M 4, (CHAR car): SKIP))); ctrl (17 + 28 * 4)); (ctrt := 2; ctrloc := ctr; test (M c D M M d); FOR ident FROM M c D M M d BY M c D M M d TO M c D M M d WHILE 1 = (M c D M M d) DO [M c D M M d : 4, -1 : M c D M M d] R ent; ent[M c D M M d, 0] := ent[1, M c D M M d] := M c D M M d; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M c D M M d; REAL pi = 0.12345; M c D M M d); test (par); alfa := ?=:=(M c D M M d); R ident = M c D M M d, R loc := CASE M c D M M d IN M c D M M d, SKIP ESAC, tas := M c D M M d; test (ident); test (loc); test (tas); PROC proc = R: M c D M M d, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M c D M M d, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M c D M M d, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M c D M M d); UNION (R, CHAR) union := pr (proc, M c D M M d, proc); test ((union | (R a): a)); (test (R BEGIN M c D M M d END), ?=:=(union; 1 = (M c D M M d) | M c D M M d), M c D M M d, test ((BOOL bool = FALSE; union | (R): M c D M M d, (CHAR car): SKIP))); ctrl (17 + 28 * 4)); (ctrt := 3; ctrloc := ctr; test (M d3 OF str D M M d4 OF str); FOR ident FROM M d3 OF str D M M d4 OF str BY M d3 OF str D M M d4 OF str TO M d3 OF str D M M d4 OF str WHILE 1 = (M d3 OF str D M M d4 OF str) DO [M d3 OF str D M M d4 OF str : 4, -1 : M d3 OF str D M M d4 OF str] R ent; ent[M d3 OF str D M M d4 OF str, 0] := ent[1, M d3 OF str D M M d4 OF str] := M d3 OF str D M M d4 OF str; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M d3 OF str D M M d4 OF str; REAL pi = 0.12345; M d3 OF str D M M d4 OF str); test (par); alfa := ?=:=(M d3 OF str D M M d4 OF str); R ident = M d3 OF str D M M d4 OF str, R loc := CASE M d3 OF str D M M d4 OF str IN M d3 OF str D M M d4 OF str, SKIP ESAC, tas := M d3 OF str D M M d4 OF str; test (ident); test (loc); test (tas); PROC proc = R: M d3 OF str D M M d4 OF str, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M d3 OF str D M M d4 OF str, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M d3 OF str D M M d4 OF str, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M d3 OF str D M M d4 OF str); UNION (R, CHAR) union := pr (proc, M d3 OF str D M M d4 OF str, proc); test ((union | (R a): a)); (test (R BEGIN M d3 OF str D M M d4 OF str END), ?=:=(union; 1 = (M d3 OF str D M M d4 OF str) | M d3 OF str D M M d4 OF str), M d3 OF str D M M d4 OF str, test ((BOOL bool = FALSE; union | (R): M d3 OF str D M M d4 OF str, (CHAR car): SKIP))); ctrl (17 + 28 * 4)); (ctrt := 4; ctrloc := ctr; test (M t[, c][2] D M M t[, d][2]); FOR ident FROM M t[, c][2] D M M t[, d][2] BY M t[, c][2] D M M t[, d][2] TO M t[, c][2] D M M t[, d][2] WHILE 1 = (M t[, c][2] D M M t[, d][2]) DO [M t[, c][2] D M M t[, d][2] : 4, -1 : M t[, c][2] D M M t[, d][2]] R ent; ent[M t[, c][2] D M M t[, d][2], 0] := ent[1, M t[, c][2] D M M t[, d][2]] := M t[, c][2] D M M t[, d][2]; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M t[, c][2] D M M t[, d][2]; REAL pi = 0.12345; M t[, c][2] D M M t[, d][2]); test (par); alfa := ?=:=(M t[, c][2] D M M t[, d][2]); R ident = M t[, c][2] D M M t[, d][2], R loc := CASE M t[, c][2] D M M t[, d][2] IN M t[, c][2] D M M t[, d][2], SKIP ESAC, tas := M t[, c][2] D M M t[, d][2]; test (ident); test (loc); test (tas); PROC proc = R: M t[, c][2] D M M t[, d][2], STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M t[, c][2] D M M t[, d][2], (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M t[, c][2] D M M t[, d][2], proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M t[, c][2] D M M t[, d][2]); UNION (R, CHAR) union := pr (proc, M t[, c][2] D M M t[, d][2], proc); test ((union | (R a): a)); (test (R BEGIN M t[, c][2] D M M t[, d][2] END), ?=:=(union; 1 = (M t[, c][2] D M M t[, d][2]) | M t[, c][2] D M M t[, d][2]), M t[, c][2] D M M t[, d][2], test ((BOOL bool = FALSE; union | (R): M t[, c][2] D M M t[, d][2], (CHAR car): SKIP))); ctrl (17 + 28 * 4)); (ctrt := 5; ctrloc := ctr; test (M call (3) D M M call (4)); FOR ident FROM M call (3) D M M call (4) BY M call (3) D M M call (4) TO M call (3) D M M call (4) WHILE 1 = (M call (3) D M M call (4)) DO [M call (3) D M M call (4) : 4, -1 : M call (3) D M M call (4)] R ent; ent[M call (3) D M M call (4), 0] := ent[1, M call (3) D M M call (4)] := M call (3) D M M call (4); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M call (3) D M M call (4); REAL pi = 0.12345; M call (3) D M M call (4)); test (par); alfa := ?=:=(M call (3) D M M call (4)); R ident = M call (3) D M M call (4), R loc := CASE M call (3) D M M call (4) IN M call (3) D M M call (4), SKIP ESAC, tas := M call (3) D M M call (4); test (ident); test (loc); test (tas); PROC proc = R: M call (3) D M M call (4), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M call (3) D M M call (4), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M call (3) D M M call (4), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M call (3) D M M call (4)); UNION (R, CHAR) union := pr (proc, M call (3) D M M call (4), proc); test ((union | (R a): a)); (test (R BEGIN M call (3) D M M call (4) END), ?=:=(union; 1 = (M call (3) D M M call (4)) | M call (3) D M M call (4)), M call (3) D M M call (4), test ((BOOL bool = FALSE; union | (R): M call (3) D M M call (4), (CHAR car): SKIP))); ctrl (17 + 28 * 4)); (ctrt := 6; ctrloc := ctr; test (M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI); FOR ident FROM M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI BY M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI TO M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI WHILE 1 = (M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI) DO [M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI : 4, -1 : M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI] R ent; ent[M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, 0] := ent[1, M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI] := M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI; REAL pi = 0.12345; M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI); test (par); alfa := ?=:=(M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI); R ident = M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, R loc := CASE M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI IN M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, SKIP ESAC, tas := M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI; test (ident); test (loc); test (tas); PROC proc = R: M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI); UNION (R, CHAR) union := pr (proc, M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, proc); test ((union | (R a): a)); (test (R BEGIN M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI END), ?=:=(union; 1 = (M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI) | M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI), M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, test ((BOOL bool = FALSE; union | (R): M PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI D M M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, (CHAR car): SKIP))); ctrl (17 + 28 * 4)); (ctrt := 7; ctrloc := ctr; test (M (INT x := c; x) D M M (INT x := d; x)); FOR ident FROM M (INT x := c; x) D M M (INT x := d; x) BY M (INT x := c; x) D M M (INT x := d; x) TO M (INT x := c; x) D M M (INT x := d; x) WHILE 1 = (M (INT x := c; x) D M M (INT x := d; x)) DO [M (INT x := c; x) D M M (INT x := d; x) : 4, -1 : M (INT x := c; x) D M M (INT x := d; x)] R ent; ent[M (INT x := c; x) D M M (INT x := d; x), 0] := ent[1, M (INT x := c; x) D M M (INT x := d; x)] := M (INT x := c; x) D M M (INT x := d; x); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M (INT x := c; x) D M M (INT x := d; x); REAL pi = 0.12345; M (INT x := c; x) D M M (INT x := d; x)); test (par); alfa := ?=:=(M (INT x := c; x) D M M (INT x := d; x)); R ident = M (INT x := c; x) D M M (INT x := d; x), R loc := CASE M (INT x := c; x) D M M (INT x := d; x) IN M (INT x := c; x) D M M (INT x := d; x), SKIP ESAC, tas := M (INT x := c; x) D M M (INT x := d; x); test (ident); test (loc); test (tas); PROC proc = R: M (INT x := c; x) D M M (INT x := d; x), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M (INT x := c; x) D M M (INT x := d; x), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M (INT x := c; x) D M M (INT x := d; x), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M (INT x := c; x) D M M (INT x := d; x)); UNION (R, CHAR) union := pr (proc, M (INT x := c; x) D M M (INT x := d; x), proc); test ((union | (R a): a)); (test (R BEGIN M (INT x := c; x) D M M (INT x := d; x) END), ?=:=(union; 1 = (M (INT x := c; x) D M M (INT x := d; x)) | M (INT x := c; x) D M M (INT x := d; x)), M (INT x := c; x) D M M (INT x := d; x), test ((BOOL bool = FALSE; union | (R): M (INT x := c; x) D M M (INT x := d; x), (CHAR car): SKIP))); ctrl (17 + 28 * 4)); (ctrt := 8; ctrloc := ctr; test (M ("#" & (TRUE & 3)) D M M ("#" & (TRUE & d))); FOR ident FROM M ("#" & (TRUE & call (3))) D M M ("#" & (TRUE & t[, d][2])) BY M ("#" & (TRUE & t[, c][2])) D M M ("#" & (TRUE & d4 OF str)) TO M ("#" & (TRUE & 3)) D M M ("#" & (TRUE & ("#" & (TRUE & d)))) WHILE 1 = (M ("#" & (TRUE & (INT x := c; x))) D M M ("#" & (TRUE & 4))) DO [M ("#" & (TRUE & PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI)) D M M ("#" & (TRUE & d)) : 4, -1 : M ("#" & (TRUE & PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI)) D M M ("#" & (TRUE & d4 OF str))] R ent; ent[M ("#" & (TRUE & t[, c][2])) D M M ("#" & (TRUE & call (4))), 0] := ent[1, M ("#" & (TRUE & c)) D M M ("#" & (TRUE & (INT x := d; x)))] := M ("#" & (TRUE & (INT x := c; x))) D M M ("#" & (TRUE & PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI)); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M ("#" & (TRUE & PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI)) D M M ("#" & (TRUE & call (4))); REAL pi = 0.12345; M ("#" & (TRUE & call (3))) D M M ("#" & (TRUE & call (4)))); test (par); alfa := ?=:=(M ("#" & (TRUE & d3 OF str)) D M M ("#" & (TRUE & d4 OF str))); R ident = M ("#" & (TRUE & d3 OF str)) D M M ("#" & (TRUE & PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI)), R loc := CASE M ("#" & (TRUE & ("#" & (TRUE & d3 OF str)))) D M M ("#" & (TRUE & t[, d][2])) IN M ("#" & (TRUE & PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI)) D M M ("#" & (TRUE & PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI)), SKIP ESAC, tas := M ("#" & (TRUE & 3)) D M M ("#" & (TRUE & (INT x := d; x))); test (ident); test (loc); test (tas); PROC proc = R: M ("#" & (TRUE & (INT x := c; x))) D M M ("#" & (TRUE & t[, d][2])), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M ("#" & (TRUE & call (3))) D M M ("#" & (TRUE & t[, d][2])), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M ("#" & (TRUE & PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI)) D M M ("#" & (TRUE & t[, d][2])), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M ("#" & (TRUE & c)) D M M ("#" & (TRUE & (INT x := d; x)))); UNION (R, CHAR) union := pr (proc, M ("#" & (TRUE & (INT x := c; x))) D M M ("#" & (TRUE & (INT x := d; x))), proc); test ((union | (R a): a)); (test (R BEGIN M ("#" & (TRUE & (INT x := c; x))) D M M ("#" & (TRUE & d)) END), ?=:=(union; 1 = (M ("#" & (TRUE & call (3))) D M M ("#" & (TRUE & call (4)))) | M ("#" & (TRUE & call (3))) D M M ("#" & (TRUE & PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI))), M ("#" & (TRUE & t[, c][2])) D M M ("#" & (TRUE & t[, d][2])), test ((BOOL bool = FALSE; union | (R): M ("#" & (TRUE & c)) D M M ("#" & (TRUE & d)), (CHAR car): SKIP))); ctrl (17 + 28 * 4)); # nombre de operateurs : 15 # (ctrt := 9; ctrloc := ctr; test (t[, b][2] A M call (5) C t[, f][2] E M M ("#" & (TRUE & t[, j][2])) G d0 OF str I call (0) H i F M M i D PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI B M t[, d][2]); FOR ident FROM t[, b][2] A M 5 C (INT x := f; x) E M M d0 OF str G j I d0 OF str H d9 OF str F M M t[, i][2] D d5 OF str B M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI BY ("#" & (TRUE & (INT x := b; x))) A M PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI C t[, f][2] E M M j G j I 10 H 9 F M M d9 OF str D e B M 4 TO d2 OF str A M (INT x := e; x) C call (6) E M M d0 OF str G PROC INT IF 0 = 0 THEN INT: 10 ELSE INT: 0 FI I j H (INT x := i; x) F M M d9 OF str D call (5) B M 4 WHILE 1 = (d2 OF str A M t[, e][2] C call (6) E M M ("#" & (TRUE & t[, j][2])) G call (0) I PROC INT IF 0 = 0 THEN INT: 10 ELSE INT: 0 FI H 9 F M M d9 OF str D ("#" & (TRUE & e)) B M t[, d][2]) DO [("#" & (TRUE & b)) A M (INT x := e; x) C ("#" & (TRUE & PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI)) E M M d0 OF str G ("#" & (TRUE & d0 OF str)) I 10 H (INT x := i; x) F M M t[, i][2] D (INT x := e; x) B M d : 4, -1 : call (2) A M call (5) C call (6) E M M 10 G t[, j][2] I t[, j][2] H PROC INT IF 9 = 0 THEN INT: 10 ELSE INT: 9 FI F M M call (9) D t[, e][2] B M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI] R ent; ent[b A M e C d6 OF str E M M call (0) G j I (INT x := j; x) H d9 OF str F M M d9 OF str D PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI B M call (4), 0] := ent[1, t[, b][2] A M t[, e][2] C call (6) E M M ("#" & (TRUE & 10)) G t[, j][2] I j H 9 F M M ("#" & (TRUE & d9 OF str)) D ("#" & (TRUE & d5 OF str)) B M d] := b A M 5 C ("#" & (TRUE & d6 OF str)) E M M PROC INT IF 0 = 0 THEN INT: 10 ELSE INT: 0 FI G j I (INT x := j; x) H i F M M 9 D PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI B M ("#" & (TRUE & 4)); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; ("#" & (TRUE & b)) A M (INT x := e; x) C ("#" & (TRUE & t[, f][2])) E M M (INT x := j; x) G PROC INT IF 0 = 0 THEN INT: 10 ELSE INT: 0 FI I d0 OF str H i F M M t[, i][2] D e B M t[, d][2]; REAL pi = 0.12345; b A M call (5) C f E M M ("#" & (TRUE & ("#" & (TRUE & d0 OF str)))) G j I 10 H 9 F M M d9 OF str D PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI B M d4 OF str); test (par); alfa := ?=:=(2 A M ("#" & (TRUE & ("#" & (TRUE & (INT x := e; x))))) C d6 OF str E M M call (0) G ("#" & (TRUE & d0 OF str)) I call (0) H 9 F M M t[, i][2] D PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI B M ("#" & (TRUE & PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI))); R ident = PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI A M d5 OF str C ("#" & (TRUE & 6)) E M M d0 OF str G call (0) I ("#" & (TRUE & PROC INT IF 0 = 0 THEN INT: 10 ELSE INT: 0 FI)) H PROC INT IF 9 = 0 THEN INT: 10 ELSE INT: 9 FI F M M PROC INT IF 9 = 0 THEN INT: 10 ELSE INT: 9 FI D 5 B M d, R loc := CASE (INT x := b; x) A M e C d6 OF str E M M call (0) G j I call (0) H PROC INT IF 9 = 0 THEN INT: 10 ELSE INT: 9 FI F M M d9 OF str D PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI B M (INT x := d; x) IN ("#" & (TRUE & t[, b][2])) A M call (5) C call (6) E M M d0 OF str G PROC INT IF 0 = 0 THEN INT: 10 ELSE INT: 0 FI I t[, j][2] H ("#" & (TRUE & 9)) F M M 9 D PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI B M ("#" & (TRUE & (INT x := d; x))), SKIP ESAC, tas := PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI A M call (5) C f E M M 10 G (INT x := j; x) I call (0) H t[, i][2] F M M 9 D d5 OF str B M (INT x := d; x); test (ident); test (loc); test (tas); PROC proc = R: b A M call (5) C 6 E M M call (0) G d0 OF str I d0 OF str H t[, i][2] F M M i D ("#" & (TRUE & PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI)) B M ("#" & (TRUE & d4 OF str)), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (call (2) A M t[, e][2] C 6 E M M j G d0 OF str I t[, j][2] H t[, i][2] F M M d9 OF str D e B M PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, 2 A M e C 6 E M M t[, j][2] G ("#" & (TRUE & j)) I PROC INT IF 0 = 0 THEN INT: 10 ELSE INT: 0 FI H t[, i][2] F M M t[, i][2] D t[, e][2] B M call (4), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); d2 OF str A M (INT x := e; x) C (INT x := f; x) E M M 10 G d0 OF str I 10 H t[, i][2] F M M i D d5 OF str B M call (4)); UNION (R, CHAR) union := pr (proc, (INT x := b; x) A M call (5) C (INT x := f; x) E M M call (0) G call (0) I PROC INT IF 0 = 0 THEN INT: 10 ELSE INT: 0 FI H t[, i][2] F M M t[, i][2] D PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI B M d4 OF str, proc); test ((union | (R a): a)); (test (R BEGIN PROC INT IF 2 = 0 THEN INT: 10 ELSE INT: 2 FI A M 5 C PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI E M M call (0) G (INT x := j; x) I 10 H PROC INT IF 9 = 0 THEN INT: 10 ELSE INT: 9 FI F M M i D (INT x := e; x) B M ("#" & (TRUE & d)) END), ?=:=(union; 1 = (call (2) A M ("#" & (TRUE & d5 OF str)) C d6 OF str E M M (INT x := j; x) G t[, j][2] I (INT x := j; x) H t[, i][2] F M M ("#" & (TRUE & call (9))) D call (5) B M t[, d][2]) | 2 A M PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI C (INT x := f; x) E M M 10 G d0 OF str I (INT x := j; x) H ("#" & (TRUE & call (9))) F M M ("#" & (TRUE & ("#" & (TRUE & t[, i][2])))) D 5 B M d4 OF str), 2 A M call (5) C (INT x := f; x) E M M j G (INT x := j; x) I j H d9 OF str F M M call (9) D e B M call (4), test ((BOOL bool = FALSE; union | (R): b A M (INT x := e; x) C d6 OF str E M M d0 OF str G t[, j][2] I ("#" & (TRUE & t[, j][2])) H ("#" & (TRUE & 9)) F M M (INT x := i; x) D e B M (INT x := d; x), (CHAR car): SKIP))); ctrl (17 + 28 * 15)); # nombre de operateurs : 14 # (ctrt := 10; ctrloc := ctr; test (M (INT x := h; x) H call (7) E M 7 E e C M M 6 C (INT x := c; x) C PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI E d4 OF str E M 5 H (INT x := d; x)); FOR ident FROM M h H g E M t[, g][2] E e C M M d6 OF str C d3 OF str C (INT x := d; x) E 4 E M (INT x := e; x) H call (4) BY M (INT x := h; x) H t[, g][2] E M PROC INT IF 7 = 0 THEN INT: 10 ELSE INT: 7 FI E ("#" & (TRUE & PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI)) C M M d6 OF str C (INT x := c; x) C call (4) E d E M ("#" & (TRUE & PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI)) H PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI TO M d8 OF str H t[, g][2] E M ("#" & (TRUE & (INT x := g; x))) E d5 OF str C M M f C d3 OF str C d E (INT x := d; x) E M call (5) H 4 WHILE 1 = (M ("#" & (TRUE & PROC INT IF 8 = 0 THEN INT: 10 ELSE INT: 8 FI)) H (INT x := g; x) E M ("#" & (TRUE & g)) E ("#" & (TRUE & e)) C M M d6 OF str C (INT x := c; x) C call (4) E (INT x := d; x) E M t[, e][2] H PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI) DO [M h H g E M (INT x := g; x) E 5 C M M (INT x := f; x) C ("#" & (TRUE & t[, c][2])) C d E PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI E M 5 H d4 OF str : 4, -1 : M call (8) H PROC INT IF 7 = 0 THEN INT: 10 ELSE INT: 7 FI E M call (7) E 5 C M M ("#" & (TRUE & d6 OF str)) C ("#" & (TRUE & PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI)) C ("#" & (TRUE & call (4))) E d E M PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI H PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI] R ent; ent[M PROC INT IF 8 = 0 THEN INT: 10 ELSE INT: 8 FI H g E M (INT x := g; x) E d5 OF str C M M 6 C (INT x := c; x) C t[, d][2] E call (4) E M call (5) H d4 OF str, 0] := ent[1, M d8 OF str H 7 E M call (7) E t[, e][2] C M M (INT x := f; x) C 3 C PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI E (INT x := d; x) E M (INT x := e; x) H (INT x := d; x)] := M ("#" & (TRUE & PROC INT IF 8 = 0 THEN INT: 10 ELSE INT: 8 FI)) H d7 OF str E M call (7) E (INT x := e; x) C M M PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI C d3 OF str C d E 4 E M PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI H call (4); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; M h H call (7) E M (INT x := g; x) E ("#" & (TRUE & (INT x := e; x))) C M M t[, f][2] C 3 C call (4) E d4 OF str E M ("#" & (TRUE & call (5))) H call (4); REAL pi = 0.12345; M call (8) H call (7) E M call (7) E d5 OF str C M M PROC INT IF 6 = 0 THEN INT: 10 ELSE INT: 6 FI C PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI C call (4) E call (4) E M (INT x := e; x) H (INT x := d; x)); test (par); alfa := ?=:=(M (INT x := h; x) H PROC INT IF 7 = 0 THEN INT: 10 ELSE INT: 7 FI E M call (7) E e C M M ("#" & (TRUE & ("#" & (TRUE & d6 OF str)))) C call (3) C 4 E d4 OF str E M 5 H t[, d][2]); R ident = M (INT x := h; x) H call (7) E M ("#" & (TRUE & PROC INT IF 7 = 0 THEN INT: 10 ELSE INT: 7 FI)) E d5 OF str C M M (INT x := f; x) C t[, c][2] C d E d4 OF str E M (INT x := e; x) H ("#" & (TRUE & call (4))), R loc := CASE M PROC INT IF 8 = 0 THEN INT: 10 ELSE INT: 8 FI H call (7) E M d7 OF str E t[, e][2] C M M d6 OF str C t[, c][2] C PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI E t[, d][2] E M t[, e][2] H t[, d][2] IN M t[, h][2] H 7 E M g E ("#" & (TRUE & (INT x := e; x))) C M M f C t[, c][2] C 4 E PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI E M d5 OF str H call (4), SKIP ESAC, tas := M ("#" & (TRUE & d8 OF str)) H g E M call (7) E e C M M call (6) C d3 OF str C 4 E d E M 5 H PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI; test (ident); test (loc); test (tas); PROC proc = R: M d8 OF str H (INT x := g; x) E M g E t[, e][2] C M M call (6) C t[, c][2] C d E d4 OF str E M 5 H t[, d][2], STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (M t[, h][2] H t[, g][2] E M 7 E t[, e][2] C M M 6 C t[, c][2] C ("#" & (TRUE & ("#" & (TRUE & ("#" & (TRUE & 4)))))) E call (4) E M 5 H 4, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, M (INT x := h; x) H t[, g][2] E M 7 E call (5) C M M t[, f][2] C PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI C d E PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI E M 5 H PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); M 8 H 7 E M call (7) E ("#" & (TRUE & PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI)) C M M f C (INT x := c; x) C (INT x := d; x) E d E M ("#" & (TRUE & ("#" & (TRUE & call (5))))) H ("#" & (TRUE & d))); UNION (R, CHAR) union := pr (proc, M d8 OF str H d7 OF str E M g E call (5) C M M call (6) C PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI C (INT x := d; x) E t[, d][2] E M ("#" & (TRUE & call (5))) H d4 OF str, proc); test ((union | (R a): a)); (test (R BEGIN M PROC INT IF 8 = 0 THEN INT: 10 ELSE INT: 8 FI H PROC INT IF 7 = 0 THEN INT: 10 ELSE INT: 7 FI E M t[, g][2] E ("#" & (TRUE & e)) C M M ("#" & (TRUE & ("#" & (TRUE & (INT x := f; x))))) C PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI C t[, d][2] E t[, d][2] E M d5 OF str H ("#" & (TRUE & PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI)) END), ?=:=(union; 1 = (M d8 OF str H call (7) E M t[, g][2] E call (5) C M M f C (INT x := c; x) C 4 E PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI E M t[, e][2] H 4) | M h H g E M 7 E PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI C M M f C ("#" & (TRUE & (INT x := c; x))) C t[, d][2] E call (4) E M 5 H PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI), M 8 H 7 E M g E (INT x := e; x) C M M (INT x := f; x) C PROC INT IF 3 = 0 THEN INT: 10 ELSE INT: 3 FI C 4 E call (4) E M t[, e][2] H ("#" & (TRUE & d4 OF str)), test ((BOOL bool = FALSE; union | (R): M ("#" & (TRUE & h)) H 7 E M d7 OF str E call (5) C M M call (6) C call (3) C PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI E PROC INT IF 4 = 0 THEN INT: 10 ELSE INT: 4 FI E M PROC INT IF 5 = 0 THEN INT: 10 ELSE INT: 5 FI H d4 OF str, (CHAR car): SKIP))); ctrl (17 + 28 * 14)); SKIP); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.018.appl18.a680000644000175000001440000003527612224301220014572 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl18# # Happy family, taken from: C.H. Lindsey and S.G. van der Meulen, "Informal Introduction to ALGOL 68", Revised edition # BEGIN COMMENT This example concerns people: COMMENT MODE PERSON = STRUCT (STRING surname, given # name #, REF PERSON father, mother, wife # or husband #, FLEX [1:0] REF PERSON children, BOOL dead, male); BOOL male = TRUE, female = FALSE, alive = FALSE, dead = TRUE; REF PERSON nobody = NIL; COMMENT Sometimes it will be convenient to have a PERSON's given name and surname together: COMMENT PROC names = (REF PERSON pers) STRUCT(STRING given, surname): (given OF pers, surname OF pers); COMMENT All our formal-parameters will be of mode REF PERSON rather than PERSON, to save making unnecessary copies of PERSON's (which are rather large) at run time. COMMENT COMMENT Here is a procedure that will be used to add a little random spice to the messages that we shall produce. It yields a random integer in the range specified by its parameter. COMMENT PROC randint = (INT range) INT: 1 + ENTIER (random*range); read(last random); # to start it off # COMMENT This program is going to print texts of variable length. We therefore have to take a newline whenever a line is full (after 80 characters, say), but before doing this we must go back to the last space and transfer the whole of the word which was about to be split onto the next line. Therefore, we shall output into a []CHAR instead of directly to the book. COMMENT FILE file; [1:80] CHAR buffer; FOR i TO UPB buffer DO buffer[i]:= " " OD; associate(file, buffer); COMMENT Whenever the buffer becomes full, its contents (except for the split word) must be printed in the real book. COMMENT PROC empty buffer = (REF FILE f) BOOL: (INT j:= UPB buffer; IF char number(f) > j THEN WHILE buffer[j] /= " " DO j -:= 1 OD FI; print((buffer[ :j], newline)); reset(f); put(f, buffer[j+1: ]); FOR i FROM UPB buffer -j+1 TO UPB buffer DO buffer[i]:= " " OD; TRUE); on line end(file, empty buffer); COMMENT The []CHAR associated with 'file' is like a book containing one page containing one line. As soon as we call 'newline(file)', therefore, we shall find that the page has overflowed (the current position will actually be at '(1,2,1)'). COMMENT on page end(file, empty buffer); STRUCT (INT day, [1:3] CHAR month, INT year) date; COMMENT We shall frequently have occasion to print dates. Here is a FORMAT to do it. COMMENT FORMAT datef = $ g(0)x, 3ax, 2d $; PROC generate = (REF PERSON infant, father, mother, STRING given name, BOOL male) VOID: IF male OF father AND NOT male OF mother AND NOT dead OF mother THEN OP PLUSAB = (REF FLEX[]REF PERSON names, REF PERSON pers) VOID: names:= (INT upb = UPB names; [1:upb + 1]REF PERSON new names; new names[1:upb] :=names; new names[upb + 1]:= pers; new names); infant:= (surname OF mother, given name, father, mother, NIL, (), # not yet! # alive, male); children OF father PLUSAB infant; children OF mother PLUSAB infant; IF wife OF father :=: mother COMMENT That was an identity relation. If you have not yet read 5.7.4, please accept our assurance that ':=:' is a sort of operator which yields TRUE if the two names which are its operands in fact are the same name. In this case, the operands were of mode REF PERSON, and IF the PERSON's REF'ed to turn out to be the same PERSON COMMENT THEN putf(file, ( $2l"Birth." l 4x g$, surname OF infant, $". On " f(datef)$, date, $" to "g$, given OF mother, $", wife of "g$, given OF father, $", a "c("darling", "bouncing", "beautiful", "tiny")$, randint(4), $x b("son", "daughter") " - "$, male, $g"."$, given name)) COMMENT ELSE no comment COMMENT FI COMMENT The above call of 'putf' is intended to produce messages such as: Birth. Fitzwilliam. On 3 MAR 28 to Eleanor, wife of Ebenezer, a beautiful son - Japhet. COMMENT ELSE stop # the birth was quite impossible # FI; # end of generate # COMMENT The following procedure is intended to print the name of some PERSON, together with details of his parents. However, if there is some doubt about the marital state of the parents, then we shall draw a discreet veil over the matter by using a different FORMAT. COMMENT PROC details = (REF PERSON pers) VOID: IF mother OF pers :=: REF PERSON (wife OF father OF pers) THEN BOOL sex = male OF pers; putf(file, ($ g ", " $, given OF pers, $ c("only", "youngest", "younger", "eldest", "elder", "") x $, (INT j:= 0, k; REF FLEX [] REF PERSON children = children OF father OF pers; INT upb = UPB children; FOR i TO upb # each brother/sister of pers # DO REF PERSON child = children[i]; (male OF child = sex | j+:= 1); (given OF child = given OF pers | k:= j) OD; (j=1 | 1 # only # |: k=j | 2+ ABS (j=2) # youngest or younger # |: k=1 | 4+ ABS (j=2) # eldest or elder # | 6)), $ b("son", "daughter") " of " $, sex, $ g " and ", g x, g $, given OF father OF pers, names(mother OF pers) )) ELSE putf(file, ($ g x, g $, names(pers))) FI; # end of details # PROC marry = ( REF PERSON bride, groom) VOID: IF male OF groom AND NOT dead OF groom AND NOT male OF bride AND NOT dead OF bride AND (wife OF groom :=: nobody | TRUE | dead OF wife OF groom) AND (wife OF bride # sic # :=: nobody | TRUE | dead OF wife OF bride) THEN wife OF groom:= bride; wife OF bride:= groom; COMMENT We are now going to produce a message such as: Marriage. Fitzwilliam/Jones. On 1 APR 24, Eleanor, only daughter of Emrys and Myfanwy Jones to Ebenezer, elder son of Aloysius and Anastasia Fitzwilliam. COMMENT putf(file, ($ 2l "Marriage." l 4x g "/", g". On " $, surname OF groom, surname OF bride, $ f(datef) ", " $, date)); details(bride); put(file, " to "); details(groom); put(file, "."); surname OF bride:= surname OF groom ELSE stop # the marriage is impossible, or illegal, or both # FI; # end of marry # PROC kill = (REF PERSON bloke) VOID: IF NOT dead OF bloke THEN dead OF bloke:= TRUE; BOOL sex = male OF bloke; BOOL wa # wife alive # = (wife OF bloke :=: nobody | FALSE | NOT dead OF wife OF bloke); STRING # name of # wife = (wa | given OF wife OF bloke | "" ); COMMENT The following call of 'putf' is intended to produce messages such as: Death. On 21 DEC 68, Ebenezer, elder son of Aloysius and Anastasia Fitzwilliam, mourned by his devoted wife Eleanor COMMENT putf(file, ( $ 2l "Death." l4x "On " f(datef) ", " $, date)); details(bloke); IF wa THEN putf(file, ( $", mourned by " b("his", "her") x, c("everloving", "devoted", "thankful") x, b("wife", "husband"), x g $, sex, randint(3), sex, wife)) FI; COMMENT If 'bloke' has surviving descendants, the dirge continues in the following vein: and his children Shem, Ham and Japhet and his grandchildren Ananias, Azarias and Misael and his great-grandchild Tom. COMMENT BOOL mp # mourners printed # := wa; COMMENT The following PROC calls itself recursively for each generation. COMMENT PROC print children of = ([]REF PERSON parents, INT generation) VOID: BEGIN INT i:=0, j:=0; [1: (INT i := 0; FOR j TO UPB parents DO i +:= UPB children OF parents[j] OD; i) ] REF PERSON children, living children; FOR k TO UPB parents DO FOR l TO UPB children OF parents[k] DO REF PERSON child = (children OF parents[k]) [l]; children[i +:= 1] := (NOT dead OF child |living children[j +:= 1] := child |child) OD OD; IF j /= 0 THEN # there are living children to be printed # putf(file, ( $ f(mp | $ " and" $ |: wa | $ "," $ | $ "mourned by" $), x b("his", "her") x, n(generation-1) "great-" f(generation /= 0 | $ "grand" $ | $ $), "child" f(j /= 1 | $ "ren" $ | $ $) x, n(j) (g, f((j-:=1) + 1 | $ $, $ " and " $ | $ ", " $))$, sex, ( [1:j] STRING names; FOR i TO j DO names[i]:= given OF living children[i] OD; names) )); mp:= TRUE FI; IF UPB children /= 0 THEN print children of(children, generation + 1) FI END # of print children of #; print children of(bloke, 0); put(file, ".") ELSE stop # the bloke was dead already # FI # end of kill #; COMMENT Now we are ready to start our tale. Since we do not wish to go right back to Adam, we shall start by declaring the story so far: COMMENT PERSON aloysius := ("Fitzwilliam", "Aloysius", SKIP, SKIP, SKIP, (), dead, male); PERSON anastasia := ("Fitzwilliam", "Anastasia", SKIP, SKIP, aloysius, (), dead, female); PERSON ebenezer := ("Fitzwilliam", "Ebenezer", aloysius, anastasia, NIL, (), alive, male); PERSON alaric := ("Fitzwilliam", "Alaric", aloysius, anastasia, NIL, (), alive, male); COMMENT We were unable to include 'anastasia' as 'aloysius'' wife when initialising him, because her declaration had not been elaborated at that time (cf. 3.2.E7). We can rectify this, and the similar case of their children, now COMMENT wife OF aloysius := anastasia; children OF aloysius := children OF anastasia := (ebenezer, alaric); COMMENT We shall declare the next family differently, so avoiding this problem: COMMENT PERSON emrys, myfanwy, frederick, eleanor; emrys:= ("Jones", "Emrys", SKIP, SKIP, myfanwy, (frederick, eleanor), dead, male); myfanwy:= ("Jones", "Myfanwy", SKIP, SKIP, emrys, children OF emrys, alive, female); frederick:= ("Jones", "Frederick", emrys, myfanwy, NIL, (), alive, male); eleanor:= ("Jones", "Eleanor", emrys, myfanwy, NIL, (), alive, female); PERSON shem, ham, japhet, ananias, azarias, misael, tom; COMMENT These are the unborn generations, and are therefore undefined. COMMENT date := (1, "APR", 24); marry(eleanor, ebenezer); date := (1, "JAN", 25); generate(shem, ebenezer, eleanor, "Shem", male); COMMENT We don't waste much time in this program. COMMENT date := (31, "MAR", 26); generate(ham, ebenezer, eleanor, "Ham", male); date := (3, "MAR", 28); generate(japhet, ebenezer, eleanor, "Japhet", male); COMMENT This will produce the example given in the PROC 'generate'. COMMENT date := (14, "JUL", 48); COMMENT Now we need to declare some eligible young ladies. COMMENT PERSON a, b, josie, rosie; josie := ("Smith", "Josephine", a, b, NIL, (), alive, female); rosie := ("Smith", "Rose", a, b, NIL, (), alive, female); marry(josie, shem); date := (23, "JAN", 49); generate(ananias, shem, josie, "Ananias", male); COMMENT Well, perhaps it was premature. COMMENT date := (14, "DEC", 50); generate(azarias, shem, josie, "Azarias", male); date := (29, "FEB", 52); kill(josie); COMMENT Alas! But ... COMMENT date := (28, "DEC", 52); marry(rosie, shem); COMMENT There are some interesting ecclesiastical problems in that one. COMMENT date := (14, "JAN", 54); generate(misael, shem, rosie, "Misael", male); COMMENT Here is a not-so-eligible young lady: COMMENT PERSON x := (CHAR(SKIP), CHAR(SKIP), SKIP, SKIP, NIL, REF PERSON(SKIP), alive, female); date := (20, "DEC", 68); generate(tom, azarias, x, "Tom", male); COMMENT And so the permissive society has arrived. Nothing will be printed. COMMENT date := (21, "DEC", 68); kill(ebenezer); COMMENT Poor chap! this will produce the example given in the PROC 'kill'. COMMENT newline(file); newline(file) # to ensure that the final contents of the buffer get printed # END algol68g-2.8/test-set/a68g.mc.043.decl02.a680000644000175000001440000000616412224301224014532 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #decl02# BEGIN # Shielding, yin and yang # MODE Z = Z, # wrong # A = REF A, # wrong # B = PROC B, # wrong # C = STRUCT(C c), # wrong # D = PROC(D)INT, # right # E = PROC(INT)E, # right # F = [3] F, # wrong # G = UNION(INT, G), # wrong # ## AA = REF REF AA, # wrong # AB = REF PROC AB, # wrong # AC = REF STRUCT(AC ac), # right # AD = REF PROC(AD)INT, # right # AE = REF PROC(INT)AE, # right # AF = REF [ ] AF, # wrong # AG = REF UNION(INT, AG), # wrong # ## BA = PROC REF BA, # wrong # BB = PROC PROC BB, # wrong # BC = PROC STRUCT(BC bc), # right # BD = PROC PROC(BD)INT, # right # BE = PROC PROC(INT)BE, # right # BF = PROC [ ] BF, # wrong # BG = PROC UNION(INT, BG), # wrong # ## CA = STRUCT(REF CA ca), # right # CB = STRUCT(PROC CB cb), # right # CC = STRUCT(STRUCT(CC cc)cc), # wrong # CD = STRUCT(PROC(CD)INT cd), # right # CE = STRUCT(PROC(INT)CE ce), # right # CF = STRUCT([3] CF cf), # wrong # CG = STRUCT(UNION(INT, CG)cg), # wrong # ## DA = PROC(REF DA)INT, # right # DB = PROC(PROC DB)INT, # right # DC = PROC(STRUCT(DC dc))INT, # right # DD = PROC(PROC(DD)INT)INT, # right # DE = PROC(PROC(INT)DE)INT, # right # DF = PROC([ ] DF)INT, # right # DG = PROC(UNION(INT, DG))INT, # right # ## EA = PROC(INT)REF EA, # right # EB = PROC(INT)PROC EB, # right # EC = PROC(INT)STRUCT(EC ec), # right # ED = PROC(INT)PROC(ED)INT, # right # EE = PROC(INT)PROC(INT)EE, # right # EF = PROC(INT)[ ] EF, # right # EG = PROC(INT)UNION(INT, EG), # right # ## FA = [3] REF FA, # wrong # FB = [3] PROC FB, # wrong # FC = [3] STRUCT(FC fc), # wrong # FD = [3] PROC(FD)INT, # right # FE = [3] PROC(INT)FE, # right # FF = [3] [2] FF, # wrong # FG = [3] UNION(INT, FG), # wrong # ## GA = UNION(INT, REF GA), # wrong # GB = UNION(INT, PROC GB), # wrong # GC = UNION(INT, STRUCT(GC gc)), # wrong # GD = UNION(INT, PROC(GD)INT), # right # GE = UNION(INT, PROC(INT)GE), # right # GF = UNION(INT, [ ] GF), # wrong # GG = UNION(INT, UNION(INT, GG)); # wrong # SKIP END algol68g-2.8/test-set/a68g.mc.029.coer01.a680000644000175000001440000000111212224301222014540 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer01# BEGIN # Coercions # print ((REAL x := 0; REF [] REAL (x) := 1; x)); # 1.0 # print ((INT n := 0; n +:= 1 := 5)) # 5 # ENDalgol68g-2.8/test-set/a68g.mc.073.jump03.a680000644000175000001440000000075012224301231014573 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #jump03# BEGIN # Jump # INT i := 1, j := 2; i := j := (GOTO l; 3); l: print ((i, j)) # 1 2 # ENDalgol68g-2.8/test-set/a68g.mc.109.numr13.a680000644000175000001440000003414512224301253014613 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr13# BEGIN #Test inverse trig functions# PROC warn = (STRING s) VOID: BEGIN print ((newline, s)) END; REAL zero = 0; REAL sums1 := zero, sumsqs1 := zero, maxs1 := zero, ats1, INT cs1 := 0; REAL sums2 := zero, sumsqs2 := zero, maxs2 := zero, ats2, INT cs2 := 0; REAL sums3 := zero, sumsqs3 := zero, maxs3 := zero, ats3, INT cs3 := 0; REAL sumc1 := zero, sumsqc1 := zero, maxc1 := zero, atc1, INT cc1 := 0; REAL sumc2 := zero, sumsqc2 := zero, maxc2 := zero, atc2, INT cc2 := 0; REAL sumc3 := zero, sumsqc3 := zero, maxc3 := zero, atc3, INT cc3 := 0; REAL sumt1 := zero, sumsqt1 := zero, maxt1 := zero, att1, INT ct1 := 0; REAL sumt2 := zero, sumsqt2 := zero, maxt2 := zero, att2, INT ct2 := 0; REAL sumt3 := zero, sumsqt3 := zero, maxt3 := zero, att3, INT ct3 := 0; REAL sumsc := zero, sumsqsc := zero, maxsc := zero, atsc, INT csc := 0; REAL sumcs := zero, sumsqcs := zero, maxcs := zero, atcs, INT ccs := 0; REAL piby2 = pi / 2; PROC asin = (REAL x, PROC VOID l) REAL: IF # x positive, 0<=arcsin(x) piby2 THEN e ("arcsin exceeds pi/2"); #allow rounding up# SKIP ELSE IF # sin(arcsin(x))=x ? # REAL z = sin (y); REAL d1 = ABS z + ABS x; d1 = zero THEN cs1 +:= 1 ELIF REAL d2 = ABS ((ABS z - ABS x) / smallreal); REAL d = (d2 + d2) / d1; sums1 +:= d; sumsqs1 +:= d * d; cs1 +:= 1; d > maxs1 THEN maxs1 := d; ats1 := x FI; IF # arcsin(-x)=-arcsin(x) ? # REAL z = arcsin (-x); SIGN z /= -SIGN y THEN print ((newline, newline, "arcsin(", -x, " ) =", z)); warn ("arcsin yields result of wrong sign"); l ELIF REAL d1 = ABS y + ABS z; d1 = zero THEN cs2 +:= 1 ELIF REAL d2 = ABS ((ABS y - ABS z) / smallreal); REAL d = (d2 + d2) / d1; sums2 +:= d; sumsqs2 +:= d * d; cs2 +:= 1; d > maxs2 THEN maxs2 := d; ats2 := x FI; y FI; PROC acos = (REAL x, PROC VOID l) REAL: IF # x positive, 0<=arccos(x) piby2 THEN e ("arccos exceeds pi/2"); #allow rounding up# SKIP ELSE IF x >= smallreal #otherwise arccos(x)=pi/2 and cos(arccos(x))=0# THEN IF # cos(arccos(x))=x ? # REAL z = cos (y); REAL d1 = ABS z + ABS x; d1 = zero THEN cc1 +:= 1 ELSE REAL d2 = ABS ((ABS z - ABS x) / smallreal); REAL d = (d2 + d2) / d1; sumc1 +:= d; sumsqc1 +:= d * d; cc1 +:= 1; (d > maxc1 | maxc1 := d; atc1 := x) FI FI; IF # arccos(-x)=pi-arccos(x) ? # REAL z = arccos (-x); z < piby2 THEN print ((newline, newline, "arccos(", -x, " ) =", z)); warn ("result should exceed pi/2"); l ELIF z > pi THEN print ((newline, newline, "arccos(", -x, " ) =", z)); warn ("arccos should not exceed pi"); l ELIF REAL zz = pi - y; REAL d1 = ABS zz + ABS z; d1 = zero THEN cc2 +:= 1 ELIF REAL d2 = ABS ((ABS zz - ABS z) / smallreal); REAL d = (d2 + d2) / d1; sumc2 +:= d; sumsqc2 +:= d * d; cc2 +:= 1; d > maxc2 THEN maxc2 := d; atc2 := x FI; y FI; PROC atan = (REAL x, PROC VOID l) REAL: IF # x positive, 0<=arctan(x) piby2 THEN e ("arctan exceeds pi/2"); #allow rounding up# SKIP ELIF # tan(arctan(x))=x ? # x < maxreal / 2 THEN IF REAL z = tan (y); REAL d1 = ABS z + ABS x; d1 = zero THEN ct1 +:= 1 ELIF REAL d2 = ABS ((ABS z - ABS x) / smallreal); REAL d = (d2 + d2) / d1; sumt1 +:= d; sumsqt1 +:= d * d; ct1 +:= 1; d > maxt1 THEN maxt1 := d; att1 := x FI; IF # arctan(-x)=-arctan(x) ? # REAL z = arctan (-x); SIGN z /= -SIGN y THEN print ((newline, newline, "arctan(", -x, " ) =", z)); warn ("arctan yields result of wrong sign"); l ELIF REAL d1 = ABS y + ABS z; d1 = zero THEN ct2 +:= 1 ELIF REAL d2 = ABS ((ABS y - ABS z) / smallreal); REAL d = (d2 + d2) / d1; sumt2 +:= d; sumsqt2 +:= d * d; ct2 +:= 1; d > maxt2 THEN maxt2 := d; att2 := x FI; y FI; PROC test = (REAL a, b, h) VOID: BEGIN REAL arcsin x = asin (a / h, VOID: GOTO l), arcsin y = asin (b / h, VOID: GOTO l), arccos x = acos (a / h, VOID: GOTO l), arccos y = acos (b / h, VOID: GOTO l), arctan x = atan (a / b, VOID: GOTO l), arctan y = atan (b / a, VOID: GOTO l); IF # arcsin(x)+arcsin(y)=pi/2 # REAL z = arcsin x + arcsin y; REAL d = ABS (z - piby2) / (piby2 * smallreal); sums3 +:= d; sumsqs3 +:= d * d; cs3 +:= 1; d > maxs3 THEN maxs3 := d; ats3 := a / h FI; IF # arccos(x)+arccos(y)=pi/2 # REAL z = arccos x + arccos y; REAL d = ABS (z - piby2) / (piby2 * smallreal); sumc3 +:= d; sumsqc3 +:= d * d; cc3 +:= 1; d > maxc3 THEN maxc3 := d; atc3 := b / h FI; IF # arctan(x)+arctan(y)=pi/2 # REAL z = arctan x + arctan y; REAL d = ABS (z - piby2) / (piby2 * smallreal); sumt3 +:= d; sumsqt3 +:= d * d; ct3 +:= 1; d > maxt3 THEN maxt3 := d; att3 := a / b FI; IF #arcsin(x)=arccos(y)# REAL z = arcsin x + arccos y; z = zero THEN csc +:= 1 ELIF REAL zz = ABS (arcsin x - arccos y) / z; REAL d = (zz + zz) / smallreal; sumsc +:= d; sumsqsc +:= d * d; csc +:= 1; d > maxsc THEN maxsc := d; atsc := a / h FI; IF #arccos(x)=arcsin(y)# REAL z = arccos x + arcsin y; z = zero THEN ccs +:= 1 ELIF REAL zz = ABS (arccos x - arcsin y) / z; REAL d = (zz + zz) / smallreal; sumcs +:= d; sumsqcs +:= d * d; ccs +:= 1; d > maxcs THEN maxcs := d; atcs := b / h FI; l: SKIP END; PROC gcd = (INT a, b) INT: IF INT c = a MOD b; c = 0 THEN b ELSE gcd (b, c) FI; INT c := 200; #number of triangles tested# FOR i FROM 2 TO maxint WHILE c > 0 DO FOR j FROM i - 1 BY -2 TO 1 WHILE #generate Pythagorean triangle# IF gcd (i, j) = 1 AND (ODD i /= ODD j) THEN REAL i2 = i * i, j2 = j * j, ij = i * j; REAL short = i2 - j2, long = ij + ij, hypot = i2 + j2; test (short, long, hypot); c -:= 1 ELSE c FI > 0 DO SKIP OD OD; PROC p = (STRING s, REAL max, at, sum, sumsq, INT c) VOID: (print ((newline, newline, s, newline)); print (("Maximum relative error = smallreal*", fixed (max, -(realwidth % 2 + 2), realwidth % 2), newline)); (max /= zero | print (("Occurred at x = ", at, newline))); print (("Average relative error = smallreal*", fixed (sum / c, -(realwidth % 2 + 2), realwidth % 2), newline)); print (("R.M.S. relative error = smallreal*", fixed (sumsq / c, -(realwidth % 2 + 2), realwidth % 2), newline)); print (("Number of tests = ", whole (c, -5)))); p ("Checks on sin(arcsin(x))=x :", maxs1, ats1, sums1, sumsqs1, cs1); p ("Checks on arcsin(-x)=-arcsin(x) :", maxs2, ats2, sums2, sumsqs2, cs2); p ("Checks on arcsin(x)+arcsin(y)=pi/2 :", maxs3, ats3, sums3, sumsqs3, cs3); p ("Checks on cos(arccos(x))=x :", maxc1, atc1, sumc1, sumsqc1, cc1); p ("Checks on arccos(-x)=pi-arccos(x) :", maxc2, atc2, sumc2, sumsqc2, cc2); p ("Checks on arccos(x)+arccos(y)=pi/2 :", maxc3, atc3, sumc3, sumsqc3, cc3); p ("Checks on tan(arctan(x))=x :", maxt1, att1, sumt1, sumsqt1, ct1); p ("Checks on arctan(-x)=-arctan(x) :", maxt2, att2, sumt2, sumsqt2, ct2); p ("Checks on arctan(x)+arctan(y)=pi/2 :", maxt3, att3, sumt3, sumsqt3, ct3); p ("Checks on arcsin(x)=arccos(y) :", maxsc, atsc, sumsc, sumsqsc, csc); p ("Checks on arccos(x)=arcsin(y) :", maxcs, atcs, sumcs, sumsqcs, ccs); #Special values# IF REAL a = asin (zero, VOID: GOTO l1); a /= zero THEN print ((newline, newline, "arcsin(0) =", a)); warn ("arcsin(0) should be 0") FI; l1: IF REAL a = asin (1, VOID: GOTO l2); a /= piby2 THEN print ((newline, newline, "arcsin(1) differs from pi/2 by smallreal*", fixed (ABS (piby2 - a) / smallreal, -(realwidth % 2 + 2), realwidth % 2))) FI; l2: IF REAL a = acos (1, VOID: GOTO l3); a /= zero THEN print ((newline, newline, "arccos(1) =", a)); warn ("arccos(1) should be 0") FI; l3: IF REAL a = acos (zero, VOID: GOTO l4); a /= piby2 THEN print ((newline, newline, "arccos(0) differs from pi/2 by smallreal*", fixed (ABS (piby2 - a) / smallreal, -(realwidth % 2 + 2), realwidth % 2))) FI; l4: IF REAL a = arccos (-1); a /= pi THEN print ((newline, newline, "arccos(-1) differs from pi by smallreal*", fixed (ABS (pi - a) / smallreal, -(realwidth % 2 + 2), realwidth % 2))) FI; l5: IF REAL a = atan (zero, VOID: GOTO l6); a /= zero THEN print ((newline, newline, "arctan(0) =", a)); warn ("arctan(0) should be 0") FI; l6: print ((newline, newline, "smallreal =", smallreal, newline)) ENDalgol68g-2.8/test-set/a68g.mc.099.numr03.a680000644000175000001440000000542512224301247014624 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr03# BEGIN # Test ALGOL 68 version of 'zeroin' (MCA 2310 in 'ALGOL 60 Procedures in Numerical Algebra' by Th.J. Dekker) # PROC zero in = (REF REAL x, y, PROC (REAL) REAL f, tol) BOOL: BEGIN REAL a := x, b := y; REAL fa := f (a), fb := f (b); REAL c := a, fc := fa; WHILE (ABS fc < ABS fb | # interchange: # (a := b, fa := fb); (b := c, fb := fc); (c := a, fc := fa)); REAL tolb := tol (b), m := (c + b) * 0.5; ABS (m - b) > tolb DO REAL p := (b - a) * fb, q := fa - fb; (p < 0 | (p := -p, q := -q)); (a := b, fa := fb); fb := f (b := IF p <= ABS q * tolb THEN (c > b | b + tolb | b - tolb) ELIF p < (m - b) * q THEN p / q + b ELSE m FI); IF ABS (SIGN fb + SIGN fc) = 2 THEN (c := a, fc := fa) FI OD # while, do # ; (x := b, y := c); ABS (SIGN fb + SIGN fc) < 2 END # zero in # ; ## REAL eps = 3 * small real; PROC test = (REAL x0, y0, PROC (REAL) REAL f, STRING s, UNION (STRING, REAL) sol) VOID: print ((newline, "Expression: ", s, newline, "Zero to be found between ", x0, " and ", y0, newline, IF REAL x, y; zero in (x := x0, y := y0, f, (REAL p) REAL: eps + eps * ABS p) THEN STRUCT (STRING s1, REAL r1, STRING s2, REAL r2) ("Value found at ", x, " is ", f (x)) ELSE " no solution found" FI, newline, "Result on EL-X8: ", sol, newline)) #test # ; test (-1, 0, (REAL x) REAL: exp (x) - x * x, "exp(x) - x * x", -0.7034674224979); test (1, 10, (REAL x) REAL: ln (x) - x + 2, "ln(x) - x + 2", 3.146193220622); test (0, 5, (REAL x) REAL: x * x - 4, "x * x - 4", 2.0); test (1, 1.5, (REAL x) REAL: sin (3 * x), "sin(3 * x)", 1.047197551197); test (-1, 1, (REAL x) REAL: x * x + 1, "x * x + 1", "no solution found") ENDalgol68g-2.8/test-set/a68g.mc.086.misc05.a680000644000175000001440000000757512224301233014577 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #misc05# # Runs and yields 1.0, 1.0, 1.0, -2.0 # BEGIN MODE FORM = UNION (REF CONST, REF VAR, REF TRIPLE, REF CALL), CONST = STRUCT (REAL value), VAR = STRUCT (STRING name, REAL value), TRIPLE = STRUCT (FORM leftoperand, INT operator, FORM rightoperand), FUNCTION = STRUCT (REF VAR boundvar, FORM body), CALL = STRUCT (REF FUNCTION functionname, FORM parameter); INT plus = 1, minus = 2, times = 3, by = 4, to = 5; HEAP CONST zero, one; value OF zero := 0; value OF one := 1; OP = = (FORM a, REF CONST b) BOOL: CASE a IN (REF CONST ec): ec :=: b OUT FALSE ESAC; OP + = (FORM a, b) FORM: (a = zero | b |: b = zero | a | HEAP TRIPLE := (a, plus, b)); OP - = (FORM a, b) FORM: (b = zero | a | HEAP TRIPLE := (a, minus, b)); OP * = (FORM a, b) FORM: (a = zero OR b = zero | zero |: a = one | b |: b = one | a | HEAP TRIPLE := (a, times, b)); OP / = (FORM a, b) FORM: (a = zero AND NOT (b = zero) | zero |: b = one | a | HEAP TRIPLE := (a, by, b)); OP ** = (FORM a, REF CONST b) FORM: (a = one OR (b :=: zero) | one |: b :=: one | a | HEAP TRIPLE := (a, to, b)); PROC derivativeof = (FORM e, REF VAR x) FORM: CASE e IN (REF CONST): zero, (REF VAR ev): (ev :=: x | one | zero), (REF TRIPLE et): CASE FORM u = leftoperand OF et, v = rightoperand OF et; FORM udash = derivativeof (u, x), vdash = derivativeof (v, x); operator OF et IN udash + vdash, udash - vdash, u * vdash + udash * v, (udash - et * vdash) / v, (v | (REF CONST ec): v * u ** (HEAP CONST c; value OF c := value OF ec - 1; c) * udash) ESAC, (REF CALL ef): BEGIN REF FUNCTION f = functionname OF ef, FORM g = parameter OF ef; REF VAR y = boundvar OF f; HEAP FUNCTION fdash := (y, derivativeof (body OF f, y)); (HEAP CALL := (fdash, g)) * derivativeof (g, x) END ESAC; PROC valueof = (FORM e) REAL: CASE e IN (REF CONST ec): value OF ec, (REF VAR ev): value OF ev, (REF TRIPLE et): CASE REAL u = valueof (leftoperand OF et), v = valueof (rightoperand OF et); operator OF et IN u + v, u - v, u * v, u / v, exp (v * ln (u)) ESAC, (REF CALL ef): BEGIN REF FUNCTION f = functionname OF ef; value OF boundvar OF f := valueof (parameter OF ef); valueof (body OF f) END ESAC; HEAP FORM f, g; HEAP VAR a := ("a", SKIP), b := ("b", SKIP), x := ("x", SKIP); value OF a := 1; value OF b := 1; value OF x := 1; f := a + x / (b + x); g := (f + one) / (f - one); print ((value OF a, value OF b, value OF x, valueof (derivativeof (g, x)))) ENDalgol68g-2.8/test-set/a68g.mc.152.smio02.a680000644000175000001440000000333612224301262014573 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio02# BEGIN print (("Results must be:", newline, 3, newline, 3.0, newline, 3, 3.0, newline, 2r11, TRUE, newline, 2, 0, newline, 1, newline, TRUE, newline, 6.0, newline, "Empty", newline, "Correct jump out of print parameter", newline, newline, "Results are:", newline)); print (IF TRUE THEN 3 ELSE 3.0 FI); print (newline); print (IF FALSE THEN 3 ELSE 3.0 FI); print (newline); print (IF TRUE THEN (3, 3.0) ELSE (2r11, TRUE, newline) FI); print (newline); print (IF FALSE THEN (3, 3.0) ELSE (2r11, TRUE, newline) FI); print ((INT i := 1; (i + 1, i - 1, newline) # coll. clause # # serial clause # )); print (UNION ([] INT, BOOL) ([] INT (1))); print (newline); print (UNION ([] INT, BOOL) (BOOL (TRUE))); print (newline); # 'print' works on a union of everything, so also on BOOL or []INT # print ((PROC PROC REF REAL: PROC REF REAL: REF REAL: HEAP REAL) := 6); print (newline); print (()); print ("Empty"); print (newline); print ((3, sqrt (GOTO l), 5)); print ("Error"); l: print ("Correct jump out of print parameter") ENDalgol68g-2.8/test-set/a68g.mc.108.numr12.a680000644000175000001440000001271112224301252014603 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr12# BEGIN #Test trig functions 2# #N.B. This test should not be considered as certification of trig functions, but only as an indication that trig functions have the right properties# #Spot checks# REAL zero = 0, half = 0.5, one = 1, two = 2, three = 3, four = 4, five = 5, six = 6, seven = 7, eight = 8, twelve = 12.0, sixteen = 16.0, thirtytwo = 32.0; print ((newline, "Spot checks:", newline)); FOR i TO 12 DO STRUCT (STRING s1, s2, REAL s, STRING s3, REAL c) z = CASE i IN ("sin 0 = zero", "sin(0) = ", zero, "cos(pi/2) = ", pi / two), ("sin pi/24 = 0.13052619222005159154840622789548901 (Hart)", "sin(pi/24) = ", pi / 24, "cos(11*pi/24) = ", 11.0 * pi / 24.0), ("sin pi/16 = 0.19509032201612826784828486847702224 (Hart)", "sin(pi/16) = ", pi / sixteen, "cos(7*pi/16) = ", seven * pi / sixteen), ("sin 1/4 = 0.24740395925452292959684870484938920 (Hart)", "sin(1/4) = ", 0.25, "cos((2*pi-1)/4)= ", (pi + pi - 1) / four), ("sin pi/12 = 0.25881904510252076234889883762404832 (Hart)", "sin(pi/12) = ", pi / twelve, "cos(5*pi/12) = ", five * pi / twelve), ("sin 1/2 = 0.47942553860420300027328793521557139 (Hart)", "sin(1/2) = ", half, "cos((pi-1)/2) = ", (pi - one) / two), ("sin pi/6 = 0.5", "sin(pi/6) = ", pi / six, "cos(pi/3) = ", pi / three), ("sin pi/4 = 0.70710678118654752440084436210484903 (Hart)", "sin(pi/4) = ", pi / four, "cos(pi/4) = ", pi / four), ("sin 1 = 0.84147098480789650665250232163029900 (Hart)", "sin(1) = ", one, "cos(pi/2-1) = ", (pi - two) / two), ("sin pi/3 = 0.86602540378443864676372317075293618 (Hart)", "sin(pi/3) = ", pi / three, "cos(pi/6) = ", pi / six), ("sin 3*pi/8 = 0.92387953251128675612818319839678828 (Hart)", "sin(3*pi/8) = ", three * pi / eight, "cos(pi/8) = ", pi / eight), ("sin 5*pi/12 = 0.96592582628906828674974319972889736 (Hart)", "sin(5*pi/12) = ", five * pi / twelve, "cos(pi/12) = ", pi / twelve), SKIP ESAC; print ((newline, s1 OF z, newline, s2 OF z)); print (fixed (sin (s OF z), -(realwidth + 1), realwidth - 1)); print ((newline, s3 OF z)); print (fixed (cos (c OF z), -(realwidth + 1), realwidth - 1)); print (newline) OD; FOR i TO 23 DO STRUCT (STRING s1, s2, REAL t) z = CASE i IN ("tan 0 = 0", "tan(0) = ", zero), ("tan pi/32 = 0.09849140335716425307719752129132743 (Hart)", "tan(pi/32) = ", pi / thirtytwo), ("tan pi/16 = 0.19891236737965800691159762264467622 (Hart)", "tan(pi/16) = ", pi / sixteen), ("tan 1/4 = 0.25534192122103626650448223649047368 (Hart)", "tan(1/4) = ", 0.25), ("tan pi/12 = 0.26794919243112270647255365849412763 (Hart)", "tan(pi/12) = ", pi / twelve), ("tan 3*pi/32 = 0.30334668360734239167588394694129987 (Hart)", "tan(3*pi/32) = ", three * pi / thirtytwo), ("tan pi/8 = 0.41421356237309504880168872420969807 (Hart)", "tan(pi/8) = ", pi / eight), ("tan 5*pi/32 = 0.53451113595079164108968596129536290 (Hart)", "tan(5*pi/32) = ", five * pi / thirtytwo), ("tan 1/2 = 0.54630248984379051325517946578028538 (Hart)", "tan(1/2) = ", half), ("tan pi/6 = 0.57735026918962576450914878050195745 (Hart)", "tan(pi/6) = ", pi / six), ("tan 3*pi/16 = 0.66817863791929891999775768652308076 (Hart)", "tan(3*pi/16) = ", three * pi / sixteen), ("tan 7*pi/32 = 0.82067879082866033097228198533101159 (Hart)", "tan(7*pi/32) = ", seven * pi / thirtytwo), ("tan pi/4 = 1.0", "tan(pi/4) = ", pi / four), ("tan 9*pi/32 = 1.21850362558797634479547723062036405 (Hart)", "tan(9*pi/32) = ", 9.0 * pi / thirtytwo), ("tan 5*pi/16 = 1.49660576266548901760113513494247691 (Hart)", "tan(5*pi/16) = ", five * pi / sixteen), ("tan 1 = 1.55740772465490223050697480745836017 (Hart)", "tan(1) = ", one), ("tan pi/3 = 1.73205080756887729352744634150587236 (Hart)", "tan(pi/3) = ", pi / three), ("tan 11*pi/32 = 1.87086841178938948108520133434152443 (Hart)", "tan(11*pi/32) = ", 11.0 * pi / thirtytwo), ("tan 3*pi/8 = 2.41421356237309504880168872420969807 (Hart)", "tan(3*pi/8) = ", three * pi / eight), ("tan 13*pi/32 = 3.29655820893832042687815421682625370 (Hart)", "tan(13*pi/32) = ", 13 * pi / thirtytwo), ("tan 5*pi/12 = 3.73205080756887729352744634150587236 (Hart)", "tan(5*pi/12) = ", five * pi / twelve), ("tan 7*pi/16 = 5.02733949212584810451497507106407238 (Hart)", "tan(7*pi/16) = ", seven * pi / sixteen), ("tan 15*pi/32 = 10.15317038760886046210714766341947220 (Hart)", "tan(15*pi/32) = ", 15 * pi / thirtytwo), SKIP ESAC; print ((newline, s1 OF z, newline, s2 OF z)); print (fixed (tan (t OF z), -(realwidth + 1), realwidth - 1)); print (newline) OD; print ((newline, "smallreal = ")); print (fixed (smallreal, -2 * realwidth, 2 * (realwidth - 1))); print ((newline, " =", smallreal)); print (newline) ENDalgol68g-2.8/test-set/a68g.mc.084.misc03.a680000644000175000001440000000345112224301232014557 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #misc03# ( # ALGOL 68 program (test on readability of error messages) 10-7-'73, J. Admiraal # PROC inprod = ( [] REAL a, b) REAL: ( REAL s:= 0; FOR k FROM LWB a TO UPB a DO s +:= a[k] * b[k] OD; s ) # inprod # ; PROC vecvec = (INT low, up, shift, []REAL a, b) REAL: inprod(a[low:up], b[low+shift : up+shift]) # vecvec #; PROC matvec = (INT low, up, i, [,] REAL a, [] REAL b) REAL: inprod( a[i,low:up], b[low:up]) # matvec #; PROC tamvec = (INT low, up, i, [,] REAL a, [] REALb) REAL: inprod( a[low:up, i], b[low:up]) # tamvec #; PROC matmat = (INT low, up, i, j, [,] REAL a, b) REAL: inprod( a[i, low:up], b[low:up, j]) # matmat #; PROC tammat = (INT low, up, i, j, [,] REAL a, b) REAL: inprod( a[low:up, i], b[low:up, j]) # tammat #; PROC mattam = (INT low, up, i, j, [,] REAL a, b) REAL: inprod( a[i, low:up], b[j, low:up]) # mattam #; # # [1 : 10, 1 : 10] REAL ca, [1:10] REAL aa, BOOL bool:= TRUE; # Twelve bad calls # vecvec (1, 10, bool, aa, aa); vecvec (1, 10, ca, aa, aa, 1.0); matvec (1, 10, bool, ca, aa); tamvec (1, 10, aa, ca, aa); matmat (1, 10, 5, 5, aa, bool); tammat (1, 10, 5, 5, bool, ca); mattam (1, 10, 5, 5, ca, ca, 1.0); matmat (bool, 10, 5, 5, ca, ca); mattam (aa, 10, 5, 5, ca, ca); vecvec (1, 10, 0, aa); matvec (bool); matmat (1, 10, 5, 5, ca, ca, 1.0) ) algol68g-2.8/test-set/a68g.mc.047.decl06.a680000644000175000001440000002214412224301225014537 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #decl06# BEGIN # No errors # # 1. Actual declaration. # # 1.a. Without bounds. # # primitive # BEGIN INT x1, INT x2, x3, INT x4, x5, x6, REAL x7, x8, x9, x10, x11, x12, LONG INT x13, LONG REAL x14, BOOL x15, CHAR x16; SKIP END; # ref + primitive # BEGIN REF INT x1, REF REF REAL x2, REF REF REF REF LONG REAL x3, REF REF REF REF REF BOOL x4, REF REF REF REF REF REF CHAR x5, REF REF PROC VOID x6; SKIP END; # proc # BEGIN PROC VOID x1, PROC PROC REAL x2, PROC PROC PROC PROC LONG REAL x3, PROC PROC PROC PROC PROC BOOL x4, PROC PROC PROC PROC PROC PROC CHAR x5, PROC PROC PROC VOID x6; SKIP END; # ref + proc # BEGIN REF REF REF REF REF REF PROC VOID x1, PROC REF REAL x2, PROC REF PROC REF LONG REAL x3, PROC REF PROC REF PROC BOOL x4, REF PROC REF PROC REF PROC CHAR x5, PROC REF PROC VOID x6; SKIP END; # proc with one parameter which is primitive or ref + primitive # BEGIN PROC (INT) VOID x1, PROC (REF REF REF LONG INT) VOID x2, PROC (BOOL) VOID x3, PROC (REF CHAR) VOID x4, PROC (LONG REAL) VOID x5, PROC (REF REF REF BOOL) VOID x6, PROC (PROC VOID) VOID x7, PROC (REF REF PROC VOID) VOID x8; SKIP END; # ref + proc with one parameter which is ref * primitive # BEGIN REF PROC (INT) VOID x1, REF REF PROC (LONG REAL) VOID x2, x3, REF REF REF REF PROC (REF CHAR) VOID x4, REF PROC (PROC VOID) VOID x5, REF REF PROC (REF PROC VOID) VOID x6; SKIP END; # ref * proc with more than one parameter which are ref * primitive # BEGIN PROC (INT, LONG INT) VOID x1, PROC (REAL, REF LONG REAL, REF REF BOOL) VOID x2, PROC (REF REF REF CHAR, INT, LONG INT, REAL, REAL, INT) VOID x3, REF PROC (INT, INT, INT, REF CHAR) VOID x4, REF REF REF PROC (PROC VOID, REF REF PROC VOID, INT) VOID x5; SKIP END; # ref + row of * ref * primitive # BEGIN REF [] INT x1, REF [, ] REAL x2, REF REF [, , , ] LONG REAL x3, REF REF REF [, , , , , ] REF BOOL x4, REF [] REF REF REF LONG INT x5, REF REF [, , , , ] REF REF CHAR x6, REF [] PROC VOID x7, REF [, ] REF REF PROC VOID x8; SKIP END; # ref + row of * ref * proc # BEGIN REF [] PROC VOID x1, REF REF [, ] PROC (REF INT) VOID x2, REF REF REF [] PROC (INT, REF REF INT) VOID x3, REF [] REF PROC (REF LONG REAL, REF REF REF CHAR, REF LONG LONG REAL) VOID x4, REF REF [, , , ] REF REF REF PROC (REF INT, LONG LONG LONG INT) VOID x5; REF [] PROC (PROC VOID, REF PROC VOID) VOID x6; SKIP END; # ref * proc with row of parameters # BEGIN PROC ([] REAL) VOID x1, REF PROC (INT, [] LONG REAL) VOID x2, REF REF PROC ([, ] INT, [] REF REF BOOL) VOID x3, REF REF REF REF PROC (REF [] INT, REF REF [] REF REF LONG REAL) VOID x4, PROC (REF REF [, , , ] REF REF REF REAL) VOID x5, PROC ([] REF REAL, [, , , ] REF CHAR, REF [, ] BOOL) VOID x6, PROC ([] REF PROC VOID, REF [, , ] PROC VOID, REF REF [, ] REF REF PROC VOID) VOID x7; SKIP END; # nested rows # BEGIN REF [, , , ] REF [, ] INT x1, REF [] REF [] PROC VOID x2, REF [] REF REF [] REF BOOL x3, REF [, , , ] REF [, , , ] REF REF REF PROC VOID x4, REF REF [] REF [] INT x5, REF [] REF [] REF [] REF [, ] REF [] LONG REAL x6; SKIP END; # nested procs # BEGIN PROC (PROC (PROC (PROC VOID) VOID) VOID) VOID x1, PROC (INT, PROC (REF REF PROC VOID, REAL, REF PROC (REF LONG INT, PROC VOID) VOID, INT) VOID) VOID x2, PROC (INT, PROC VOID, PROC (INT, PROC VOID, REF REAL, REF PROC VOID) VOID) VOID x3, PROC (INT, PROC (INT, INT) VOID, PROC (INT) VOID, REAL) VOID x4; SKIP END; # mixed rows and procs # BEGIN REF [] PROC ([, ] INT, PROC ([] PROC VOID) VOID, [, ] PROC (PROC VOID, INT) VOID, REF [] PROC VOID) VOID x1; SKIP END; # 1.b. With bounds. # BEGIN [1 : 1] INT x1, [1 : 1, 1 : 1] REF LONG REAL x2, [1 : 1, 1 : 1, 1 : 1] REF REF PROC VOID x3, [1 : 1] PROC VOID x4, [1 : 1] PROC (INT) VOID x5, [1 : 1] PROC (INT, REAL, REF PROC VOID) VOID x6, [1 : 1, 1 : 1, 1 : 1, 1 : 1] REF REF PROC (INT) VOID x7, [1 : 1] REF [] INT x8, [1 : 1] REF [, , , ] REF PROC VOID x9, [1 : 1] REF PROC ([] INT) VOID x10, [1 : 1] PROC ([] REF PROC VOID, REF [, , ] PROC VOID, REF REF REF REF [, ] REF REF REF PROC VOID) VOID x11, [1 : 1] REF [] REF [, , ] REF REF [] LONG REAL x12, [1 : 1] PROC (REF [] PROC VOID, [] PROC VOID, [] REF INT) VOID x13; SKIP END; # 2. Variable and constant declarations. # BEGIN PROC VOID a; PROC (INT) VOID b; PROC VOID c, d; REAL e; REAL f, g; SKIP; SKIP; SKIP; SKIP END; # 3. Declarations of routines. # BEGIN INT i; PROC a = VOID: SKIP; PROC (INT) VOID b = (INT c) VOID: SKIP; PROC (INT, REAL) VOID c = (INT e, REAL f) VOID: SKIP; BEGIN PROC c = VOID: a; # no error # SKIP END END; # 4. Call without parameters. # BEGIN PROC VOID a = VOID: SKIP; PROC VOID b; REF PROC VOID c = b; REF PROC VOID d; a; # without deref # b; # with deref # c; # with deref # d; # with deref # SKIP END; # 5. Call with parameters. # BEGIN INT int; REAL real; PROC (INT) VOID dcs1, PROC (INT, REAL) VOID dcs2; PROC (INT) VOID a = (INT a) VOID: SKIP; PROC (INT) VOID b; REF PROC (INT) VOID c = b; REF PROC (INT) VOID d; PROC (INT, REAL) VOID e = (INT a, REAL b) VOID: SKIP; a (int); dcs1 (int); dcs2 (int, real); e (int, real); b (int); c (int); d (int); BEGIN REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF PROC (INT) VOID a; a (int); SKIP END; BEGIN # No error # PROC (REF INT, REF REAL) VOID a; a (int, real) END; BEGIN PROC (INT) VOID a; a (int) END; BEGIN PROC (INT) VOID a; a (int); SKIP END END; # 6. Assignation with an identifier as destination. # BEGIN INT a; REF INT b = a; PROC (REAL) REAL c; a := 1; b := a; c := sin; SKIP END; # 7. Assignation with a slice as destination. # BEGIN INT i, j, k, l; [i : i] REAL a1; [i : i, j : j] REAL a2; REF [] REAL a3 = a1; REF [, ] REAL a4; REF [, , ] REAL a5 = a4; [, , , ] REF REAL a6 = a3[i]; a1[i] := 3; a2[i, j] := 3; a3[i] := 3; a4[i, j] := 3; a5[i, j, k] := 3; a6[i, j, k, l] := 3; BEGIN REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF REF [] REAL x; x[i] := 3.0 END END ENDalgol68g-2.8/test-set/a68g.mc.031.coer03.a680000644000175000001440000000266212224301223014547 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer03# BEGIN # Morf versus comorf # PROC right = VOID: print ("right"), wrong = VOID: print ("wrong"); PROC deproc = (STRING mcm) VOID: print ((newline, mcm, " deproc: ")), PROC nodeproc = (STRING mcm) VOID: print ((newline, mcm, " nodeproc: ")); deproc ("selection "); proc OF STRUCT (PROC VOID proc, INT d) (right, SKIP); deproc ("slice "); [] PROC VOID (right)[1]; deproc ("routine text"); PROC VOID: right; deproc ("formula "); OP + = (INT i) PROC VOID: right; +1; deproc ("call "); ((INT i) PROC VOID: right) (1); deproc ("identifier "); right; nodeproc ("assignation "); LOC PROC VOID := wrong; nodeproc ("cast "); PROC VOID (wrong); nodeproc ("generator "); LOC PROC VOID; FOR i TO 2 DO IF i = 1 THEN deproc ("balance "); right ELSE nodeproc ("balance "); PROC VOID (wrong) FI OD ENDalgol68g-2.8/test-set/a68g.mc.068.idef12.a680000644000175000001440000000422112224301230014527 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef12# # Priorities and weird constructions # WHILE INT n := 0; OP + = (REF INT i, CHAR c) STRING: "ab"; (WHILE DO GOTO skip OD; TRUE DO SKIP OD; PRIO + = 1; SKIP EXIT skid: (HEAP INT +:= 1 + "1" +=: (HEAP STRING := "c")) = "abc" EXIT skip: GOTO skid) DO DO # The implicit structure of the formulas is ( a O1 ( b + ( c O2 d))) which is only achieved if pr(O1) < pr(+) < pr(O2) # PRIO + = 2; OP + = (INT i, BOOL b) STRING: (print ("corr"); "ect,"); OP + = (REAL x, BOOL b) BOOL: (print ("Line "); FALSE); OP + = (CHAR c, BOOL b) BOOL: (print ("two "); FALSE); OP + = (BITS b, INT i) STRING: (print ("one "); "Nope "); OP + = (REF BYTES b, REAL x) INT: (print ("is "); -(n +:= 1)); OP + = (STRING s, COMPL c) BITS: (print ("sho"); drop); print ((HEAP STRING +:= ABS IF PRIO + = 3; ODD n OR 2.0 + "a" = "b" THEN PRIO + = 4; TRUE AND "a" + 2 < 3 ELSE PRIO + = 5; "prio" = 2r1 + 2 - 3 FI + # prio 2 # CASE PRIO + = 7; 0 - LOC BYTES + 3.0 ** 5 IN TRUE, FALSE OUT PRIO + = 8; 3 ELEM "prio" + 2.0 I 3.0 ESAC AND random < 0.5, newline)) OD EXIT drop: print (("rter than line three.", newline, "End of test")); stop ODalgol68g-2.8/test-set/a68g.mc.173.synt02.a680000644000175000001440000000067312224301275014631 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #synt02# BEGIN [] REAL x # This is a small program, the rest is missing# algol68g-2.8/test-set/a68g.ur.195.r8.a680000644000175000001440000001477612224301311014056 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r8 # # reads 2 cards # (print (("denotations", newline)); INT vf = 70; PRIO ?=:= = 1; #tests syntaxiques# # BOOL # ((FALSE; SKIP; FALSE; FALSE); (FALSE, SKIP, FALSE, FALSE); STRUCT (BOOL a, b, c, d) a = (FALSE, SKIP, FALSE, FALSE); [] BOOL b = (FALSE, SKIP, FALSE, FALSE); CASE 3 IN FALSE, SKIP, FALSE, FALSE OUT FALSE ESAC; (UNION (REF BOOL, PROC BOOL) a := HEAP BOOL; a | (REF BOOL): FALSE); BOOL d = FALSE; BOOL v, vv := FALSE; v := FALSE; PROC pp = (BOOL a, b) BOOL: FALSE; pp (FALSE, FALSE); OP ?=:= = (BOOL a, b) BOOL: b, ?=:= = (BOOL a) BOOL: a; ?=:=FALSE ?=:= ?=:=?=:=FALSE ?=:= FALSE); # INT # ((2147483647; SKIP; 2147483647; 2147483647); (2147483647, SKIP, 2147483647, 2147483647); STRUCT (INT a, b, c, d) a = (2147483647, SKIP, 2147483647, 2147483647); [] INT b = (2147483647, SKIP, 2147483647, 2147483647); CASE 3 IN 2147483647, SKIP, 2147483647, 2147483647 OUT 2147483647 ESAC; (UNION (REF INT, PROC INT) a := HEAP INT; a | (REF INT): 2147483647); INT d = 2147483647; INT v, vv := 2147483647; v := 2147483647; PROC pp = (INT a, b) INT: 2147483647; pp (2147483647, 2147483647); OP ?=:= = (INT a, b) INT: b, ?=:= = (INT a) INT: a; ?=:=2147483647 ?=:= ?=:=?=:=2147483647 ?=:= 2147483647); # REAL # ((-1e-00000; SKIP; -1e-00000; -1e-00000); (-1e-00000, SKIP, -1e-00000, -1e-00000); STRUCT (REAL a, b, c, d) a = (-1e-00000, SKIP, -1e-00000, -1e-00000); [] REAL b = (-1e-00000, SKIP, -1e-00000, -1e-00000); CASE 3 IN -1e-00000, SKIP, -1e-00000, -1e-00000 OUT -1e-00000 ESAC; (UNION (REF REAL, PROC REAL) a := HEAP REAL; a | (REF REAL): -1e-00000); REAL d = -1e-00000; REAL v, vv := -1e-00000; v := -1e-00000; PROC pp = (REAL a, b) REAL: -1e-00000; pp (-1e-00000, -1e-00000); OP ?=:= = (REAL a, b) REAL: b, ?=:= = (REAL a) REAL: a; ?=:=-1e-00000 ?=:= ?=:=?=:=-1e-00000 ?=:= -1e-00000); # CHAR # ((""""; SKIP; """"; """"); ("""", SKIP, """", """"); STRUCT (CHAR a, b, c, d) a = ("""", SKIP, """", """"); [] CHAR b = ("""", SKIP, """", """"); CASE 3 IN """", SKIP, """", """" OUT """" ESAC; (UNION (REF CHAR, PROC CHAR) a := HEAP CHAR; a | (REF CHAR): """"); CHAR d = """"; CHAR v, vv := """"; v := """"; PROC pp = (CHAR a, b) CHAR: """"; pp ("""", """"); OP ?=:= = (CHAR a, b) CHAR: b, ?=:= = (CHAR a) CHAR: a; ?=:="""" ?=:= ?=:=?=:="""" ?=:= """"); # COMPL # ((001 I -02; SKIP; 001 I -02; 001 I -02); (001 I -02, SKIP, 001 I -02, 001 I -02); STRUCT (COMPL a, b, c, d) a = (001 I -02, SKIP, 001 I -02, 001 I -02); [] COMPL b = (001 I -02, SKIP, 001 I -02, 001 I -02); CASE 3 IN 001 I -02, SKIP, 001 I -02, 001 I -02 OUT 001 I -02 ESAC; (UNION (REF COMPL, PROC COMPL) a := HEAP COMPL; a | (REF COMPL): 001 I -02); COMPL d = 001 I -02; COMPL v, vv := 001 I -02; v := 001 I -02; PROC pp = (COMPL a, b) COMPL: 001 I -02; pp (001 I -02, 001 I -02); OP ?=:= = (COMPL a, b) COMPL: b, ?=:= = (COMPL a) COMPL: a; ?=:=(001 I -02) ?=:= ?=:=?=:=(001 I -02) ?=:= (001 I -02)); # BITS # ((8r7054; SKIP; 8r7054; 8r7054); (8r7054, SKIP, 8r7054, 8r7054); STRUCT (BITS a, b, c, d) a = (8r7054, SKIP, 8r7054, 8r7054); [] BITS b = (8r7054, SKIP, 8r7054, 8r7054); CASE 3 IN 8r7054, SKIP, 8r7054, 8r7054 OUT 8r7054 ESAC; (UNION (REF BITS, PROC BITS) a := HEAP BITS; a | (REF BITS): 8r7054); BITS d = 8r7054; BITS v, vv := 8r7054; v := 8r7054; PROC pp = (BITS a, b) BITS: 8r7054; pp (8r7054, 8r7054); OP ?=:= = (BITS a, b) BITS: b, ?=:= = (BITS a) BITS: a; ?=:=8r7054 ?=:= ?=:=?=:=8r7054 ?=:= 8r7054); # STRING # (("#("" END #"; SKIP; "#("" END #"; "#("" END #"); ("#("" END #", SKIP, "#("" END #", "#("" END #"); STRUCT (STRING a, b, c, d) a = ("#("" END #", SKIP, "#("" END #", "#("" END #"); [] STRING b = ("#("" END #", SKIP, "#("" END #", "#("" END #"); CASE 3 IN "#("" END #", SKIP, "#("" END #", "#("" END #" OUT "#("" END #" ESAC; (UNION (REF STRING, PROC STRING) a := HEAP STRING; a | (REF STRING): "#("" END #"); STRING d = "#("" END #"; STRING v, vv := "#("" END #"; v := "#("" END #"; PROC pp = (STRING a, b) STRING: "#("" END #"; pp ("#("" END #", "#("" END #"); OP ?=:= = (STRING a, b) STRING: b, ?=:= = (STRING a) STRING: a; ?=:="#("" END #" ?=:= ?=:=?=:="#("" END #" ?=:= "#("" END #"); #tests semantiques# INT ctr := 0; print ((" BOOL denotations", newline)); ctr +:= ABS TRUE + 1 - ABS FALSE; print (("true : ", TRUE, " false : ", FALSE, newline)); print ((" INT denotations", newline)); print ((" REAL denotations", newline)); print ((" CHAR denotations", newline)); [] CHAR k = ("#", "@", ",", "?", "$", "*", ".", "<", "-", "+", "a", " ", "z", ")", "e", "[", "r", "t", "|", "y", "1", "u", "2", "i", "3", "o", "&", "p", "0", "/", "q", ">", "s", ":", "d", ";", "f", "^", "g", "'", "h", "4", "j", "5", "k", "6", "l", "w", "?", "x", """", "c", "=", "v", "]", "b", "(", "n", "7", "m", "8", "9", " "); [1 : UPB k] CHAR l; FOR i TO UPB k DO l[i] := k[i]; (k[i] = l[i] | ctr +:= 1 | print ("err.char")) OD; print ((" COMPL denotations", newline)); (ABS (-2 * re OF COMPL (-00001, 002) - IM COMPL (-000001, 0000000000000000000002)) > 0.001 | print ("err.compl") | ctr +:= 1); print ((" BITS denotations", newline)); (2r101010111100110111101111 /= 16rabcdef | print ("err.bits") |: 8r3377337733 /= 4r123333123233123 | ctr +:= 1 | print ("err.bits")); print ((" STRING denotations", newline)); STRING s := "string"; (s = "string" | ctr +:= 1 | print ("err.string")); s := "gnirts"; (s = "gnirts" | ctr +:= 1 | print ("err.string")); print ((newline, "void denotation", newline)); (UNION (BYTES, VOID) u := EMPTY; u | (VOID): ctr +:= 1 | print ("err.void")); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.071.jump01.a680000644000175000001440000000102712224301231014565 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #jump01# # Simple jumps and EXIT's # (FOR i TO 2 DO IF i = 2 THEN GOTO l FI; print ("First") EXIT l: print (" second") # Result: First second # OD)algol68g-2.8/test-set/a68g.mc.056.garb04.a680000644000175000001440000000132312224301227014537 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #garb04# BEGIN # Heap # INT n := 0, REF INT x := LOC INT := 0; l: (HEAP INT p := n +:= 1; print ((x, p)); # 0,1,1,2,2,... # x := p); (n < 100 | l); print (newline); print (("collections, garbage, collect seconds:", newline)); print ((collections, garbage, collect seconds, newline)) ENDalgol68g-2.8/test-set/a68g.mc.085.misc04.a680000644000175000001440000000223712224301232014562 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #misc04# BEGIN # A primary # MODE # M = PROC(INT)[]PROC P, # P = REF [] PROC (CHAR) N, N = [1 : 0] UNION (INT, CHAR); INT ii # partial parameter # ; FOR k TO 5 DO FOR l TO 5 DO FOR m TO 2 DO print (CASE BEGIN (INT i) [] PROC P: (ii := i; P: HEAP [1 : 2] PROC (CHAR) N := (SKIP, (CHAR c) N: (ii, c))) END (k)[1][2] ("abcde"[l])[m] IN (CHAR c): c, (INT i): "12345"[i] ESAC) OD OD OD # hit 'm hard, the output should be : 1a1b1c1d1e2a2b ... 5c5d5e # ENDalgol68g-2.8/test-set/a68g.mc.087.misc06.a680000644000175000001440000000216312224301233014565 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #misc06# PR timelimit 5 PR BEGIN # Test recursion by Ackermann function. This program should be run with successive inputs: 1, 2, 3, 4 and 5, and will crash at a certain depth. See: Y. Sundblad, A Study of the Highly Recursive Ackermann Function as a Test of Recursive Procedures, NA 18, Royal Institute of Technology, Stockholm # PROC ack = (INT m, n) INT: IF m = 0 THEN n + 1 ELIF n = 0 THEN ack (m - 1, 1) ELSE ack (m - 1, ack (m, n - 1)) FI # ack # ; INT m; # read(m);# m := 1; # read(m);# m := 2; # read(m);# m := 3; FOR n FROM 0 DO print ((newline, m, n, ack (m, n), newline)) OD ENDalgol68g-2.8/test-set/a68g.mc.003.appl03.a680000644000175000001440000000173312224301215014551 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl03# BEGIN # ALGOL 68 program TJD 730701. This program prints a difference table of a 4-th degree polynomial. # [0 : 5] INT a; OP MIM = (INT a, b) INT: (a <= b | a | b); PRIO MIM = 1; PROC pol4 = (INT x) INT: x * (x + 1) * (x + 2) * (x + 3); FOR n FROM 0 TO 20 DO INT kmax = n MIM 5; [0 : kmax] INT b; b[0] := pol4 (n); FOR k TO kmax DO b[k] := b[k - 1] - a[k - 1] OD; a[0 : kmax AT 0] := b; print ((n, b, newline)) OD ENDalgol68g-2.8/test-set/a68g.ur.184.r541b.a680000644000175000001440000010220112224301301014334 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r541b # (print (("routine texts with parameters", newline)); INT vf = 44 * 10 + 3; INT ctr := 0, ctrt := 0, ctrloc; PROC ctrl = (INT inc) VOID: (ctr /= ctrloc + inc | print (("count er in test", ctrt, ctr, ctrloc + inc, newline))); MODE MU = UNION (STRING, CHAR); # servitudes pour les corps de routines # OP MON = (REAL a) REAL: (ctr +:= 1; 3.1415), = = (BOOL a, INT b) INT: (a | b | ctr -:= 1), UNION (INT, BOOL) vu, MODE STRA = STRUCT (INT de, REF INT of), [, ] INT ta = 1, PROC pra = (UNION (INT, BOOL) a) INT: (a | (INT x): (ctr +:= 1; x)), INT ida = 1; MODE STRB = STRUCT (BOOL de, REF INT of), [, ] BOOL tb = TRUE, PROC prb = (UNION (INT, BOOL) a) BOOL: (a | (BOOL x): (ctr +:= 1; x)), BOOL idb = TRUE; # mode rendu : PROC ( INT , MU , MU ) INT # (MODE R = PROC (INT, MU, MU) INT; PROC test = (R proc) VOID: IF proc (1, "", " ") = 1 THEN ctr +:= 1 ELSE print (("er", ctrt, ctr - ctrloc, newline)) FI; OP ?=:= = (R x) R: (test (x); x); (ctrt := 1; ctrloc := ctr; test ((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)); FOR ident FROM ((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)) (1, "", " ") BY ((INT ida, MU b, c) INT: pra (1)) (1, "", " ") TO ((INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]) (1, "", " ") WHILE ((INT ida, MU b, c) BOOL: tb[ida, (ctr +:= 1; 1)]) (1, "", " ") DO [((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)) (1, "", " ") : 4, -1 : ((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)) (1, "", " ")] R ent; ent[((INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC) (1, "", " "), 0] := ent[1, ((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)) (1, "", " ")] := (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1); REAL e = 0.12345; (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)); test (par); alfa := ?=:=((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)); R ident = (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP), R loc := CASE ((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)) (1, "", " ") IN (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], SKIP ESAC, tas := (INT ida, MU b, c) INT: pra (1); test (ident); test (loc); test (tas); PROC proc = R: (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), ((INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)); UNION (R, CHAR) union := pr (proc, (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP), proc); test ((union | (R a): a)); (test (R BEGIN (INT ida, MU b, c) INT: pra (1) END), ?=:=(union; ((INT ida, MU b, c) BOOL: prb (TRUE)) (1, "", " ") | (INT ida, MU b, c) INT: pra (1)), (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1), test ((BOOL bool = FALSE; union | (R): (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1), (CHAR car): SKIP))); ctrl (44)); (ctrt := 2; ctrloc := ctr; test ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1); FOR ident FROM ((INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)) (1, "", " ") BY ((INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC) (1, "", " ") TO ((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)) (1, "", " ") WHILE ((INT ida, MU b, c) BOOL: tb[ida, (ctr +:= 1; 1)]) (1, "", " ") DO [((INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)) (1, "", " ") : 4, -1 : ((INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)) (1, "", " ")] R ent; ent[((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)) (1, "", " "), 0] := ent[1, ((INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)) (1, "", " ")] := (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]; REAL e = 0.12345; (INT ida, MU b, c) INT: pra (1)); test (par); alfa := ?=:=((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)); R ident = (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP), R loc := CASE ((INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]) (1, "", " ") IN (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1), SKIP ESAC, tas := (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida); test (ident); test (loc); test (tas); PROC proc = R: (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), ((INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1); UNION (R, CHAR) union := pr (proc, (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP), proc); test ((union | (R a): a)); (test (R BEGIN (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP) END), ?=:=(union; ((INT ida, MU b, c) BOOL: BOOL (ctr +:= 1; ida | TRUE, SKIP)) (1, "", " ") | (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)), (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], test ((BOOL bool = FALSE; union | (R): (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], (CHAR car): SKIP))); ctrl (44)); (ctrt := 3; ctrloc := ctr; test ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1); FOR ident FROM ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1) (1, "", " ") BY ((INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]) (1, "", " ") TO ((INT ida, MU b, c) INT: pra (1)) (1, "", " ") WHILE ((INT ida, MU b, c) BOOL: de OF STRB (TRUE, ctr +:= 1)) (1, "", " ") DO [((INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC) (1, "", " ") : 4, -1 : ((INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]) (1, "", " ")] R ent; ent[((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)) (1, "", " "), 0] := ent[1, ((INT ida, MU b, c) INT: pra (1)) (1, "", " ")] := (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1); REAL e = 0.12345; (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)); test (par); alfa := ?=:=((INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]); R ident = (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], R loc := CASE ((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)) (1, "", " ") IN (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida), SKIP ESAC, tas := (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1; test (ident); test (loc); test (tas); PROC proc = R: (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]); UNION (R, CHAR) union := pr (proc, (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, proc); test ((union | (R a): a)); (test (R BEGIN (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END END), ?=:=(union; ((INT ida, MU b, c) BOOL: CASE vu := (ctr +:= 1; TRUE) IN (BOOL x): x ESAC) (1, "", " ") | (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)), (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP), test ((BOOL bool = FALSE; union | (R): (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], (CHAR car): SKIP))); ctrl (44)); (ctrt := 4; ctrloc := ctr; test ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1); FOR ident FROM ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1) (1, "", " ") BY ((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)) (1, "", " ") TO ((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)) (1, "", " ") WHILE ((INT ida, MU b, c) BOOL: de OF STRB (TRUE, ctr +:= 1)) (1, "", " ") DO [((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)) (1, "", " ") : 4, -1 : ((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)) (1, "", " ")] R ent; ent[((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)) (1, "", " "), 0] := ent[1, ((INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)) (1, "", " ")] := (INT ida, MU b, c) INT: pra (1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1; REAL e = 0.12345; (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END); test (par); alfa := ?=:=((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1); R ident = (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, R loc := CASE ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1) (1, "", " ") IN (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP), SKIP ESAC, tas := (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1); test (ident); test (loc); test (tas); PROC proc = R: (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), ((INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, (INT ida, MU b, c) INT: pra (1), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); (INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); UNION (R, CHAR) union := pr (proc, (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], proc); test ((union | (R a): a)); (test (R BEGIN (INT ida, MU b, c) INT: pra (1) END), ?=:=(union; ((INT ida, MU b, c) BOOL: BOOL (ctr +:= 1; ida | TRUE, SKIP)) (1, "", " ") | (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)), (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, test ((BOOL bool = FALSE; union | (R): (INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, (CHAR car): SKIP))); ctrl (44)); (ctrt := 5; ctrloc := ctr; test ((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)); FOR ident FROM ((INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]) (1, "", " ") BY ((INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC) (1, "", " ") TO ((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)) (1, "", " ") WHILE ((INT ida, MU b, c) BOOL: BEGIN INT x; ctr +:= 1; e: TRUE EXIT f: SKIP END) (1, "", " ") DO [((INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC) (1, "", " ") : 4, -1 : ((INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END) (1, "", " ")] R ent; ent[((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1) (1, "", " "), 0] := ent[1, ((INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC) (1, "", " ")] := (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1); REAL e = 0.12345; (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)); test (par); alfa := ?=:=((INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]); R ident = (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida), R loc := CASE ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1) (1, "", " ") IN (INT ida, MU b, c) INT: pra (1), SKIP ESAC, tas := (INT ida, MU b, c) INT: pra (1); test (ident); test (loc); test (tas); PROC proc = R: (INT ida, MU b, c) INT: pra (1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), ((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)); UNION (R, CHAR) union := pr (proc, (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP), proc); test ((union | (R a): a)); (test (R BEGIN (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP) END), ?=:=(union; ((INT ida, MU b, c) BOOL: tb[ida, (ctr +:= 1; 1)]) (1, "", " ") | (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END), (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1), test ((BOOL bool = FALSE; union | (R): (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, (CHAR car): SKIP))); ctrl (44)); (ctrt := 6; ctrloc := ctr; test ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1); FOR ident FROM ((INT ida, MU b, c) INT: pra (1)) (1, "", " ") BY ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1) (1, "", " ") TO ((INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)) (1, "", " ") WHILE ((INT ida, MU b, c) BOOL: de OF STRB (TRUE, ctr +:= 1)) (1, "", " ") DO [((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)) (1, "", " ") : 4, -1 : ((INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END) (1, "", " ")] R ent; ent[((INT ida, MU b, c) INT: pra (1)) (1, "", " "), 0] := ent[1, ((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)) (1, "", " ")] := (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; (INT ida, MU b, c) INT: pra (1); REAL e = 0.12345; (INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); test (par); alfa := ?=:=((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)); R ident = (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], R loc := CASE ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1) (1, "", " ") IN (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1), SKIP ESAC, tas := (INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC; test (ident); test (loc); test (tas); PROC proc = R: (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), ((INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)); UNION (R, CHAR) union := pr (proc, (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, proc); test ((union | (R a): a)); (test (R BEGIN (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1) END), ?=:=(union; ((INT ida, MU b, c) BOOL: CASE vu := (ctr +:= 1; TRUE) IN (BOOL x): x ESAC) (1, "", " ") | (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)), (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, test ((BOOL bool = FALSE; union | (R): (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1), (CHAR car): SKIP))); ctrl (44)); (ctrt := 7; ctrloc := ctr; test ((INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END); FOR ident FROM ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1) (1, "", " ") BY ((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)) (1, "", " ") TO ((INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)) (1, "", " ") WHILE ((INT ida, MU b, c) BOOL: CASE vu := (ctr +:= 1; TRUE) IN (BOOL x): x ESAC) (1, "", " ") DO [((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)) (1, "", " ") : 4, -1 : ((INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC) (1, "", " ")] R ent; ent[((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)) (1, "", " "), 0] := ent[1, ((INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)) (1, "", " ")] := (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]; REAL e = 0.12345; (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)); test (par); alfa := ?=:=((INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)); R ident = (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1), R loc := CASE ((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)) (1, "", " ") IN (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], SKIP ESAC, tas := (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1); test (ident); test (loc); test (tas); PROC proc = R: (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, (INT ida, MU b, c) INT: pra (1), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1); UNION (R, CHAR) union := pr (proc, (INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, proc); test ((union | (R a): a)); (test (R BEGIN (INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC END), ?=:=(union; ((INT ida, MU b, c) BOOL: de OF STRB (TRUE, ctr +:= 1)) (1, "", " ") | (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)), (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1), test ((BOOL bool = FALSE; union | (R): (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1), (CHAR car): SKIP))); ctrl (44)); (ctrt := 8; ctrloc := ctr; test ((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)); FOR ident FROM ((INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END) (1, "", " ") BY ((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)) (1, "", " ") TO ((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)) (1, "", " ") WHILE ((INT ida, MU b, c) BOOL: CASE vu := (ctr +:= 1; TRUE) IN (BOOL x): x ESAC) (1, "", " ") DO [((INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)) (1, "", " ") : 4, -1 : ((INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)) (1, "", " ")] R ent; ent[((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)) (1, "", " "), 0] := ent[1, ((INT ida, MU b, c) INT: pra (1)) (1, "", " ")] := (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1); REAL e = 0.12345; (INT ida, MU b, c) INT: pra (1)); test (par); alfa := ?=:=((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)); R ident = (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], R loc := CASE ((INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)) (1, "", " ") IN (INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, SKIP ESAC, tas := (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP); test (ident); test (loc); test (tas); PROC proc = R: (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), ((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, (INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); (INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)); UNION (R, CHAR) union := pr (proc, (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, proc); test ((union | (R a): a)); (test (R BEGIN (INT ida, MU b, c) INT: pra (1) END), ?=:=(union; ((INT ida, MU b, c) BOOL: (NOT idb | SKIP | ctr +:= 1; idb)) (1, "", " ") | (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)), (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, test ((BOOL bool = FALSE; union | (R): (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, (CHAR car): SKIP))); ctrl (44)); (ctrt := 9; ctrloc := ctr; test ((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)); FOR ident FROM ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1) (1, "", " ") BY ((INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END) (1, "", " ") TO ((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1) (1, "", " ") WHILE ((INT ida, MU b, c) BOOL: de OF STRB (TRUE, ctr +:= 1)) (1, "", " ") DO [((INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)) (1, "", " ") : 4, -1 : ((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)) (1, "", " ")] R ent; ent[((INT ida, MU b, c) INT: pra (1)) (1, "", " "), 0] := ent[1, ((INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP)) (1, "", " ")] := (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP); REAL e = 0.12345; (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)); test (par); alfa := ?=:=((INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); R ident = (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1), R loc := CASE ((INT ida, MU b, c) INT: pra (1)) (1, "", " ") IN (INT ida, MU b, c) INT: pra (1), SKIP ESAC, tas := (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1); test (ident); test (loc); test (tas); PROC proc = R: (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), ((INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, (INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)); UNION (R, CHAR) union := pr (proc, (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1), proc); test ((union | (R a): a)); (test (R BEGIN (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END END), ?=:=(union; ((INT ida, MU b, c) BOOL: CASE vu := (ctr +:= 1; TRUE) IN (BOOL x): x ESAC) (1, "", " ") | (INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END), (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP), test ((BOOL bool = FALSE; union | (R): (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP), (CHAR car): SKIP))); ctrl (44)); (ctrt := 10; ctrloc := ctr; test ((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)); FOR ident FROM ((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)) (1, "", " ") BY ((INT ida, MU b, c) INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END) (1, "", " ") TO ((INT ida, MU b, c) INT: pra (1)) (1, "", " ") WHILE ((INT ida, MU b, c) BOOL: tb[ida, (ctr +:= 1; 1)]) (1, "", " ") DO [((INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1)) (1, "", " ") : 4, -1 : ((INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)) (1, "", " ")] R ent; ent[((INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida)) (1, "", " "), 0] := ent[1, ((INT ida, MU b, c) INT: INT: (ctr +:= 1; 1)) (1, "", " ")] := (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1); REAL e = 0.12345; (INT ida, MU b, c) INT: pra (1)); test (par); alfa := ?=:=((INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1); R ident = (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, R loc := CASE ((INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)]) (1, "", " ") IN (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, SKIP ESAC, tas := (INT ida, MU b, c) INT: (NOT idb | SKIP | ctr +:= 1; ida); test (ident); test (loc); test (tas); PROC proc = R: (INT ida, MU b, c) INT: INT (ctr +:= 1; ida | 1, SKIP), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), ((INT ida, MU b, c) INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, (INT ida, MU b, c) INT: 3.1415 = MON 0.5 = 1, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); (INT ida, MU b, c) INT: pra (1)); UNION (R, CHAR) union := pr (proc, (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], proc); test ((union | (R a): a)); (test (R BEGIN (INT ida, MU b, c) INT: LOC INT := (ctr +:= 1; 1) END), ?=:=(union; ((INT ida, MU b, c) BOOL: BOOL: (ctr +:= 1; TRUE)) (1, "", " ") | (INT ida, MU b, c) INT: de OF STRA (1, ctr +:= 1)), (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], test ((BOOL bool = FALSE; union | (R): (INT ida, MU b, c) INT: ta[ida, (ctr +:= 1; 1)], (CHAR car): SKIP))); ctrl (44)); SKIP); # corps = relation d IDENTITE # ctrt := 11; ctrloc := ctr; TO 1 WHILE BOOL: vu :/=: (ctr +:= 1; NIL) DO (BOOL: (idb | ctr | ctrt) :=: ctr +:= 1 | ctr +:= 1) OD; ctrl (3); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.037.coer09.a680000644000175000001440000000143212224301223014555 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer09# BEGIN # Soft balance # print (CASE 2 IN SKIP, NIL, IF BOOL (SKIP) THEN GOTO stop ELSE PROC REF [] INT (SKIP) FI ESAC :=: CASE 3 IN LOC REF REF [] INT, LOC INT, NIL ESAC) #TRUE, would you believe # ENDalgol68g-2.8/test-set/a68g.mc.048.decl07.a680000644000175000001440000000421512224301225014540 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #decl07# # Now, errors # BEGIN INT int, REAL real; BEGIN INT a; [ a : a ] REAL b; [ ] REAL c; #error # SKIP END; BEGIN INT a, # error # SKIP END; BEGIN REAL x = i; # error # SKIP END; BEGIN REAL x; REAL x; # error # SKIP END; BEGIN REAL x = e; REAL x = e; # error # SKIP END; BEGIN PROC a = (b #error#) VOID: SKIP ; SKIP END; BEGIN PROC a = (REF b #error#) VOID: SKIP; SKIP END; BEGIN PROC a = ([ i : i ] REAL x #error#) VOID: SKIP; SKIP END; BEGIN PROC (INT) VOID a = VOID: SKIP #error#; SKIP END; BEGIN PROC a = (SKIP) #error#; SKIP END; BEGIN PROC (INT) VOID a = (INT b) SKIP #error# ; SKIP END; BEGIN REAL x; PROC x = VOID: SKIP #error#; SKIP END; BEGIN []REAL a = int; a(int) END; BEGIN PROC (INT) VOID a; a(a) END; BEGIN REF [] REAL a; a (int) END; BEGIN REF BOOL a; a(int) END; BEGIN PROC VOID a; a(int) END; BEGIN PROC (INT) VOID a; a(int, real) END; BEGIN PROC (INT, REAL) VOID a; a(int) END; BEGIN INT x = a; x := a; SKIP; SKIP END; BEGIN []INT x = a; x := a END; BEGIN [] REF INT x = a; x := a; SKIP END; a := 2 # Now, errors concerning mode of primary # BEGIN []REAL x=i; x[i]:= 3.0 END; BEGIN REAL x; x[i]:=3.0 END; BEGIN REF REAL x; x[i]:=3.0 END; BEGIN REF REAL x=i; x[i]:=3.0 END; # Now, errors concerning number of indexers # BEGIN REF[]REAL x; x[i, j]:=3.0 END; BEGIN REF[ , ]REAL x; x[i]:=3.0 END; BEGIN REF[ , ]REAL x; x[i, j, k] :=3.0 END END algol68g-2.8/test-set/a68g.mc.110.oper01.a680000644000175000001440000000110212224301253014547 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper01# BEGIN # Operator test # OP +:= = (INT a, b) INT: a + b; OP +:= = (INT a, REAL b) INT: ROUND (a - b); print (2 +:= 1); # yields 3 # print (2 +:= 1.0) # yields 1 # ENDalgol68g-2.8/test-set/a68g.mc.157.smio08.a680000644000175000001440000000160412224301262014602 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio08# BEGIN # 10/08/73, R van Vliet; 30/09/75, revised. Test the print and putroutines.# print ((newline, "It should print 2:")); ([1 : 7] PROC (REF FILE) VOID p; INT k := 0; p[1] := (REF FILE f) VOID: (k +:= 1; SKIP); FOR i FROM 2 TO UPB p DO p[i] := (REF FILE f) VOID: (k +:= 1; GOTO l) OD; print ((REF FILE f) VOID: FOR i TO UPB p DO p[i] (f) OD); l: print ((k, new line))) ENDalgol68g-2.8/test-set/a68g.mc.010.appl10.a680000644000175000001440000000373612224301217014554 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl10# BEGIN # Conversion from Gregorian date to weekday # PROC weekday = (INT year, month, day) STRING: [] STRING ("Sun", "Mon", "Tues", "Wednes", "Thurs", "Fri", "Satur")[(INT y := year, m := month - 2; IF m < 1 THEN m +:= 12; y -:= 1 FI; # since the year actually starts March 1st # 365 * y # number of days since year 0 # + y OVER 4 # plus leap days # - y OVER 100 # minus 1 for every century # + y OVER 400 # plus 1 for every 4 centuries # + [] INT (0, 31, 61, 92, 122, 153, 184, 214, 245, 275, 306, 337)[m] # plus number of days in this year since March 1 # + day + 2) MOD 7 + 1] + "day"; # Prints the week around 1968, Feb 29th, starting at Sunday # print ((weekday (1968, 2, 25), newline)); print ((weekday (1968, 2, 26), newline)); print ((weekday (1968, 2, 27), newline)); print ((weekday (1968, 2, 28), newline)); print ((weekday (1968, 2, 29), newline)); print ((weekday (1968, 3, 1), newline)); print ((weekday (1968, 3, 2), newline)) ENDalgol68g-2.8/test-set/a68g.mc.178.synt07.a680000644000175000001440000001121612224301275014636 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #synt07# # Please feel free to shuffle # -one);print((valueOFa,valueOFbs//t,dp*dq*r)END;,m;(k = (INT a, b) INT: a + b; decls +:= 1; OP := = (INT a, b) INT: a + b; decls +:= 1; OP =: = (INT a, b) INT: a + b; decls +:= 1; OP = (INT a, b) INT: a + b; decls +:= 1; OP >< = (INT a, b) INT: a + b; decls +:= 1; OP >> = (INT a, b) INT: a + b; decls +:= 1; OP >/ = (INT a, b) INT: a + b; decls +:= 1; OP >= = (INT a, b) INT: a + b; decls +:= 1; OP >* = (INT a, b) INT: a + b; decls +:= 1; OP >:= = (INT a, b) INT: a + b; decls +:= 1; OP ><:= = (INT a, b) INT: a + b; decls +:= 1; OP >>:= = (INT a, b) INT: a + b; decls +:= 1; OP >/:= = (INT a, b) INT: a + b; decls +:= 1; OP >=:= = (INT a, b) INT: a + b; decls +:= 1; OP >*:= = (INT a, b) INT: a + b; decls +:= 1; OP >=: = (INT a, b) INT: a + b; decls +:= 1; OP ><=: = (INT a, b) INT: a + b; decls +:= 1; OP >>=: = (INT a, b) INT: a + b; decls +:= 1; OP >/=: = (INT a, b) INT: a + b; decls +:= 1; OP >==: = (INT a, b) INT: a + b; decls +:= 1; OP >*=: = (INT a, b) INT: a + b; decls +:= 1; OP / = (INT a, b) INT: a + b; decls +:= 1; OP /< = (INT a, b) INT: a + b; decls +:= 1; OP /> = (INT a, b) INT: a + b; decls +:= 1; OP // = (INT a, b) INT: a + b; decls +:= 1; OP /= = (INT a, b) INT: a + b; decls +:= 1; OP /* = (INT a, b) INT: a + b; decls +:= 1; OP /:= = (INT a, b) INT: a + b; decls +:= 1; OP /<:= = (INT a, b) INT: a + b; decls +:= 1; OP />:= = (INT a, b) INT: a + b; decls +:= 1; OP //:= = (INT a, b) INT: a + b; decls +:= 1; OP /=:= = (INT a, b) INT: a + b; decls +:= 1; OP /*:= = (INT a, b) INT: a + b; decls +:= 1; OP /=: = (INT a, b) INT: a + b; decls +:= 1; OP /<=: = (INT a, b) INT: a + b; decls +:= 1; OP />=: = (INT a, b) INT: a + b; decls +:= 1; OP //=: = (INT a, b) INT: a + b; decls +:= 1; OP /==: = (INT a, b) INT: a + b; decls +:= 1; OP /*=: = (INT a, b) INT: a + b; decls +:= 1; OP = = (INT a, b) INT: a + b; decls +:= 1; OP =< = (INT a, b) INT: a + b; decls +:= 1; OP => = (INT a, b) INT: a + b; decls +:= 1; OP =/ = (INT a, b) INT: a + b; decls +:= 1; OP == = (INT a, b) INT: a + b; decls +:= 1; OP =* = (INT a, b) INT: a + b; decls +:= 1; OP =:= = (INT a, b) INT: a + b; decls +:= 1; OP =<:= = (INT a, b) INT: a + b; decls +:= 1; OP =>:= = (INT a, b) INT: a + b; decls +:= 1; OP =/:= = (INT a, b) INT: a + b; decls +:= 1; OP ==:= = (INT a, b) INT: a + b; decls +:= 1; OP =*:= = (INT a, b) INT: a + b; decls +:= 1; OP ==: = (INT a, b) INT: a + b; decls +:= 1; OP =<=: = (INT a, b) INT: a + b; decls +:= 1; OP =>=: = (INT a, b) INT: a + b; decls +:= 1; OP =/=: = (INT a, b) INT: a + b; decls +:= 1; OP ===: = (INT a, b) INT: a + b; decls +:= 1; OP =*=: = (INT a, b) INT: a + b; decls +:= 1; OP * = (INT a, b) INT: a + b; decls +:= 1; OP *< = (INT a, b) INT: a + b; decls +:= 1; OP *> = (INT a, b) INT: a + b; decls +:= 1; OP */ = (INT a, b) INT: a + b; decls +:= 1; OP *= = (INT a, b) INT: a + b; decls +:= 1; OP ** = (INT a, b) INT: a + b; decls +:= 1; OP *:= = (INT a, b) INT: a + b; decls +:= 1; OP *<:= = (INT a, b) INT: a + b; decls +:= 1; OP *>:= = (INT a, b) INT: a + b; decls +:= 1; OP */:= = (INT a, b) INT: a + b; decls +:= 1; OP *=:= = (INT a, b) INT: a + b; decls +:= 1; OP **:= = (INT a, b) INT: a + b; decls +:= 1; OP *=: = (INT a, b) INT: a + b; decls +:= 1; OP *<=: = (INT a, b) INT: a + b; decls +:= 1; OP *>=: = (INT a, b) INT: a + b; decls +:= 1; OP */=: = (INT a, b) INT: a + b; decls +:= 1; OP *==: = (INT a, b) INT: a + b; decls +:= 1; OP **=: = (INT a, b) INT: a + b; decls +:= 1; PRIO < = 1, << = 1, <> = 1, := = 1, =: = 1, = 1, >< = 1, >> = 1, >/ = 1, >= = 1, >* = 1, >:= = 1, ><:= = 1, >>:= = 1, >/:= = 1, >=:= = 1, >*:= = 1, >=: = 1, ><=: = 1, >>=: = 1, >/=: = 1, >==: = 1, >*=: = 1, / = 1, /< = 1, /> = 1, // = 1, /= = 1, /* = 1, /:= = 1, /<:= = 1, />:= = 1, //:= = 1, /=:= = 1, /*:= = 1, /=: = 1, /<=: = 1, />=: = 1, //=: = 1, /==: = 1, /*=: = 1, = = 1, =< = 1, => = 1, =/ = 1, == = 1, =* = 1, =:= = 1, =<:= = 1, =>:= = 1, =/:= = 1, ==:= = 1, =*:= = 1, ==: = 1, =<=: = 1, =>=: = 1, =/=: = 1, ===: = 1, =*=: = 1, * = 1, *< = 1, *> = 1, */ = 1, *= = 1, ** = 1, *:= = 1, *<:= = 1, *>:= = 1, */:= = 1, *=:= = 1, **:= = 1, *=: = 1, *<=: = 1, *>=: = 1, */=: = 1, *==: = 1, **=: = 1; print (("Should print two equal integers (number of non-bold nomads)", newline, 0 < 1 << 1 <> 1 := 1 =: 1 1 >< 1 >> 1 >/ 1 >= 1 >* 1 >:= 1 ><:= 1 >>:= 1 >/:= 1 >=:= 1 >*:= 1 >=: 1 ><=: 1 >>=: 1 >/=: 1 >==: 1 >*=: 1 / 1 /< 1 /> 1 // 1 /= 1 /* 1 /:= 1 /<:= 1 />:= 1 //:= 1 /=:= 1 /*:= 1 /=: 1 /<=: 1 />=: 1 //=: 1 /==: 1 /*=: 1 = 1 =< 1 => 1 =/ 1 == 1 =* 1 =:= 1 =<:= 1 =>:= 1 =/:= 1 ==:= 1 =*:= 1 ==: 1 =<=: 1 =>=: 1 =/=: 1 ===: 1 =*=: 1 * 1 *< 1 *> 1 */ 1 *= 1 ** 1 *:= 1 *<:= 1 *>:= 1 */:= 1 *=:= 1 **:= 1 *=: 1 *<=: 1 *>=: 1 */=: 1 *==: 1 **=: 1, decls)) ENDalgol68g-2.8/test-set/a68g.mc.055.garb03.a680000644000175000001440000000220512224301226014534 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #garb03# BEGIN # Test garbage collector # INT size = 250; REF [] REAL x, [1 : size] REF [] REAL y, INT n := 1; l: x := HEAP [1 : n] REAL; # to throw away # y[n] := HEAP [1 : 10] REAL; # to be kept # FOR k TO 10 DO y[n][k] := 10 * n + k - 11 OD; FOR m TO n DO FOR k TO 10 DO IF y[m][k] /= 10 * m + k - 11 THEN print ((newline, "Error in element", m, k, "value is", y[m][k], " should be", 10 * m + k - 11, new line, "after", collections, " garbage collections")) FI OD OD; IF (n +:= 1) LE size THEN l FI; print (("collections, garbage, collect seconds:", newline)); print ((collections, garbage, collect seconds, newline)) ENDalgol68g-2.8/test-set/a68g.mc.112.oper03.a680000644000175000001440000000141612224301253014563 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper03# BEGIN # Priorities # PRIO + = 7; print (1 + 2 * 3); # 9 # BEGIN PRIO + = 6; print (1 + 2 * 3) # 7 # ; FOR i TO 1 WHILE PRIO + = 7; TRUE DO print (1 + 2 * 3) # 9 # OD; print (1 + 2 * 3) # 7 # END; print (1 + 2 * 3) # 9 # ENDalgol68g-2.8/test-set/a68g.ur.182.r34a.a680000644000175000001440000014445012224301277014276 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r34a # (print (("choice using boolean", newline)); INT vf = (27 + 4 + 5 + 2) * (4 * 3 + 2 * 4) + 7 * 6; INT ctr := 0, ctrt, mem; PROC controle = (INT incr) VOID: (ctr /= mem + incr | print (("count er in test", ctrt, ctr, mem + incr, newline))); PROC test = INT: (ctr +:= 1; 1), rre = [] PROC INT: (ctr +:= 1; test), pche = PROC (STRING) PROC INT: (ctr +:= 1; (STRING a) PROC INT: test); UNION (INT, STRING) vu := 1; # servitudes pour contextes # MODE MSTR = STRUCT (COMPL de, of), PRIO += = 5, ? = 9, OP ?= = (INT x) VOID: x, += = (INT a) PROC INT: test, += = (UNION (INT, BOOL) a, INT b) BOOL: (ctr +:= 1) = b, += = (UNION (REF INT, REF BOOL) a, REAL b) MSTR: SKIP, += = (MSTR a, b) REF INT: ctr +:= 1; # declarations pour unites du mode PROC INT # OP ? = (INT a, PROC INT b) PROC INT: (ctr +:= 1; test), STRUCT (INT of, PROC INT de) structa = (0, test), PROC proca = ([] INT a) PROC INT: (ctr +:= 1; test), identa = PROC INT: (ctr +:= 1; test), [] PROC PROC INT ranga = identa; # declarations pour unites du mode PROC REF BOOL # OP ? = (INT a, PROC REF BOOL b) PROC REF BOOL: (ctr +:= 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)), STRUCT (INT of, PROC REF BOOL de) structb = (0, REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)), PROC procb = ([] INT a) PROC REF BOOL: (ctr +:= 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)), identb = PROC REF BOOL: (ctr +:= 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)), [] PROC PROC REF BOOL rangb = identb; # declarations pour unites du mode PROC MSTR # OP ? = (INT a, PROC MSTR b) PROC MSTR: (ctr +:= 1; MSTR: ((0, 0), ctr +:= 1)), STRUCT (INT of, PROC MSTR de) structc = (0, MSTR: ((0, 0), ctr +:= 1)), PROC procc = ([] INT a) PROC MSTR: (ctr +:= 1; MSTR: ((0, 0), ctr +:= 1)), identc = PROC MSTR: (ctr +:= 1; MSTR: ((0, 0), ctr +:= 1)), [] PROC PROC MSTR rangc = identc; # declarations pour unites du mode PROC [] PROC INT # OP ? = (INT a, PROC [] PROC INT b) PROC [] PROC INT: (ctr +:= 1; rre), STRUCT (INT of, PROC [] PROC INT de) structd = (0, rre), PROC procd = ([] INT a) PROC [] PROC INT: (ctr +:= 1; rre), identd = PROC [] PROC INT: (ctr +:= 1; rre), [] PROC PROC [] PROC INT rangd = identd; # declarations pour unites du mode PROC PROC ( STRING ) PROC INT # OP ? = (INT a, PROC PROC (STRING) PROC INT b) PROC PROC (STRING) PROC INT: (ctr +:= 1; pche), STRUCT (INT of, PROC PROC (STRING) PROC INT de) structe = (0, pche), PROC proce = ([] INT a) PROC PROC (STRING) PROC INT: (ctr +:= 1; pche), idente = PROC PROC (STRING) PROC INT: (ctr +:= 1; pche), [] PROC PROC PROC (STRING) PROC INT range = idente; # contextes # ctrt := 1; mem := ctr; (FOR ident FROM IF ctr +:= 1; SKIP; 0 <= 0 THEN ctr +:= 1; vu := 1; test ELSE SKIP FI BY IF (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) THEN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) FI TO IF ctr +:= 1; SKIP; 0 <= 0 THEN GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e FI WHILE IF (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) THEN ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) ELSE SKIP FI DO [IF ctr +:= 1; INT x; 0 <= 0 THEN (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test FI : 4, -ident : IF (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) THEN (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test FI] INT ent; ent[IF (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) THEN GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e ELSE SKIP FI, 0] := ent[ident, IF (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 THEN (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test ELSE SKIP FI] := IF (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 THEN INT x = 1; ctr +:= x; test FI OD; INT alfa, INT par = (SKIP; IF (ctr +:= 1; INT x = 1; x); 0 <= 0 THEN (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test ELSE SKIP FI; REAL pp = 1.00001; IF (ctr +:= 1; INT x = 1; x); 0 <= 0 THEN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) ELSE SKIP FI); alfa := 1 + IF (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 THEN ctr +:= 1; vu := 1; test ELSE SKIP FI; INT ident = IF (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) THEN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) ELSE SKIP FI, INT loc := CASE IF (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) THEN INT x = 1; ctr +:= x; test EXIT e: SKIP FI IN IF ctr +:= 1; INT x; 0 <= 0 THEN GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e ELSE SKIP FI, SKIP ESAC, tas := IF (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) THEN GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e FI, PROC proc = INT: IF (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 THEN (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test ELSE SKIP FI, STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), (IF (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 THEN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) FI, (0, 0e1))); [] INT apd = (ident, par, loc, IF ctr +:= 1; INT x; 0 <= 0 THEN INT x = 1; ctr +:= x; test FI, proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: IF (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 THEN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) ELSE SKIP FI; UNION (REAL, INT, COMPL) union := pr (proc, IF (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) THEN INT x = 1; ctr +:= x; test ELSE SKIP FI, proc); (INT BEGIN IF ctr +:= 1; INT x; 0 <= 0 THEN ctr +:= 1; vu := 1; test ELSE SKIP FI END, ?=(union; IF (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) THEN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) FI | IF (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) THEN INT x = 1; ctr +:= x; test FI), IF (ctr +:= 1; INT x = 1; x); 0 <= 0 THEN INT x = 1; ctr +:= x; test FI, (BOOL bool = TRUE; union | (INT): IF (ctr +:= 1; INT x = 1; x); 0 <= 0 THEN INT x = 1; ctr +:= x; test EXIT e: SKIP ELSE SKIP FI, (COMPL complex): SKIP)); controle (27 * 3); ctrt := 2; mem := ctr; IF (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) THEN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP FI := IF ctr +:= 1; INT x; 0 <= 0 THEN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) FI := IF ctr +:= 1; SKIP; 0 <= 0 THEN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) FI :=: IF ctr +:= 1; SKIP; 0 <= 0 THEN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) ELSE SKIP FI; controle (4 * 3); ctrt := 3; mem := ctr; +=IF (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 THEN INT x = 1; ctr +:= x; test ELSE SKIP FI += (IF ctr +:= 1; INT x; 0 <= 0 THEN INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP FI += re OF de OF IF (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 THEN ctr +:= 1; vu := 1; MSTR: ((0, 0), ctr +:= 1) FI += IF (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) THEN (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: MSTR: ((0, 0), ctr +:= 1) ELSE SKIP FI) += +=IF (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) THEN (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test ELSE SKIP FI; controle (5 * 3 + 5); ctrt := 4; mem := ctr; IF ctr +:= 1; SKIP; 0 <= 0 THEN INT x = 1; ctr +:= x; rre ELSE SKIP FI[1]; IF ctr +:= 1; INT x; 0 <= 0 THEN vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; pche) ELSE SKIP FI (""); controle (2 * 3 + 2)); ctrt := 5; mem := ctr; (FOR ident FROM (ctr +:= 1; INT x; FALSE | SKIP | INT x = 1; ctr +:= x; test EXIT e: SKIP) BY (CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC | SKIP | INT x = 1; ctr +:= x; test EXIT e: SKIP) TO ((ctr +:= 1; INT x = 1; x); FALSE | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) WHILE ((ctr +:= 1; INT x = 1; x); FALSE | SKIP | ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) DO [((ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test)) : 4, -ident : ((ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP | INT x = 1; ctr +:= x; test)] INT ent; ent[((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), 0] := ent[ident, ((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP | ctr +:= 1; vu := 1; test)] := ((INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test)) OD; INT alfa, INT par = (SKIP; ((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test); REAL pp = 1.00001; ((INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | INT x = 1; ctr +:= x; test EXIT e: SKIP)); alfa := 1 + (ctr +:= 1; INT x; FALSE | SKIP | INT x = 1; ctr +:= x; test); INT ident = ((ctr +:= 1; INT x = 1; x); FALSE | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), INT loc := CASE (ctr +:= 1; INT x; FALSE | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) IN ((ctr +:= 1; INT x = 1; x); FALSE | SKIP | INT x = 1; ctr +:= x; test), SKIP ESAC, tas := ((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), PROC proc = INT: ((INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test)), STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), (((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), (0, 0e1))); [] INT apd = (ident, par, loc, (ctr +:= 1; SKIP; FALSE | SKIP | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test)), proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: (ctr +:= 1; INT x; FALSE | SKIP | ctr +:= 1; vu := 1; test); UNION (REAL, INT, COMPL) union := pr (proc, (CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC | SKIP | INT x = 1; ctr +:= x; test), proc); (INT BEGIN (CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC | SKIP | INT x = 1; ctr +:= x; test) END, ?=(union; (ctr +:= 1; INT x; FALSE | SKIP | INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) | (ctr +:= 1; SKIP; FALSE | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e)), ((ctr +:= 1; INT x = 1; x); FALSE | SKIP | INT x = 1; ctr +:= x; test EXIT e: SKIP), (BOOL bool = TRUE; union | (INT): (ctr +:= 1; INT x; FALSE | SKIP | INT x = 1; ctr +:= x; test EXIT e: SKIP), (COMPL complex): SKIP)); controle (27 * 3); ctrt := 6; mem := ctr; (ctr +:= 1; INT x; FALSE | SKIP | ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) := ((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e) := (ctr +:= 1; SKIP; FALSE | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e) :=: (ctr +:= 1; INT x; FALSE | SKIP | INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP); controle (4 * 3); ctrt := 7; mem := ctr; +=(CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC | SKIP | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test)) += (((ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP | INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) += re OF de OF ((ctr +:= 1; INT x = 1; x); FALSE | SKIP | INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1)) += ((INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1))) += +=((INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | INT x = 1; ctr +:= x; test); controle (5 * 3 + 5); ctrt := 8; mem := ctr; ((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP | INT x = 1; ctr +:= x; rre)[1]; (CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; pche EXIT e: SKIP) EXIT f: GOTO e) (""); controle (2 * 3 + 2)); ctrt := 9; mem := ctr; (FOR ident FROM (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; INT x = 1; x); 0 <= 0 | ctr +:= 1; vu := 1; test) BY (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; 0 <= 0 | INT x = 1; ctr +:= x; test | SKIP) TO (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; INT x = 1; x); 0 <= 0 | ctr +:= 1; vu := 1; test | SKIP) WHILE (FALSE | SKIP |: FALSE | SKIP |: CASE ctr +:= 1; 1 IN 0 <= 0, SKIP ESAC | GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e) DO [(FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) : 4, -ident : (FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | ctr +:= 1; vu := 1; test)] INT ent; ent[(FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e | SKIP), 0] := ent[ident, (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 | INT x = 1; ctr +:= x; test | SKIP)] := (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; 0 <= 0 | INT x = 1; ctr +:= x; test | SKIP) OD; INT alfa, INT par = (SKIP; (FALSE | SKIP |: FALSE | SKIP |: CASE ctr +:= 1; 1 IN 0 <= 0, SKIP ESAC | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test | SKIP); REAL pp = 1.00001; (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 | ctr +:= 1; vu := 1; test)); alfa := 1 + (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | INT x = 1; ctr +:= x; test); INT ident = (FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | ctr +:= 1; vu := 1; test | SKIP), INT loc := CASE (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) | SKIP) IN (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), SKIP ESAC, tas := (FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), PROC proc = INT: (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) | SKIP), STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), ((FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; 0 <= 0 | ctr +:= 1; vu := 1; test | SKIP), (0, 0e1))); [] INT apd = (ident, par, loc, (FALSE | SKIP |: FALSE | SKIP |: CASE ctr +:= 1; 1 IN 0 <= 0, SKIP ESAC | INT x = 1; ctr +:= x; test EXIT e: SKIP | SKIP), proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: (FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | INT x = 1; ctr +:= x; test); UNION (REAL, INT, COMPL) union := pr (proc, (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), proc); (INT BEGIN (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; 0 <= 0 | INT x = 1; ctr +:= x; test | SKIP) END, ?=(union; (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; INT x; 0 <= 0 | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) | (FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | INT x = 1; ctr +:= x; test)), (FALSE | SKIP |: FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) | INT x = 1; ctr +:= x; test | SKIP), (BOOL bool = TRUE; union | (INT): (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), (COMPL complex): SKIP)); controle (27 * 3); ctrt := 10; mem := ctr; (FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE))) := (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; INT x; 0 <= 0 | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE))) := (FALSE | SKIP |: FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE))) :=: (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 | ctr +:= 1; vu := 1; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)); controle (4 * 3); ctrt := 11; mem := ctr; +=(FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; 0 <= 0 | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) | SKIP) += ((FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; INT x; 0 <= 0 | INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) += re OF de OF (FALSE | SKIP |: FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; MSTR: ((0, 0), ctr +:= 1)) | SKIP) += (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; INT x = 1; x); 0 <= 0 | INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1) EXIT e: SKIP | SKIP)) += +=(FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; 0 <= 0 | INT x = 1; ctr +:= x; test); controle (5 * 3 + 5); ctrt := 12; mem := ctr; (FALSE | SKIP |: FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) | ctr +:= 1; vu := 1; rre)[1]; (FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | INT x = 1; ctr +:= x; pche EXIT e: SKIP | SKIP) (""); controle (2 * 3 + 2)); ctrt := 13; mem := ctr; (FOR ident FROM (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test) BY (FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP | INT x = 1; ctr +:= x; test EXIT e: SKIP) TO (FALSE | SKIP |: FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test)) WHILE (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE))) DO [(FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP | ctr +:= 1; vu := 1; test) : 4, -ident : (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test)] INT ent; ent[(FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP | ctr +:= 1; vu := 1; test), 0] := ent[ident, (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP | INT x = 1; ctr +:= x; test)] := (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) OD; INT alfa, INT par = (SKIP; (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; INT x; FALSE | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test); REAL pp = 1.00001; (FALSE | SKIP |: FALSE | SKIP |: CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC | SKIP | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test))); alfa := 1 + (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; INT x = 1; x); FALSE | SKIP | INT x = 1; ctr +:= x; test EXIT e: SKIP); INT ident = (FALSE | SKIP |: FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | INT x = 1; ctr +:= x; test EXIT e: SKIP), INT loc := CASE (FALSE | SKIP |: FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) IN (FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), SKIP ESAC, tas := (FALSE | SKIP |: FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | ctr +:= 1; vu := 1; test), PROC proc = INT: (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP | INT x = 1; ctr +:= x; test EXIT e: SKIP), STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), ((FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; FALSE | SKIP | INT x = 1; ctr +:= x; test), (0, 0e1))); [] INT apd = (ident, par, loc, (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e), proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: (FALSE | SKIP |: FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e); UNION (REAL, INT, COMPL) union := pr (proc, (FALSE | SKIP |: FALSE | SKIP |: CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC | SKIP | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test)), proc); (INT BEGIN (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; FALSE | SKIP | INT x = 1; ctr +:= x; test) END, ?=(union; (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; FALSE | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) | (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP | INT x = 1; ctr +:= x; test)), (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP | INT x = 1; ctr +:= x; test), (BOOL bool = TRUE; union | (INT): (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; INT x = 1; x); FALSE | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), (COMPL complex): SKIP)); controle (27 * 3); ctrt := 14; mem := ctr; (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; INT x; FALSE | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) := (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; INT x; FALSE | SKIP | INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) := (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; INT x = 1; x); FALSE | SKIP | INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) :=: (FALSE | SKIP |: FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e); controle (4 * 3); ctrt := 15; mem := ctr; +=(FALSE | SKIP |: FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) += ((FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; FALSE | SKIP | INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) += re OF de OF (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; INT x; FALSE | SKIP | INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1) EXIT e: SKIP) += (FALSE | SKIP |: FALSE | SKIP |: (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: MSTR: ((0, 0), ctr +:= 1))) += +=(FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; FALSE | SKIP | INT x = 1; ctr +:= x; test); controle (5 * 3 + 5); ctrt := 16; mem := ctr; (FALSE | SKIP |: FALSE | SKIP |: ctr +:= 1; SKIP; FALSE | SKIP | INT x = 1; ctr +:= x; rre EXIT e: SKIP)[1]; (FALSE | SKIP |: FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; pche)) (""); controle (2 * 3 + 2)); ctrt := 17; mem := ctr; (FOR ident FROM (ctr +:= 1; SKIP; FALSE | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | INT x = 1; ctr +:= x; test) BY ((INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP |: ctr +:= 1; INT x; 0 <= 0 | INT x = 1; ctr +:= x; test) TO ((ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP |: ctr +:= 1; SKIP; 0 <= 0 | INT x = 1; ctr +:= x; test EXIT e: SKIP | SKIP) WHILE ((ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP |: (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) | INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP | SKIP) DO [((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP |: (ctr +:= 1; INT x = 1; x); 0 <= 0 | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e | SKIP) : 4, -ident : (ctr +:= 1; INT x; FALSE | SKIP |: CASE ctr +:= 1; 1 IN 0 <= 0, SKIP ESAC | INT x = 1; ctr +:= x; test EXIT e: SKIP | SKIP)] INT ent; ent[((ctr +:= 1; INT x = 1; x); FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e | SKIP), 0] := ent[ident, ((ctr +:= 1; INT x = 1; x); FALSE | SKIP |: ctr +:= 1; INT x; 0 <= 0 | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test))] := ((ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | ctr +:= 1; vu := 1; test | SKIP) OD; INT alfa, INT par = (SKIP; ((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e); REAL pp = 1.00001; (CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC | SKIP |: ctr +:= 1; INT x; 0 <= 0 | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) | SKIP)); alfa := 1 + ((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) | SKIP); INT ident = (ctr +:= 1; INT x; FALSE | SKIP |: ctr +:= 1; INT x; 0 <= 0 | INT x = 1; ctr +:= x; test EXIT e: SKIP), INT loc := CASE ((ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP |: CASE ctr +:= 1; 1 IN 0 <= 0, SKIP ESAC | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test)) IN ((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP |: ctr +:= 1; SKIP; 0 <= 0 | INT x = 1; ctr +:= x; test | SKIP), SKIP ESAC, tas := ((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | ctr +:= 1; vu := 1; test | SKIP), PROC proc = INT: ((ctr +:= 1; INT x = 1; x); FALSE | SKIP |: CASE ctr +:= 1; 1 IN 0 <= 0, SKIP ESAC | INT x = 1; ctr +:= x; test EXIT e: SKIP | SKIP), STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), (((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP |: ctr +:= 1; INT x; 0 <= 0 | INT x = 1; ctr +:= x; test EXIT e: SKIP | SKIP), (0, 0e1))); [] INT apd = (ident, par, loc, ((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP |: ctr +:= 1; INT x; 0 <= 0 | INT x = 1; ctr +:= x; test EXIT e: SKIP), proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: (ctr +:= 1; SKIP; FALSE | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) | SKIP); UNION (REAL, INT, COMPL) union := pr (proc, ((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP |: (ctr +:= 1; INT x = 1; x); 0 <= 0 | INT x = 1; ctr +:= x; test), proc); (INT BEGIN ((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP |: (INT x := 10; ctr +:= 1; TRUE | 0 <= 0) | GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e) END, ?=(union; ((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e | SKIP) | (CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) | SKIP)), ((ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 | INT x = 1; ctr +:= x; test), (BOOL bool = TRUE; union | (INT): (ctr +:= 1; SKIP; FALSE | SKIP |: (GOTO e; ctr +:= 100; e: ctr +:= 1); 0 <= 0 | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test), (COMPL complex): SKIP)); controle (27 * 4); ctrt := 18; mem := ctr; ((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e | SKIP) := ((INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP |: ctr +:= 1; SKIP; 0 <= 0 | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) := (CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) | SKIP) :=: ((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) | SKIP); controle (4 * 4); ctrt := 19; mem := ctr; +=((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP |: (INT x = 5; x); ctr +:= 1; INT x; 0 <= 0 | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test | SKIP) += (((ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) | SKIP) += re OF de OF (ctr +:= 1; INT x; FALSE | SKIP |: CASE ctr +:= 1; 1 IN 0 <= 0, SKIP ESAC | GOTO f EXIT e: (INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1) EXIT e: SKIP) EXIT f: GOTO e) += ((INT x = 5; x); ctr +:= 1; INT x; FALSE | SKIP |: ctr +:= 1; SKIP; 0 <= 0 | INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1))) += +=((INT x := 10; ctr +:= 1; TRUE | FALSE) | SKIP |: (ctr +:= 1; 0 <= 0 EXIT e: ctr +:= 100; SKIP) | (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test | SKIP); controle (5 * 4 + 5); ctrt := 20; mem := ctr; ((GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE | SKIP |: (ctr +:= 1; INT x = 1; x); 0 <= 0 | INT x = 1; ctr +:= x; rre EXIT e: SKIP)[1]; (ctr +:= 1; INT x; FALSE | SKIP |: (ctr +:= 1; INT x = 1; x); 0 <= 0 | INT x = 1; ctr +:= x; pche EXIT e: SKIP | SKIP) (""); controle (2 * 4 + 2)); ctrt := 21; mem := ctr; (FOR ident FROM IF (INT x = 5; x); ctr +:= 1; INT x; FALSE THEN SKIP ELIF (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE THEN SKIP ELSE (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test FI BY IF (ctr +:= 1; INT x = 1; x); FALSE THEN SKIP ELIF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELSE INT x = 1; ctr +:= x; test FI TO IF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELIF (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE THEN SKIP ELSE vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) FI WHILE IF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELIF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELSE vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) FI DO [IF ctr +:= 1; SKIP; FALSE THEN SKIP ELIF ctr +:= 1; INT x; FALSE THEN SKIP ELSE GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e FI : 4, -ident : IF (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) THEN SKIP ELIF ctr +:= 1; INT x; FALSE THEN SKIP ELSE vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) FI] INT ent; ent[IF ctr +:= 1; SKIP; FALSE THEN SKIP ELIF (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE THEN SKIP ELSE INT x = 1; ctr +:= x; test FI, 0] := ent[ident, IF (INT x = 5; x); ctr +:= 1; INT x; FALSE THEN SKIP ELIF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELSE INT x = 1; ctr +:= x; test FI] := IF ctr +:= 1; INT x; FALSE THEN SKIP ELIF (INT x = 5; x); ctr +:= 1; INT x; FALSE THEN SKIP ELSE INT x = 1; ctr +:= x; test FI OD; INT alfa, INT par = (SKIP; IF (INT x = 5; x); ctr +:= 1; INT x; FALSE THEN SKIP ELIF (ctr +:= 1; INT x = 1; x); FALSE THEN SKIP ELSE ctr +:= 1; vu := 1; test FI; REAL pp = 1.00001; IF ctr +:= 1; INT x; FALSE THEN SKIP ELIF ctr +:= 1; SKIP; FALSE THEN SKIP ELSE INT x = 1; ctr +:= x; test EXIT e: SKIP FI); alfa := 1 + IF (ctr +:= 1; INT x = 1; x); FALSE THEN SKIP ELIF (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) THEN SKIP ELSE INT x = 1; ctr +:= x; test FI; INT ident = IF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELIF (INT x = 5; x); ctr +:= 1; INT x; FALSE THEN SKIP ELSE vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) FI, INT loc := CASE IF ctr +:= 1; INT x; FALSE THEN SKIP ELIF (ctr +:= 1; INT x = 1; x); FALSE THEN SKIP ELSE ctr +:= 1; vu := 1; test FI IN IF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELIF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELSE vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; test) FI, SKIP ESAC, tas := IF ctr +:= 1; SKIP; FALSE THEN SKIP ELIF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELSE ctr +:= 1; vu := 1; test FI, PROC proc = INT: IF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELIF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELSE GOTO f EXIT e: (INT x = 1; ctr +:= x; test EXIT e: SKIP) EXIT f: GOTO e FI, STRUCT (COMPL of, STRUCT (INT de, COMPL of) de) de := ((0.111, 0), (IF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELIF ctr +:= 1; SKIP; FALSE THEN SKIP ELSE (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test FI, (0, 0e1))); [] INT apd = (ident, par, loc, IF ctr +:= 1; SKIP; FALSE THEN SKIP ELIF ctr +:= 1; SKIP; FALSE THEN SKIP ELSE INT x = 1; ctr +:= x; test EXIT e: SKIP FI, proc, tas, de OF de OF de), PROC pr := (INT rep, reprep, PROC INT repproc) INT: IF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELIF ctr +:= 1; SKIP; FALSE THEN SKIP ELSE (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test FI; UNION (REAL, INT, COMPL) union := pr (proc, IF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELIF (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE THEN SKIP ELSE ctr +:= 1; vu := 1; test FI, proc); (INT BEGIN IF (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE THEN SKIP ELIF ctr +:= 1; SKIP; FALSE THEN SKIP ELSE INT x = 1; ctr +:= x; test EXIT e: SKIP FI END, ?=(union; IF ctr +:= 1; SKIP; FALSE THEN SKIP ELIF ctr +:= 1; SKIP; FALSE THEN SKIP ELSE (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) FI | IF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELIF (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE THEN SKIP ELSE ctr +:= 1; vu := 1; test FI), IF (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) THEN SKIP ELIF (ctr +:= 1; FALSE EXIT e: ctr +:= 100; SKIP) THEN SKIP ELSE INT x = 1; ctr +:= x; test FI, (BOOL bool = TRUE; union | (INT): IF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELIF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELSE (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test FI, (COMPL complex): SKIP)); controle (27 * 4); ctrt := 22; mem := ctr; IF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELIF ctr +:= 1; INT x; FALSE THEN SKIP ELSE vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE)) FI := IF (ctr +:= 1; INT x = 1; x); FALSE THEN SKIP ELIF ctr +:= 1; INT x; FALSE THEN SKIP ELSE (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) FI := IF (INT x = 5; x); ctr +:= 1; INT x; FALSE THEN SKIP ELIF (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE THEN SKIP ELSE GOTO f EXIT e: (INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) EXIT e: SKIP) EXIT f: GOTO e FI :=: IF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELIF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELSE (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) FI; controle (4 * 4); ctrt := 23; mem := ctr; +=IF (ctr +:= 1; INT x = 1; x); FALSE THEN SKIP ELIF (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE THEN SKIP ELSE (INT x; ctr +:= 1 EXIT e: x); INT y; e:f:g:h: test FI += (IF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELIF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELSE INT x = 1; ctr +:= x; REF BOOL: (ctr +:= 1; HEAP BOOL := TRUE) FI += re OF de OF IF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELIF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELSE INT x = 1; ctr +:= x; MSTR: ((0, 0), ctr +:= 1) EXIT e: SKIP FI += IF (GOTO e; ctr +:= 100; e: ctr +:= 1); FALSE THEN SKIP ELIF (INT x := 10; ctr +:= 1; TRUE | FALSE) THEN SKIP ELSE vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; MSTR: ((0, 0), ctr +:= 1)) FI) += +=IF (ctr +:= 1; INT x = 1; x); FALSE THEN SKIP ELIF CASE ctr +:= 1; 1 IN FALSE, SKIP ESAC THEN SKIP ELSE INT x = 1; ctr +:= x; test EXIT e: SKIP FI; controle (5 * 4 + 5); ctrt := 24; mem := ctr; IF (ctr +:= 1; INT x = 1; x); FALSE THEN SKIP ELIF (INT x = 5; x); ctr +:= 1; INT x; FALSE THEN SKIP ELSE vu := 1; (INT x := 1; TRUE | ctr +:= 1; x; INT y; rre) FI[1]; IF (INT x = 5; x); ctr +:= 1; INT x; FALSE THEN SKIP ELIF ctr +:= 1; INT x; FALSE THEN SKIP ELSE INT x = 1; ctr +:= x; pche EXIT e: SKIP FI (""); controle (2 * 4 + 2)); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.078.mdeq03.a680000644000175000001440000000101212224301232014544 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #mdeq03# BEGIN # Mode equivalencing # MODE M = PROC(M)M, N = PROC(N)N, O = UNION(N,M); # error, 'M' and 'N' are the same # SKIP END algol68g-2.8/test-set/a68g.mc.035.coer07.a680000644000175000001440000000162412224301223014554 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer07# BEGIN # Weak balance # print ((COMPL x := 1; CASE 2 IN NIL, IF [] BOOL (TRUE, FALSE)[2] THEN REF REF [] COMPL: NIL ELSE x FI, LOC PROC REF [] STRUCT (REAL re, im) ESAC # REF [] COMPL = x # [1] := 3; x)) # 3.0 I 0.0 # ENDalgol68g-2.8/test-set/a68g.mc.083.misc02.a680000644000175000001440000000104112224301232014546 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #misc02# ( # Format denotation ? # FORMAT f = (# cp # 1, # count # 0, # bp # 1, # c # () ) # or something else likely to fool your compiler # ; putf(stand out, f) ) algol68g-2.8/test-set/a68g.mc.006.appl06.a680000644000175000001440000001022412224301216014553 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl06# # Revised Report, 11.10. # BEGIN # Formula manipulation # MODE FORM = UNION (REF CONST, REF VAR, REF TRIPLE, REF CALL), CONST = STRUCT (REAL value), VAR = STRUCT (STRING name, REAL value), TRIPLE = STRUCT (FORM left operand, INT operator, FORM right operand), FUNCTION = STRUCT (REF VAR bound var, FORM body), CALL = STRUCT (REF FUNCTION function name, FORM parameter); INT plus = 1, minus = 2, times = 3, by = 4, to = 5; HEAP CONST zero, one; value OF zero := 0; value OF one := 1; OP = = (FORM a, REF CONST b) BOOL: CASE a IN (REF CONST ec): ec :=: b OUT FALSE ESAC; OP + = (FORM a, b) FORM: (a = zero | b |: b = zero | a | HEAP TRIPLE := (a, plus, b)); OP - = (FORM a, b) FORM: (b = zero | a | HEAP TRIPLE := (a, minus, b)); OP * = (FORM a, b) FORM: (a = zero OR b = zero | zero |: a = one | b |: b = one | a | HEAP TRIPLE := (a, times, b)); OP / = (FORM a, b) FORM: (a = zero AND NOT (b = zero) | zero |: b = one | a | HEAP TRIPLE := (a, by, b)); OP ** = (FORM a, REF CONST b) FORM: (a = one OR (b :=: zero) | one |: b :=: one | a | HEAP TRIPLE := (a, to, b)); PROC derivative of = (FORM e, # with respect to # REF VAR x) FORM: CASE e IN (REF CONST): zero, (REF VAR ev): (ev :=: x | one | zero), (REF TRIPLE et): CASE FORM u = left operand OF et, v = right operand OF et; FORM udash = derivative of (u, # with respect to # x), vdash = derivative of (v, # with respect to # x); operator OF et IN udash + vdash, udash - vdash, u * vdash + udash * v, (udash - et * vdash) / v, (v | (REF CONST ec): v * u ** (HEAP CONST c; value OF c := value OF ec - 1; c) * udash) ESAC, (REF CALL ef): BEGIN REF FUNCTION f = function name OF ef, FORM g = parameter OF ef; REF VAR y = bound var OF f; HEAP FUNCTION fdash := (y, derivative of (body OF f, y)); (HEAP CALL := (fdash, g)) * derivative of (g, x) END ESAC # end derivative # ; PROC value of = (FORM e) REAL: CASE e IN (REF CONST ec): value OF ec, (REF VAR ev): value OF ev, (REF TRIPLE et): CASE REAL u = value of (left operand OF et), v = value of (right operand OF et); operator OF et IN u + v, u - v, u * v, u / v, exp (v * ln (u)) ESAC, (REF CALL ef): BEGIN REF FUNCTION f = function name OF ef; value OF bound var OF f := value of (parameter OF ef); value of (body OF f) END ESAC # value of # ; HEAP FORM f, g; HEAP VAR a := ("a", SKIP), b := ("b", SKIP), x := ("x", SKIP); # start here: read ((value OF a, value OF b, value OF x)); # value OF a := 1; value OF b := 1; value OF x := 1; f := a + x / (b + x); g := (f + one) / (f - one); print ((value OF a, #1# value OF b, #1# value OF x, #1# value of (derivative of (g, # with respect to # x)) #-2# )) ENDalgol68g-2.8/test-set/a68g.mc.076.mdeq01.a680000644000175000001440000000075712224301232014557 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #mdeq01# BEGIN # Mode equivalencing # MODE N = UNION(STRUCT(REAL re, im), COMPL); # Error, modes are the same # SKIP END algol68g-2.8/test-set/a68g.mc.105.numr09.a680000644000175000001440000001320212224301251014601 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr09# BEGIN #Test exp# #N.B. This test should not be considered as certification of 'exp', but only as an indication that 'exp' has the right properties# PROC warn = (STRING s) VOID: BEGIN print ((newline, "++++test error: ", s, newline, newline)) END; REAL minreal = 2 / (smallreal * maxreal * smallreal); # must be close to the smallest real value > 0 ; this will probably work on most machines with normalized reals # REAL e = exp (1); REAL y1, #exp(x)# y2, #exp(-x)# y3, #exp(1/x)# y4; #exp(-1/x)# REAL max1 := 0, sum1 := 0, sumsq1 := 0, INT c1 := 0, REAL at1; PROC test1 = (REAL x, y1, y2) VOID: # exp(x)*exp(-x)=1 # IF y1 = 0 THEN print ((newline, newline, "x=", x, newline, "exp(x)=0")) ELIF y2 = 0 THEN print ((newline, newline, "x=", -x, newline, "exp(x)=0")) ELIF REAL d = ABS (y1 * y2 - 1) / smallreal; sum1 +:= d; sumsq1 +:= d * d; c1 +:= 1; max1 < d THEN max1 := d; at1 := x FI; REAL max2 := 0, sum2 := 0, sumsq2 := 0, INT c2 := 0, REAL at2; PROC test2 = (REAL x, y) VOID: # exp(1+x)=e*exp(x) # IF y /= 0 AND y < maxreal / 3 THEN IF REAL z = exp (1 + x); z <= 0 THEN print ((newline, newline, "x=", 1 + x, newline, "exp(x)=", z)); warn ("exp(x)<=0") ELIF REAL d = ABS ((z - e * y) / z) / smallreal; sum2 +:= d; sumsq2 +:= d * d; c2 +:= 1; max2 < d THEN max2 := d; at2 := x FI FI; REAL max3 := 0, sum3 := 0, sumsq3 := 0, INT c3 := 0, REAL at3; PROC test3 = (REAL x, y) VOID: # sqrt(exp(2x))=exp(x) # IF y /= 0 AND y < sqrt (maxreal) AND y > sqrt (minreal) THEN IF REAL z = sqrt (exp (x + x)); z > 0 THEN REAL d = ABS ((z - y) / y) / smallreal; sum3 +:= d; sumsq3 +:= d * d; c3 +:= 1; (max3 < d | max3 := d; at3 := x) FI FI; PROC test4 = (REAL x, y) VOID: # check 0<=x<1, 1+x<= exp(x) <= 1/(1-x) # IF 0 <= x AND x < 1 THEN IF y < 1 + x THEN print ((newline, newline, "x=", x, newline, "exp(x)= ", y, newline, "1+x = ", 1 + x)); warn ("exp(x) should exceed 1+x") ELIF y > 1 / (1 - x) THEN print ((newline, newline, "x=", x, newline, "exp(x)= ", y, newline, "1/(1-x)=", 1 / (1 - x))); warn ("exp(x) should be less than 1/(1-x)") FI FI; REAL x := 1; WHILE x +:= random; REAL z = 1 / x; y1 := exp (x); y2 := exp (-x); y3 := exp (z); y4 := exp (-z); test1 (x, y1, y2); test1 (z, y3, y4); test2 (x, y1); test2 (-x, y2); test2 (z, y3); test2 (-z, y4); test3 (x, y1); test3 (-x, y2); test3 (z, y3); test3 (-z, y4); test4 (z, y3); y1 < maxreal / 3 AND y2 > 3 * minreal DO SKIP OD; PROC p = (STRING s, REAL sum, sumsq, n, max, at) VOID: BEGIN print ((newline, newline, s)); print ((newline, "Maximum relative error = smallreal*")); print (fixed (max, -(realwidth % 2 + 2), realwidth % 2)); print ((newline, "Occurred at x = ", at)); print ((newline, "Average relative error = smallreal*")); print (fixed (sum / n, -(realwidth % 2 + 2), realwidth % 2)); print ((newline, "R.M.S. relative error = smallreal*")); print (fixed (sqrt (sumsq / n), -(realwidth % 2 + 2), realwidth % 2)) END; p ("Checks on exp(x)*exp(-x)=1", sum1, sumsq1, c1, max1, at1); p ("Checks on exp(1+x)=exp(1)*exp(x)", sum2, sumsq2, c2, max2, at2); p ("Checks on sqrt(exp(2*x))=exp(x)", sum3, sumsq3, c3, max3, at3); print (newline); print ((newline, "e = 2.7182818284590452353602874713526624977572+ (Knuth)")); print ((newline, "exp(1) = ")); print (fixed (exp (1), -(real width + 1), real width - 1)); print ((newline, "e**-1 = 0.3678794411714423215955237701614608674458+ (Knuth)")); print ((newline, "exp(-1) = ")); print (fixed (exp (-1), -(real width + 1), real width - 1)); print ((newline, "e**2 = 7.3890560989306502272304274605750078131803+ (Knuth)")); print ((newline, "exp(2) = ")); print (fixed (exp (2), -(real width + 1), real width - 1)); print ((newline, "smallreal= ")); print (fixed (small real, -2 * real width, 2 * (realwidth - 1))); print ((newline, " = ", small real)) ENDalgol68g-2.8/test-set/a68g.mc.129.scop04.a680000644000175000001440000000207112224301256014574 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #scop04# # Routine scope error # BEGIN print (("Need not run", newline)); MODE FUN = PROC (INT) INT; MODE OPERATOR = PROC (FUN) FUN; OPERATOR nabla = (FUN t) FUN: (INT x) INT: t (x) - t (x - 1); OP UP = (OPERATOR a, INT b) OPERATOR: (FUN f) FUN: (b = 0 | f | a ((a UP (b - 1)) (f))); PRIO MIN = 1; OP MIN = (INT a, b) INT: (a <= b | a | b); FUN pol4 = (INT x) INT: x * (x + 1) * (x + 2) * (x + 3); FOR n FROM 0 TO 20 DO print (n); FOR k FROM 0 TO (n - 1) MIN 5 DO print ((nabla UP k) (pol4) (n)) OD; print (newline) OD ENDalgol68g-2.8/test-set/a68g.mc.038.coer10.a680000644000175000001440000000343112224301223014547 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer10# BEGIN # Union with VOID # OP TOPROCINT = (INT i) PROC INT: INT: 1; OP TOVOID = (INT i) VOID: 1; STRING proc int = "proc int", void = "void", before = "before ", after = " after"; print (("Results must be:", newline, void, newline, proc int, after, 1, newline, before, void, newline, before, void, newline, before, void, newline, proc int, 1, newline, void, newline, proc int, 1, newline, proc int, after, 1, newline, before, void, newline, newline, "Results are:", newline)); UNION (PROC INT, VOID) upiv := EMPTY; PROC pupiv = VOID: print ((upiv | (PROC INT pi): ((print (proc int); pi), newline) | (void, newline))); pupiv; upiv := INT: (print (after); 1); pupiv; upiv := VOID: (print (before); 1); pupiv; upiv := VOID ((print (before); 1)); pupiv; # firm void position # upiv := print (before); pupiv; upiv := TOPROCINT 1; pupiv; upiv := TOVOID 1; pupiv; upiv := INT: 1; upiv := label # must jump before assigning # ; print ("Error 1"); label: pupiv; FOR i TO 2 DO upiv := CASE i IN INT: (print (after); 1), VOID: (print (before); 1) ESAC; pupiv OD ENDalgol68g-2.8/test-set/a68g.mc.121.oper12.a680000644000175000001440000000121712224301255014564 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #oper12# BEGIN # Operator test, illegal operator # OP += = (INT a) INT : -a; OP +:= = (INT a) INT : -a; OP-/:= = (INT a) INT : -a; OP+==: = (INT a) INT : -a; # Correct version: # print(+=+:=-/:=+==:+==:+=+:=+==:1); # Bad version # print(+=+:=-/:=+==:+==+=+:=+==:=1) END algol68g-2.8/test-set/a68g.mc.126.scop01.a680000644000175000001440000000101012224301256014556 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #scop01# BEGIN # Scope error # print (("Need not run", newline)); PROC pp = (INT i) PROC INT: INT: i + 1 # error # ; print (pp (1)) ENDalgol68g-2.8/test-set/a68g.mc.041.coer14.a680000644000175000001440000000074212224301224014550 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #coer14# (# Rowing of NIL yields NIL # print (("print: ", TRUE, " ", REF [] INT (NIL) :=: REF INT (NIL), newline)))algol68g-2.8/test-set/a68g.mc.012.appl12.a680000644000175000001440000000253112224301217014550 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl12# BEGIN # AvW, 1974:10:23, packing small integers into a larger integer# PROC code = ([] INT sequence) INT: (INT code := 0; FOR k TO UPB sequence DO code *:= 2 +:= 1 *:= 2 ** sequence[k] OD; code), PROC length = (INT code) INT: (INT length := 0, c := code; WHILE c > 0 DO (ODD c | length +:= 1); c OVERAB 2 OD; length), PROC sequence = (INT code) [] INT: (INT l := length (code), c := code; [1 : l] INT sequence; FOR k TO l DO sequence[k] := 0 OD; WHILE c > 0 DO (ODD c | l -:= 1 | sequence[l] +:= 1); c OVERAB 2 OD; sequence); FOR c FROM 0 TO 100 DO print ((c, length (c), sequence (c), newline, code (sequence (c)), newline, newline)) OD ENDalgol68g-2.8/test-set/a68g.mc.149.simp15.a680000644000175000001440000000170512224301261014603 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp15# # uniqueness condition # ( (REAL x; x; INT x; x) # double x # , (REAL x; x: INT x; x) # triple x, label in decl # , (REAL x; INT x; REAL x; x) # triple x # , (REAL x; x: print(x)) # double x # , (x: x; x: x) # double x # , (MODE X = REAL, Y = X, X = REAL; LOC X) # X # , (PRIO X = 6; X 3) # no X # , (PRIO X = 6, = = 7, X = 7; 3) # double X #, (MODE X = Y; PRIO X = 1;3 ) # no Y, X wrong #, (INT a, a) INT: a # double a # ) algol68g-2.8/test-set/a68g.mc.137.simp02.a680000644000175000001440000000124412224301260014571 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp02# range_of_variables: BEGIN #Test that ranges are correct# print ((newline, "Values are 2,5,3,4", newline)); INT i, j; i := 3; j := 4; BEGIN INT i, k; i := 2; k := 5; print ((i, k)) END; print ((i, j)) ENDalgol68g-2.8/test-set/a68g.mc.026.clau07.a680000644000175000001440000000156412224301222014552 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #clau07# BEGIN # If-, case- and ucase-clauses # FOR i DO print (((i = 1 | 1 |: i = 2 | 2 |: i = 3 | 3 | eo if), newline)) OD; eo if: FOR i DO print (((i | 4, 5 |: i - 2 | 6, 7 | eo case), newline)) OD; eo case: FOR i DO print (((UNION (INT, REAL, CHAR, STRING, BOOL) (i | 1, 1.0, "a", "", TRUE) | (INT): 8, (REAL): 9 |: UNION (CHAR, STRING, BOOL) (i - 2 | "a", "", TRUE) | (CHAR): 10, (STRING): 11 | eo ucase), newline)) OD; eo ucase: SKIP ENDalgol68g-2.8/test-set/a68g.mc.106.numr10.a680000644000175000001440000001452312224301252014602 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr10# BEGIN #Test ln# #N.B. This test should not be considered as certification of 'ln', but only as an indication that 'ln' has the right properties# PROC warn = (STRING s) VOID: BEGIN print ((newline, newline, "++++test error: ", s, newline)) END; REAL minreal = 2 / (smallreal * maxreal * smallreal); # must be close to the smallest real value > 0 ; this will probably work on most machines with normalized reals # REAL e = exp (1); REAL y1, #exp(x)# y2, #exp(-x)# y3, #exp(1/x)# y4; #exp(-1/x)# REAL z1, #ln(y1)# z2, #ln(y2)# z3, #ln(y3)# z4; #ln(y4)# REAL max1 := 0, sum1 := 0, sumsq1 := 0, INT c1 := 0, REAL at1; PROC test1 = (REAL x, y, z) VOID: #ln(exp(x))=x# IF y > 0.0 THEN REAL d = ABS ((x - z) / x) / smallreal; sum1 +:= d; sumsq1 +:= d * d; c1 +:= 1; (max1 < d | max1 := d; at1 := x) FI; REAL max2 := 0, sum2 := 0, sumsq2 := 0, INT c2 := 0, REAL at2; PROC test2 = (REAL x, y) VOID: #ln(e*x)=1+ln(x)# IF x < maxreal / 3 THEN REAL z = ln (e * x); REAL z1 = y + 1; REAL d = ABS ((z - z1) / z) / smallreal; sum2 +:= d; sumsq2 +:= d * d; c2 +:= 1; (max2 < d | max2 := d; at2 := x) FI; REAL max3 := 0, sum3 := 0, sumsq3 := 0, INT c3 := 0, REAL at3; PROC test3 = (REAL x, y) VOID: #2*ln(sqrt(x))=ln(x)# IF REAL z = ln (sqrt (x)); REAL z1 = z + z; REAL d = ABS ((y - z1) / y) / smallreal; sum3 +:= d; sumsq3 +:= d * d; c3 +:= 1; max3 < d THEN max3 := d; at3 := x FI; REAL max4 := 0, sum4 := 0, sumsq4 := 0, INT c4 := 0, REAL at4; PROC test4 = (REAL x, y, z) VOID: #ln(1/x)=-ln(x)# IF REAL z1 = ABS y + ABS z; z1 /= 0 THEN REAL d = ABS (2 * (y + z) / z1) / smallreal; sum4 +:= d; sumsq4 +:= d * d; c4 +:= 1; (max4 < d | max4 := d; at4 := x) FI; PROC test5 = (REAL x, y) VOID: #x>0, 1-1/x <= ln(x) <= x-1# IF y < 1.0 - 1.0 / x THEN print ((newline, newline, "x=", x, newline, "ln(x) = ", y, newline, "1-1/x = ", 1 - 1 / x)); warn ("ln(x) should not be less than 1-1/x") ELIF y > x - 1 THEN print ((newline, newline, "x=", x, newline, "ln(x) = ", y, newline, "x-1 =", x - 1)); warn ("ln(x) should not exceed x-1") FI; REAL x := 1; WHILE x +:= random; REAL x2 = -x, x3 = 1 / x; REAL x4 = -x3; y1 := exp (x); y2 := exp (x2); y3 := exp (x3); y4 := exp (x4); z1 := ln (y1); z2 := ln (y2); z3 := ln (y3); z4 := ln (y4); test1 (x, y1, z1); test1 (x2, y2, z2); test1 (x3, y3, z3); test1 (x4, y4, z4); test2 (y1, z1); test2 (y2, z2); test2 (y3, z3); test2 (y4, z4); test3 (y1, z1); test3 (y2, z2); test3 (y3, z3); test3 (y4, z4); test4 (y1, z1, z2); test4 (y3, z3, z4); test5 (y1, z1); test5 (y2, z2); test5 (y3, z3); test5 (y4, z4); y1 < maxreal / 3 AND y2 > 3 * minreal DO SKIP OD; PROC p = (STRING s, REAL sum, sumsq, n, max, at) VOID: BEGIN print ((newline, newline, s)); print ((newline, "Maximum relative error = smallreal*")); print (fixed (max, -(realwidth % 2 + 2), realwidth % 2)); print ((newline, "Occurred at x = ", at)); print ((newline, "Average relative error = smallreal*")); print (fixed (sum / n, -(realwidth % 2 + 2), realwidth % 2)); print ((newline, "R.M.S. relative error = smallreal*")); print (fixed (sqrt (sumsq / n), -(realwidth % 2 + 2), realwidth % 2)) END; p ("Checks on ln(exp(x))=x", sum1, sumsq1, c1, max1, at1); p ("Checks on ln(e*x)=1+ln(x)", sum2, sumsq2, c2, max2, at2); p ("Checks on 2*ln(sqrt(x))=ln(x)", sum3, sumsq3, c3, max3, at3); p ("Checks on ln(1/x)=-ln(x)", sum4, sumsq4, c4, max4, at4); print (newline); print ((newline, "log 1 = 0")); print ((newline, "ln(1) = ")); print (fixed (ln (1), -(realwidth + 1), realwidth - 1)); print ((newline, "log 2 = 0.6931471805599453094172321214581765680755+ (Knuth)")); print ((newline, "ln(2) = ")); print (fixed (ln (2), -(realwidth + 1), realwidth - 1)); print ((newline, "log 3 = 1.0986122886681096913952452369225257046475- (Knuth)")); print ((newline, "ln(3) = ")); print (fixed (ln (3), -(realwidth + 1), realwidth - 1)); print ((newline, "log 10 = 2.3025850929940456840179914546843642076011+ (Knuth)")); print ((newline, "ln(10) = ")); print (fixed (ln (10), -(realwidth + 1), realwidth - 1)); print ((newline, "-loglog 2 = 0.3665129205816643270124391582326694694543- (Knuth)")); print ((newline, "-ln(ln(2))= ")); print (fixed (-ln (ln (2)), -(realwidth + 1), realwidth - 1)); print ((newline, "smallreal = ")); print (fixed (small real, -2 * realwidth, 2 * (realwidth - 1))); print ((newline, " = ", small real, newline)) ENDalgol68g-2.8/test-set/a68g.mc.142.simp07.a680000644000175000001440000000317512224301260014577 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #simp07# BEGIN # loops # INT i = 5; FOR i TO i DO print (i) OD; # 1, 2, 3, 4, 5 # print (newline); print (newline); INT s = 8; FOR a FROM s BY 1 WHILE INT b = a - s + 1; a <= 2 * s DO INT q := 0, r := a; WHILE r >= b DO (q +:= 1, r -:= b) OD; IF a /= b * q + r OR r >= b THEN print ("Error") FI; print ((a, b, q, r, newline)) OD; print (newline); # 8 1 8 0 9 2 4 1 10 3 3 1 11 4 2 3 12 5 2 2 13 6 2 1 14 7 2 0 15 8 1 7 16 9 1 7 # PROC power 2 = (INT k) INT: (INT m := 1; FOR i TO k DO m +:= power 2 (i - 1) OD; m); print (power 2 (6)) # 64 # ENDalgol68g-2.8/test-set/a68g.mc.017.appl17.a680000644000175000001440000000306012224301220014552 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl17# BEGIN # All-parser, Dick Grune, 20-11-74. The following is an example of a technique that will give a parser for any non-left-recursive context-free grammar. The parser gives all possible parsings. # MODE ACT = VOID, TAIL = PROC ACT, RULE = PROC (TAIL) ACT; # R u l e G r a m m a r # RULE t = (TAIL q) ACT: s (ACT: b (q)); # t: s, b. # RULE s = (TAIL q) ACT: # s: # (a (ACT: s (ACT: s (q))); # a, s, s; # a (q) # a. # ); RULE a = (TAIL q) ACT: (n +:= 1; IF inp[n] = "a" THEN q FI; # a: "a". # n -:= 1); RULE b = (TAIL q) ACT: (n +:= 1; IF inp[n] = "b" THEN q FI; # b: "b". # n -:= 1); STRING inp, INT n := 0; INT max = 10; FOR i FROM 0 TO max DO inp := i * "a" + "b"; INT count := 0; t (ACT: count +:= 1); print (("The sentence """, inp, """ has", count, " parsings", newline)) OD ENDalgol68g-2.8/test-set/a68g.mc.019.appl19.a680000644000175000001440000016615112224301221014572 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #appl19# # +prpl>lftc "input" "tables" "forward" a: "x", "d"; b, "c"; "e", "x", "c"; "e", b, "d"; "u", c. b: "x". c: c. d: c. a: a. . # # The above is input for this program # BEGIN # For timing information see routine 'time', near line 100 # STRING progname = "Parser Generator for ALGOL 68 H -- Version 2.0.0"; # This is an intermediate version of a program being written by Hendrik Boom. It should not be considered to be a finished product; however, this present version appears to work. # # <><><><> Things to do: Find out whether it is worth doing SLR1 when we have LALR. Modify table production to handle LALR. Should 'check look ahead' save LALR lookaheads. Selectively avoid creating bit tables. # # Temporary measures # # PR page PR # # PR page PR # INT left margin := 1, INT place := 0; INT right margin = 130; [1 : right margin] CHAR print line; PROC indent = VOID : left margin +:= 3; PROC dedent = VOID : IF left margin > 3 THEN left margin -:= 3 FI; PROC end line = VOID: BEGIN print((print line[1 : place], newline)); place := ( left margin > right margin % 2 | right margin % 2 | left margin ) - 1; FOR i FROM 1 TO place DO print line[i] := " " OD END, PROC my end line = VOID: BEGIN left margin +:= 6; end line; left margin -:= 6 END; OP -< = (CHAR c) VOID : BEGIN IF place >= right margin THEN end line FI; print line[place +:= 1] := c END # of 'print' characters # ; OP -< = (REF STRING s) VOID : IF IF place >= right margin THEN my end line FI; INT ub = UPB s; INT np = place + ub; np <= right margin THEN # normal case # print line[place+1 : np] := s; place := np ELSE INT break = right margin - place; -< s[1:break]; my end line; -< s[break+1 : ] FI # end of 'print' for string variables #; OP +< = (STRING s) VOID : IF IF place >= right margin THEN my end line FI; INT ub = UPB s; INT np = place + ub; np <= right margin THEN # normal case # print line[place+1 : np] := s; place := np ELSE LOC FLEX [1 : ub] CHAR t; t := s; -< t FI; OP -< = (INT i) VOID : +< whole(i, 0), OP -< = (BOOL b) VOID: (b | +< "true" | +< "false"); PROC time = (STRING s) VOID: # if applicable # ( COMMENT No enquiries --- dedent; end line; indent; +< s; +< " after "; +< fixed(clock, 0, 6); +< " seconds"; end line; IF g opt THEN collect garbage FI; -< available; +< "words of storage are available after "; -< collections; +< " garbage collections "; +< "which have collected a total of " ; -< garbage; +< " words of garbage and have cost "; +< fixed(collect seconds, 0, 6); +< " seconds of CPU time. "; end line; --- end of COMMENT SKIP ); BOOL g opt := FALSE; # SLR(1) parser generator # # PR page PR # PROC generate parser = (REF FILE input, output, BOOL pr opt, pl opt, ple opt, f opt, s opt, t opt, c opt, ll1 opt) BOOL: # pr opt: print r matrix. pl opt: print l matrix. gt opt: print l nonempty matrix. f: print f matrix. s opt: try SLR(1) processing first. t opt: trace building of FSM. c opt: trace configurations of states. ll1 opt: perform ll1 check. # BEGIN # Global changes desired: Replace "CONFLIST" everywhere by "PROMLIST" # # Other possible changes: The lookaheads are not needed to compute the a matrix and the margins, with a few exceptions: production transitions are not placed in a, but only in the margins. The 'm' matrix and entire FSM list structure can then be discarded, except for representative back transitions for error messages, releasing storage for the bit matrix computations. The net effect would be to reduce the main storage required. # +< progname; end line; time("Started"); +< "Options:"; indent; end line; +< "pr opt "; -< pr opt; end line; +< "pl opt "; -< pl opt; end line; +< "ple opt "; -< ple opt; end line; +< "LL1 opt "; -< ll1 opt; end line; +< "f opt "; -< f opt; end line; +< "s opt "; -< s opt; end line; +< "t opt "; -< t opt; end line; +< "c opt "; -< c opt; end line; +< "g opt "; -< g opt; end line; dedent; end line; #Modes# # PR page PR # MODE STATE = STRUCT( REF TRANSITIONLIST out # all transitions leading out of this state #, REF TRANSITIONLIST in # all transitions leading into this state; repeatedly following the first 'in' transition of the 'in' transitionlist of each state will eventually lead to the start state #, REF CONFLIST conf # the configurations of this state #, BOOL is adequate # initially TRUE. 'is adequate' is assigned FALSE only when the state is judged adequate; i.e., all its lookahead is resolved. #, REF STATE next # in same hash bucket #, link # 'link' links new states together until they are fully processed #, INT number), TRANSITIONLIST = STRUCT( REF TRANSITION this, REF TRANSITIONLIST next), TRANSITION = STRUCT( REF STATE from, MARKER symbol, REF STATE to # production transitions lead nowhere; therefore their 'to' fields are NIL #, INT number, INT scan # used to prevent endless recursion in 'lalr look ahead' # ), PRODUCTION = STRUCT( SYMBOL left, PROMOTION right, INT number, BOOL useful), PRODUCTIONLIST = STRUCT( PRODUCTION this, REF PRODUCTIONLIST next), PROD = PRODUCTION, SYMBOL = REF SYM, SYM = STRUCT( STRING name, INT number, BOOL isterminal, REF CONFLIST attachment, REF STATE states # states are hashed according to access symbol; STATES points to the hash bucket #, BOOL useful, productive, empty, REF PRODUCTIONLIST definitions), SYMBOLLIST = STRUCT( SYMBOL this, REF SYMBOLLIST next), CONFIGURATION = STRUCT( SYMBOL sym, PROMOTION promote), CONF = CONFIGURATION, CONFLIST = STRUCT( PROMOTION this, REF CONFLIST next), PROMOTION = UNION(REF CONF, REF PROD), MARKER = UNION(SYMBOL, REF PROD), GRAMMAR = STRUCT( REF [] REF PRODUCTION productions, REF PRODUCTION start production, REF [] SYMBOL symbols, terminals, nonterminals, SYMBOL start, end of file ), # PR page PR # PRIO ORAB = 1, ANDAB = 1, MIN = 1, MAX = 1; OP ORAB = (REF BOOL a, BOOL b)REF BOOL : a:= a OR b, ANDAB = (REF BOOL a, BOOL b) REF BOOL: a:= a AND b, ORAB = (REF BITS a, BITS b)REF BITS : a:= a OR b, ANDAB = (REF BITS a, BITS b)REF BITS : a:= a AND b, MIN = (INT a,b)INT: (a > b| b| a), MAX = (INT a,b)INT : (a > b| a| b); OP = = (UNION(MARKER, PROMOTION) a, b) BOOL : NOT (a /= b), /= = (UNION(MARKER, PROMOTION) a, b) BOOL : CASE a IN (SYMBOL a): ( b | (SYMBOL b) : a :/=: b | TRUE ), (REF PROD a): ( b | (REF PROD b): a :/=: b | TRUE ), (REF CONF a): ( b | (REF CONF b): a :/=: b | TRUE ) OUT error("invalid parameter to /= - Parser generator error"); GOTO stop ESAC; OP /= =(REF CONFLIST c,d) BOOL: NOT (c = d), = =(REF CONFLIST c,d) BOOL: c <= d AND d <= c, <= = (REF CONFLIST c,d) BOOL: BEGIN REF CONFLIST l,m; l:= c; WHILE IF l :/=: REF CONFLIST (NIL) THEN # test that 'this' OF 'l' is in 'd'. # m := d; WHILE IF m :/=: REF CONFLIST (NIL) THEN this OF l /= this OF m ELSE FALSE FI DO m:= next OF m OD; # assert 'm' :=: NIL iff this OF 'l' is not in d # m :/=: REF CONFLIST (NIL) ELSE FALSE FI DO l:= next OF l OD; # assert l :=: NIL iff c is contained in d # l :=: REF CONFLIST ( NIL ) END # of <= #; OP SIZE = (REF CONFLIST c) INT : BEGIN INT i := 0; LOC REF CONFLIST d := c; WHILE d :/=: REF CONFLIST(NIL) DO d := next OF d; i +:= 1 OD; i END # of 'size' #; PROC for right side = ( REF PRODUCTION p, PROC(REF SYMBOL)VOID x ) VOID: BEGIN PROMOTION prom := right OF p; WHILE CASE prom IN (REF PROD p) : FALSE, (REF CONF c): (x(sym OF c); prom := promote OF c; TRUE) ESAC DO SKIP OD END # of 'for right side' #; # Output # # PR page PR # MODE PRINTABLE = UNION( CHAR, STRING, INT, REF SYM, PROC(REF FILE) VOID, REF PROD, REF PRODUCTIONLIST, REF CONF, REF [] REF PROD, REF SYMBOLLIST, REF TRANSITIONLIST, REF STATE, REF TRANSITION, GRAMMAR); PROC error = ([]PRINTABLE message) VOID : BEGIN end line; +< "Error detected: "; show(message); end line END #error#; PROC sys error = ([]PRINTABLE message) VOID : BEGIN end line; +< "System error detected: "; show(message); end line END # of 'sys error' #; PROC([]PRINTABLE) VOID sys err = sys error; PROC show = ([] PRINTABLE x) VOID: FOR i FROM LWB x TO UPB x DO CASE x[i] IN (PROC (REF FILE) VOID x) : (end line; x(stand out)), (CHAR c): -< c, (STRING s): +< s, (INT i): -< i, (REF SYM s): -< i, (REF SYMBOLLIST s): -< s, (REF PRODUCTION p): -< p, (REF PRODUCTIONLIST p): -< p, (REF [ ] REF PROD p): -< p, (REF CONFIGURATION c): -< c, (REF STATE s): -< s, (REF TRANSITION t): -< t, (REF TRANSITIONLIST t): -< t, (GRAMMAR g): -< g OUT +< "Unprintable stuff" ESAC OD # end of 'show' #; OP -< = (REF SYM s) VOID : IF s :/=: REF SYM(NIL) THEN -< name OF s ELSE +< "*ref sym nil*" FI, OP -< = (REF SYMBOLLIST s) VOID : IF s :=: REF SYMBOLLIST(NIL) THEN SKIP ELSE -< this OF s; +< ", "; -< next OF s FI, OP -< = (REF PRODUCTIONLIST p) VOID: (p :=: NIL | SKIP | -< this OF p; -< next OF p), OP -< = (REF [ ] REF PROD p) VOID: IF p :=: REF [] REF PROD(NIL) THEN SKIP ELSE FOR i FROM LWB p TO UPB p DO -< p[i]; end line OD FI, OP -< = (PROMOTION prom) VOID: CASE prom IN (REF CONFIGURATION c): IF c :=: REF CONFIGURATION(NIL) THEN +< "* ref conf nil *" ELSE PROMOTION p := c; PRODUCTION pr; WHILE CASE p IN (REF CONF c): (p := promote OF c; TRUE), (REF PROD p): (pr := p; FALSE) ESAC DO SKIP OD ; show configuration(pr, c) FI, (REF PRODUCTION p): show configuration(p, REF PROD(NIL)) OUT syserr("+< promotion fails") ESAC, OP -< = (REF CONFLIST c) VOID: IF c :=: REF CONFLIST(NIL) THEN +< "* ref conflist nil *" ELSE REF CONFLIST l := c; WHILE l :/=: REF CONFLIST(NIL) DO -< this OF l; end line; l := next OF l OD FI, OP -< = (REF STATE s) VOID: (+< "state number ", -< number OF s), OP -< = (REF TRANSITION t) VOID : ( +< "transition from "; -< from OF t; +< " to "; IF to OF t :=: REF STATE(NIL) THEN +< "nowhere" ELSE -< to OF t FI; +< " under "; CASE symbol OF t IN (SYMBOL s): -< s, (REF PROD p): -< p OUT +< "????" ESAC ), OP -< = (REF TRANSITIONLIST t) VOID: IF t :/=: REF TRANSITIONLIST(NIL) THEN -< this OF t; +< ", "; -< next OF t FI, OP -< = (GRAMMAR g) VOID: BEGIN print(newpage); -< productions OF g END, PROC show configuration = (REF PROD p, PROMOTION c) VOID: BEGIN -< number OF p; +< ": "; -< left OF p; CHAR sep := ":"; PROMOTION pro := right OF p; WHILE IF c = pro THEN +< " ..." FI; CASE pro IN (REF PROD): FALSE, (REF CONF c): ( -< sep; -< " "; -< sym OF c; pro := promote OF c; TRUE) ESAC DO sep := "," OD; IF sep = ":" THEN +< ": " FI; +< ". " END # of 'show configuration' #; OP +< = (REF STATE s) VOID : IF s:/=: NIL THEN IF in OF s :/=: REF TRANSITIONLIST (NIL) THEN REF TRANSITION t = this OF in OF s; IF t :/=: REF TRANSITION(NIL) THEN +< from OF t; CASE symbol OF t IN (SYMBOL s): ( -< " "; -< name OF s) OUT syserr(("nonsymbol on transition ", t)) ESAC FI FI FI; #Reading grammars # # PR page PR # # Grammars are read in according to the following grammar: grammar: direction, productions, ".". productions: production, "."; productions, ".", production. direction: empty, """forward""", """backward""". production: non-terminal, ":", right sides. right side: empty; symbol; symbol, ",", right side. right sides: right side; right side; ";"; right sides. symbol: terminal; nonterminal. nonterminal: TAG. terminal: strict terminal; pseudo terminal. x:: strict; pseudo. x terminal: x mark, x images, x mark. x images: CHARACTER; x mark, xmark; character, x images; x mark, x mark, x images. strict mark: """". pseudo mark: "''". # PROC read grammar = (REF GRAMMAR g)BOOL: BEGIN BOOL input line ended := FALSE; CHAR input state := " "; PROC char in string= (CHAR c, STRING s)BOOL: BEGIN BOOL val:= FALSE; FOR i FROM LWB s TO UPB s WHILE NOT ( val := c = s[i]) DO SKIP OD; val END # char in string#; PROC is letter = (CHAR c)BOOL: c = "<" OR c = ">" OR (c >= "a")AND (c <= "z"), is letdig = (CHAR c)BOOL: c = "<" OR c = ">" OR c >= "a" AND c <= "z" OR c >= "0" AND c <= "9"; CHAR char:= " "; STRING line := "", INT linept := 1; PROC next ch = BOOL: BEGIN input line ended := FALSE; WHILE linept > UPB line DO get(input, (newline, line)); print((input state, " ", line, newline)); linept := 1; input line ended := TRUE OD; char := line[linept]; linept +:= 1; TRUE END; PROC skip comments = VOID: WHILE char = "#" OR char = "[" OR char = "+" DO IF char = "[" THEN input state := "]"; WHILE nextch; char /= "]" DO SKIP OD; input state := " "; nextch ELSE CHAR ch = char; WHILE nextch; IF char = ch THEN nextch; FALSE ELIF input line ended THEN error(("unfinished comment")); FALSE ELSE TRUE FI DO SKIP OD FI OD # end of 'skip comments' # ; PROC next char = BOOL: BEGIN next ch; skip comments; TRUE END # of next char #; PROC coast = VOID: IF char = " " THEN WHILE next char; char = " " DO SKIP OD FI; PROC verslind= (STRING stop)VOID: BEGIN input state := "-"; WHILE NOT char in string(char, stop) DO next char OD; input state := " " END; PROC look up terminal = (STRING name) SYMBOL: look up symbol (terminals, name, nmb terminals), PROC look up nonterminal= (STRING name) SYMBOL: look up symbol(nonterminals, name, nmb nonterminals), PROC look up symbol= (REF REF SYMBOLLIST table, STRING name, REF INT counter) SYMBOL : BEGIN REF SYMBOLLIST t := table; WHILE IF t :/=: REF SYMBOLLIST(NIL) THEN name OF this OF t /= name ELSE FALSE FI DO t:= next OF t OD; IF t :=: REF SYMBOLLIST(NIL) THEN t := table := HEAP SYMBOLLIST := (HEAP SYM := (name, counter +:= 1, SKIP, NIL, NIL, FALSE, FALSE, FALSE, NIL ), table ) FI; this OF t END; PROC read nonterminal = (REF STRING n) BOOL: IF coast; isletter(char) THEN WHILE isletdig(char) DO n +:= char; next char; IF char = " " THEN coast; IF isletdig(char) THEN n +:= " " FI FI OD; TRUE ELIF char = "/" THEN n +:= "/"; nextchar; IF read terminal(n) THEN TRUE ELSE read nonterminal(n) FI ELSE FALSE FI # end of read nonterminal #; PROC in nonterminal=(REF SYMBOL s) BOOL: IF STRING n := ""; read nonterminal(n) THEN s := look up nonterminal(n); IF (n[1] = "/" OR n[1] = "<" OR n[1] = ">") AND NOT empty OF s THEN productionlist := HEAP PRODUCTIONLIST := ((s, SKIP, nmb prod +:= 1, FALSE), productionlist); right OF this OF productionlist := this OF productionlist; empty OF s := TRUE FI; TRUE ELSE FALSE FI # end of 'in nonterminal' # ; PROC read terminal = (REF STRING n) BOOL: IF coast; char = "''" OR char = """" THEN CHAR x = char; n +:= x; input state := char; WHILE next ch; IF char = x THEN n +:= x; next ch; char = x ELIF input line ended THEN error(("unfinished terminal ", n)); FALSE ELSE TRUE FI DO n +:= char OD; input state := " "; skip comments; TRUE ELSE FALSE FI # end of 'read terminal' # ; PROC in terminal = (REF SYMBOL s) BOOL: IF STRING n := ""; read terminal(n) THEN IF UPB n > 2 THEN s:= look up terminal(n); TRUE ELSE error("empty terminal"); FALSE FI ELSE FALSE FI # end of in terminal#; PROC in symbol = (REF SYMBOL s) BOOL: (in nonterminal(s) | TRUE| in terminal(s)); PROC in right tail = ( REF PROMOTION c, REF PRODUCTION p) BOOL: IF SYMBOL s; in symbol(s) THEN IF forward THEN c := HEAP CONFIGURATION := ( s, IF coast; char="," THEN IF PROMOTION c; next char; in right tail(c,p) THEN c ELSE p FI ELIF char = "." OR char = ";" THEN p # empty alternative # ELSE error( ""","", ""."", or "";"" expected but not found"); p FI ); TRUE ELSE c := HEAP CONFIGURATION := (s, p); WHILE coast; char = "," DO IF next char; in symbol(s) THEN c := HEAP CONFIGURATION := (s, c) ELSE error("missing or invalid symbol"); verslind(",;:.") FI OD; TRUE FI ELSE c := p; TRUE FI # end of in right tail#; PROC in right side = (REF PROD p) BOOL: # yes, only one REF here # IF HEAP PROMOTION c; in right tail (c, p) THEN right OF p := c; TRUE ELSE FALSE FI; PROC in production = (REF REF PRODUCTIONLIST l) BOOL: IF SYMBOL left; in nonterminal(left) THEN IF coast; char=":" THEN WHILE char = ":" OR char = ";" DO next char; l := HEAP PRODUCTIONLIST := ((left, SKIP, nmb prod +:= 1, FALSE), l); IF in right side(this OF l) THEN coast ELSE error("invalid right side.") FI OD; IF char /= "." THEN error("invalid right side terminator"); verslind("."); FALSE ELSE TRUE FI ELSE error("no "":"""); verslind(":"); FALSE FI ELSE error("no nonterminal on left"); FALSE FI # end of in production #; PROC in grammar= BOOL: BEGIN (STRING s; get(input, s)); STRING direction := ""; forward := IF NOT read terminal(direction) THEN TRUE ELIF direction = """forward""" THEN TRUE ELIF direction = """backward""" THEN FALSE ELSE error(("invalid direction", direction, ". ""forward"" is assumed. ")); TRUE FI; WHILE coast; char /= "." DO IF in production (production list) THEN IF program symbol :=: SYMBOL(NIL) THEN program symbol:= left OF this OF production list FI ELSE error("invalid production"); verslind(".") FI; next char OD; TRUE END # of in grammar # ; # PR page PR # BOOL forward := TRUE; INT nmb prod:= 0, nmb terminals:= 0, nmb nonterminals:= 0; REF PRODUCTIONLIST productionlist := NIL; REF SYMBOLLIST terminals := NIL, nonterminals := NIL; SYMBOL program symbol := NIL; SYMBOL start symbol = look up nonterminal ("* start *"), end of file = look up terminal ( "* end of file *" ); in grammar; production list := HEAP PRODUCTIONLIST := (SKIP, production list); REF PRODUCTION start production = this OF production list; start production := (start symbol, HEAP CONFIGURATION:= ( IF program symbol :=: SYMBOL(NIL) THEN error("grammar has no productions"); start symbol ELSE program symbol FI, HEAP CONFIGURATION:= ( end of file, start production ) ), nmb prod +:= 1, FALSE ); HEAP [ 1 : nmb prod] REF PRODUCTION productions; HEAP [1: nmb terminals + nmb nonterminals] SYMBOL symbols; WHILE production list :/=: REF PRODUCTIONLIST ( NIL ) DO REF PRODUCTIONLIST here = production list; production list := next OF here; productions[number OF this OF here] := this OF here; next OF here := definitions OF left OF this OF here; definitions OF left OF this OF here := here OD; WHILE terminals :/=: REF SYMBOLLIST(NIL) DO symbols[number OF this OF terminals] := this OF terminals; is terminal OF this OF terminals:= TRUE; terminals:= next OF terminals OD; WHILE nonterminals :/=: REF SYMBOLLIST (NIL) DO symbols[number OF this OF nonterminals +:= nmb terminals] := this OF nonterminals; is terminal OF this OF nonterminals := FALSE; nonterminals:= next OF nonterminals OD; g := (productions, start production, symbols, symbols[1:nmb terminals], symbols[nmb terminals +1: nmb terminals + nmb nonterminals @ nmb terminals + 1], start symbol, end of file); TRUE END # of read grammar#; # PR page PR # GRAMMAR g; time("Read grammar"); IF read grammar(g) THEN time("Grammar read"); PROC extract production data = VOID: BEGIN INT l; PROMOTION p; FOR i FROM 1 TO nmb productions DO target[i] := number OF left OF production[i]; production length[i] := (l := 0; p := right OF production [i]; FOR i FROM 0 WHILE CASE p IN (REF PROD) : (l := i; FALSE), (REF CONF c) : (p := promote OF c; TRUE) ESAC DO SKIP OD; l ) OD END # of extract production data #; PROC find empty and useless nonterminals = VOID : BEGIN FOR i TO UPB symbol DO empty OF symbol[i] := FALSE; productive OF symbol[i] := FALSE; useful OF symbol[i] := FALSE OD; FOR i FROM LWB terminal TO UPB terminal DO productive OF symbol[i] := TRUE OD; WHILE BEGIN BOOL change := FALSE; PRIO NEWT= 1; OP NEWT=(REF BOOL d,BOOL s) VOID: ( NOT d AND s | d := TRUE; change := TRUE ); FOR pn FROM 1 TO UPB production DO REF PRODUCTION p= production [pn]; PROMOTION r := right OF p; BOOL emptyright:= TRUE, productive right:= TRUE; WHILE CASE r IN (REF CONFIGURATION c): BEGIN emptyright ANDAB empty OF sym OF c; productiveright ANDAB productive OF sym OF c; r := promote OF c; TRUE END OUT FALSE ESAC DO SKIP OD; SYMBOL left = left OF p; empty OF left NEWT empty right; productive OF left NEWT productiveright; IF productive right AND ( useful OF left OR ( left :=: start symbol) ) AND # for efficiency only# NOT useful OF p THEN useful OF p:= TRUE; useful OF left := TRUE; r:= right OF p; WHILE CASE r IN (REF CONFIGURATION c): BEGIN useful OF sym OF c NEWT TRUE; r := promote OF c; TRUE END OUT FALSE ESAC DO SKIP OD FI OD; change END DO SKIP OD END # of find empty...#; PROC print symbols= VOID: BEGIN PROC s = (SYMBOL s) VOID : BEGIN end line; IF useful OF s THEN +< " " ELSE +< ">>>>>" FI; -< " "; IF empty OF s THEN +< "empty" ELSE +< " " FI; -< " "; IF NOT productive OF s THEN +< "not productive" ELSE +< " " FI; IF NOT useful OF s THEN +< " not useful " ELSE +< " " FI; -< name OF s END; end line; print(newpage); +< "Terminals"; FOR i FROM LWB terminal TO UPB terminal DO s( terminal[i] ) OD; end line; +< "Nonterminals"; FOR i FROM LWB nonterminal TO UPB nonterminal DO s(nonterminal[i]) OD; end line END # of 'print symbols' #; # Bit matrices # # PR page PR # PROC bit = (REF [,]BITS m, INT i, j) BOOL : BEGIN INT iw = i OVER bits width, ib = i MOD bits width; (ib + 1) ELEM m[iw, j] END # of bit #; PROC setbit = (REF [,] BITS m, INT i, j) VOID: BEGIN INT iw = i OVER bits width, ib = i MOD bits width; REF BITS e = m[iw, j]; e := e OR 2 r 1 SHL (bits width - ib - 1) END # of set bit # ; PROC print bit matrix = (REF [,] BITS a, INT l1, u1, l2, u2, CHAR mark) VOID: BEGIN time("Print bit matrix"); FOR p FROM l1 BY 50 TO u1 DO INT q = u1 MIN p + 49; FOR r FROM l2 BY 50 TO u2 DO INT s = u2 MIN r + 49; end line; print(newpage); # Heading of 8 characters per symbol # FOR z FROM 1 TO 8 DO FOR u FROM r TO s DO IF UPB name OF (symbol[u]) < z THEN -< " " ELSE -< (name OF (symbol[u])) [z] FI OD; end line OD # end of heading #; FOR t FROM p TO q DO STRING background = ( t MOD 5 = 0 | "-+" | " !" ) [AT 0]; FOR u FROM r TO s DO IF bit(a, t, u) THEN -< mark ELSE -< background[ABS(u MOD 5 = 0)] FI OD; -< t; -< " "; -< name OF symbol[t]; end line OD OD OD END # of print matrix #; # Create bit arrays # # PR page PR # PROC create bit arrays = (REF REF [,] BITS rpl) VOID : BEGIN [lownt32 : highnt32, 1 : nsymbols] BITS pr, HEAP [lownt32 : highnt32, 1 : nsymbols] BITS pl, [ 0 : nsymbols 32, 1 : nsymbols ] BITS adj, temp; # Compute 'pl', 'pr', and 'adj' # FOR i FROM 1 LWB pr TO 1 UPB pr DO FOR j FROM 2 LWB pr TO 2 UPB pr DO pr[i, j] := pl[i, j] := plnonempty[i, j] := 2 r 0 OD OD; FOR i FROM 1 LWB adj TO 1 UPB adj DO FOR j FROM 2 LWB adj TO 2 UPB adj DO adj[i, j] := temp[i, j] := f[i, j] := 2 r 0 OD OD; FOR pi TO UPB production DO REF PROD p = production[pi]; IF NOT useful OF p THEN error(("production ", p, " is not useful. ")) ELSE SYMBOL l= left OF p; PROMOTION r= right OF p; CASE r IN (REF PROD): SKIP, (REF CONF r): setbit(plnonempty, number OF l, number OF sym OF r) ESAC; PROMOTION tail:= r, prev := p; WHILE BEGIN PROMOTION tailtail := tail; WHILE CASE tailtail IN (REF PROD tt): (CASE prev IN (REF PROD prev): SKIP, (REF CONF prev): setbit(pr, number OF l, number OF sym OF prev) ESAC; FALSE ), (REF CONF tt): (CASE prev IN (REF PROD prev): setbit(pl, number OF l, number OF sym OF tt), (REF CONF prev): setbit(adj, number OF sym OF prev, number OF sym OF tt) ESAC; tailtail := promote OF tt; empty OF sym OF tt ) ESAC DO SKIP OD; prev := tail; CASE tail IN (REF PROD): FALSE, (REF CONF t): BEGIN tail:= promote OF t; TRUE END ESAC END DO SKIP OD FI OD; COMMENT The following lines have been commented out. They may nonetheless be useful for debugging changes later. print bit matrix(pr, lownt, highnt, 1, nsymbols, "q"); print bit matrix(pl, lownt, highnt, 1, nsymbols, "k"); print bit matrix(pl nonempty, lownt, highnt, 1, nsymbols, ">"); print bit matrix(adj, 1, nsymbols, 1, nsymbols, "="); COMMENT time("Compute closures"); # At this point, pl[i, j] iff i => xxxj... and xxx =>* empty pr[i, j] iff i => ...jxxx and xxx =>* empty adj[i,j] iff x => ...ixxxj... and xxx =>* empty, plnonempty[i, j] iff i => j... Now compute the symmetric transitive closures of pl,pr, and plnonempty; # # Bit matrices: transitive closures # # PR page PR # PROC close= (REF [,] BITS m) VOID: # replace m by its transitive closure # FOR j FROM lownt TO highnt DO FOR k FROM 1 TO nsymbols DO IF bit (m,j,k) THEN FOR i FROM lownt 32 TO highnt 32 DO m[i,k] ORAB m[i,j] OD FI OD OD; close (pl); IF s opt OR pr opt THEN close(pr) FI; # otherwise, 'pr' is not needed. # close (plnonempty); FOR i FROM lownt TO highnt DO setbit (pr,i,i); setbit (pl,i,i); setbit (plnonempty,i,i) OD; # At this point, pl[i, j] iff i =>* j... pr[i, j] iff i =>* ...j adj[i,j] iff x => ...ixxxj... and xxx =>* empty, plnonempty[i, j] iff i => j... using no empty productions # # Bit matrices: the follows matrix # # PR page PR # IF s opt OR f opt THEN time("Compute ''f''"); PRIO /* = 7; OP /* = (REF [,] BITS a, b) REF [,] BITS : # a transpose times b. 'b' contains only one part of the 'b' that is to be multiplied. It diagonal is extended with ones, thus: 10000000 <- 1 01000000 00100000 bbbbbbbb <- lownt bbbbbbbb bbbbbbbb bbbbbbbb bbbbbbbb <- nsymbols = highnt let 'u' be the [,]BOOL which is packed as [,]BITS in 't'. 'at' is the transpose of 'a' . then: u[i, j] = OR[k] at[i, k] AND b[k, j] = OR[k] (a[k, i] AND IF k < lownt THEN k = j ELSE b[k, j] FI ) = ( OR[k < lownt] a[k, i] AND (k = j) ) OR ( OR[k >= lownt] (a[k, i] AND b[k, j] ) ) = IF j < lownt THEN a[j, i] ELSE FALSE FI OR OR[k >= lownt] (a[k, i] AND b[k, j]) # BEGIN HEAP [0 : n symbols 32, 1 : n symbols] BITS t; BITS l; FOR i FROM 1 LWB t TO 1 UPB t DO FOR j FROM 2 LWB t TO 2 UPB t DO t[i, j] := 2 r 0 OD OD; FOR i FROM 1 TO nsymbols DO FOR j FROM 1 TO n symbols DO IF IF (j < lownt | bit(a, j, i) | FALSE ) THEN TRUE ELSE l := 2 r 0; FOR k FROM lownt 32 TO high nt 32 DO l ORAB (a[k, i] AND b[k, j]) OD; l /= 2 r 0 FI THEN setbit(t, i, j) FI OD OD; t END; f := (adj /* pr) /* pl # pr t * a * pl = (a t * pr) t * pl notice that the diagonals of 'pr' and 'pl' must be extended with ones. # FI # end of 'f' processing #; IF pr opt THEN print bit matrix(pr, low nt, high nt, 1, n symbols, "r") FI; IF pl opt THEN print bit matrix(pl, low nt, high nt, 1, nsymbols, "l") FI; IF ple opt OR TRUE THEN print bit matrix(pl nonempty, low nt, high nt, 1, n symbols, ">") FI; IF f opt THEN print bit matrix(f, 1, n symbols, 1, n symbols, "f") FI; rpl := pl END # create bit matrices #; PROC destroy bit matrices = VOID : BEGIN f := NIL; plnonempty := NIL # ; collect garbage # END # of destroy bit matrices# ; # PR page PR # # Elementary operations on states, configurations, and transitions # PROC makestate= (REF CONFLIST c, SYMBOL access) REF STATE: BEGIN # hashing on access # REF STATE thesestates := IF access :=: NIL THEN NIL # only the start state may have no access # ELSE states OF access FI; # search for an equivalent state# REF STATE s:= these states; WHILE IF s :/=: REF STATE (NIL) THEN conf OF s /= c ELSE FALSE FI DO s:= next OF s OD; IF s:=: REF STATE (NIL) THEN # new state # s := newstates := thesestates := HEAP STATE := (NIL, NIL, c, FALSE, these states, new states, nmb states +:= 1); IF t opt THEN +< "new "; -< s; end line FI; IF c opt THEN indent; -< s; end line; -< conf OF s; dedent; end line FI FI; IF access :=: SYMBOL(NIL) THEN startstate:= thesestates ELSE states OF access := thesestates FI; s END # of makestate # ; #attach# PROC attach= (PROMOTION c, SYMBOL s) VOID: # Attach the promotion 'p' to the symbol 's', unless it is there already. # BEGIN REF CONFLIST cl:= attachment OF s; WHILE IF cl :/=: REF CONFLIST( NIL ) THEN this OF cl /= c ELSE FALSE FI DO cl:= next OF cl OD; IF REF CONFLIST (cl) :=: NIL THEN attachment OF s:= HEAP CONFLIST:= (c,attachment OF s) FI END#attach#; PROC maketransition= (REF STATE from, MARKER s, REF STATE to )VOID: # Make a transition from one state to another, unless it is there already. 'to' may be NIL, but 'from' may not. # BEGIN REF TRANSITIONLIST t := out OF from; WHILE IF t :/=: REF TRANSITIONLIST(NIL) THEN (from OF this OF t :/=: from) OR (symbol OF this OF t /= s) OR (to OF this OF t :/=: to) ELSE FALSE FI DO t := next OF t OD; IF t :=: REF TRANSITIONLIST(NIL) THEN nmb transitions +:= 1; REF TRANSITION new := HEAP TRANSITION := (from, s, to, nmb transitions, 0); IF t opt THEN +< "new "; -< new; end line FI; out OF from := HEAP TRANSITIONLIST := (new, out OF from); IF to :/=: REF STATE (NIL) THEN REF REF TRANSITIONLIST inplace = IF in OF to :=: REF TRANSITIONLIST(NIL) THEN in OF to ELSE next OF in OF to FI; inplace := HEAP TRANSITIONLIST := (new, in place) FI FI END # of make transition # ; # FSM states# PROC for all states = (PROC(REF STATE) VOID x) VOID: BEGIN IF startstate :/=: REF STATE(NIL) THEN x(startstate) FI; FOR i TO UPB symbol DO SYMBOL ac = symbol[i]; REF STATE st := states OF ac; WHILE REF STATE (st):/=: NIL DO x(st); st:= next OF st OD OD END # for all states #; # Finite state machine construction # # PR page PR # #grow fsm# PROC grow fsm = VOID : BEGIN nmb states := nmb transitions := 0; newstates:= NIL; REF STATE current state := start state := IF useful OF start production THEN makestate( HEAP CONFLIST:=(right OF startproduction, NIL), NIL ) ELSE NIL FI; newstates := currentstate; WHILE newstates :/=: REF STATE(NIL) DO # Process a new state : # currentstate:= newstates; newstates := link OF newstates; # Process 'current state': # REF CONFLIST cl:= conf OF currentstate; WHILE cl :/=: REF CONFLIST (NIL) DO # Process configuration 'c': # PROMOTION c := this OF cl; CASE c IN (REF PRODUCTION c): maketransition(currentstate, c, NIL), (REF CONFIGURATION c): BEGIN # Promotion transitions are wanted, but we must sort them by symbol. The set of resulting new configurations for each symbol will later become a state. The promotion transitions under a symbol are hung on its 'attach' field. # SYMBOL s = sym OF c; INT sn = number OF s; attach(promote OF c, s); IF NOT is terminal OF s THEN # A nonterminal: predict any new configurations, and promote them as well. # FOR tn TO UPB symbol DO SYMBOL t = symbol[tn]; IF bit (plnonempty, sn, tn) THEN #assert s =>* t without using empty productions # REF PRODUCTIONLIST pl := definitions OF t; WHILE pl :/=: REF PRODUCTIONLIST(NIL) DO REF PROD p = this OF pl; IF NOT useful OF p THEN SKIP ELSE CASE right OF p IN (REF PRODUCTION): make transition ( currentstate, p, NIL), (REF CONF rp): attach(promote OF rp, sym OF rp) ESAC FI; pl := next OF pl OD FI OD FI END ESAC; cl := next OF cl OD; #Possible new states have been considered as sets of configurations. Now make them into real states# FOR sn TO UPB symbol DO SYMBOL s = symbol[sn]; IF attachment OF s :/=: REF CONFLIST (NIL) THEN REF STATE q = make state(attachment OF s, s); maketransition(currentstate,s,q) FI; REF REF CONFLIST(attachment OF s) := NIL OD OD END # growfsm#; # Check look ahead # # PR page PR # PROC ll1 check = VOID: for all states( (REF STATE s) VOID: IF SIZE(conf OF s) > 1 THEN +< "An LL(1) violation can be reached by reading"; indent; end line; +< s; dedent; end line FI ) # end of ll1 check #; PROC check look ahead = (BOOL slr 1 processing) BOOL : BEGIN IF NOT slr1 processing THEN syserr(("temporary bug: only SLR1 tables will be produced", " even though we perform LALR lookahead checks.")) FI; PROC inadequacy = (REF STATE s) VOID: # complain about an inadequacy # BEGIN errors := TRUE; end line; end line; +< "An inadequate state can be reached by reading "; indent; end line; +< s; dedent; end line; +< "Possible actions are: "; indent; REF TRANSITIONLIST t := out OF s; WHILE t :/=: REF TRANSITIONLIST(NIL) DO CASE symbol OF this OF t IN (SYMBOL s): IF isterminal OF s THEN end line; +< "Read "; -< name OF s FI, (REF PRODUCTION p): BEGIN end line; +< "Apply production "; -< number OF p; +< " with lookaheads "; INT l = number OF left OF p; FOR i FROM LWB terminal TO UPB terminal DO IF bit(f, l, i) THEN -< " "; -< name OF symbol[i] FI OD END ESAC; t := next OF t OD; dedent; end line END # of inadequacy #; #Check lookahead resumes# [1 : UPB terminal] BOOL b, c; BOOL errors := FALSE; for all states ((REF STATE s) VOID: BEGIN FOR i TO UPB b DO b[i] := FALSE OD; REF TRANSITIONLIST tl := out OF s; WHILE # more list exists and no conflict yet found # IF tl :/=: REF TRANSITIONLIST (NIL) THEN REF TRANSITION t = this OF tl; CASE symbol OF t IN (SYMBOL u): IF isterminal OF u THEN IF b[number OF u] THEN FALSE ELSE b[number OF u]:= TRUE; TRUE FI FI, (REF PRODUCTION p): IF slr1 processing THEN BOOL conflict := FALSE; INT l = number OF left OF p; FOR i FROM LWB terminal TO UPB terminal DO REF BOOL bi = b[i]; IF bi THEN ( bit(f, l, i) | conflict := TRUE ) ELSE bi := bit(f, l, i) FI OD; NOT conflict ELSE [LWB terminal : UPB terminal] BOOL look; FOR i FROM LWB look TO UPB look DO look[i] := FALSE OD; lalr look ahead(t, look); BOOL conflict := FALSE; INT l = number OF left OF p; FOR i FROM LWB terminal TO UPB terminal DO REF BOOL bi = b[i]; IF bi THEN (look[i] | conflict := TRUE ) ELSE bi := look[i] FI OD; NOT conflict FI ESAC ELSE FALSE FI DO tl := next OF tl OD; IF tl :/=: REF TRANSITIONLIST(NIL) THEN inadequacy (s) FI END ) # end of state loop #; NOT errors END # of check look ahead#; # LALR lookahead # # PR page PR # PROC lalr look ahead = (REF TRANSITION t, REF[ #1 : nmb terminals # ]BOOL look ) VOID: # OR the LALR(1) lookahead set for the reduction transition 't' into 'look' # BEGIN REF PRODUCTION p = CASE symbol OF t IN (REF PROD p): p OUT syserror("not a reduction"); give up ESAC; # Notice that 'p' must be useful to have a transition # REF SYMBOL left = left OF p; PROC backward = (REF TRANSITION t, REF SYMBOLLIST l) VOID: IF t :=: REF TRANSITION(NIL) THEN SKIP ELIF REF STATE s = from OF t; s :=: REF STATE(NIL) THEN SKIP ELIF l :=: REF SYMBOLLIST(NIL) THEN REF TRANSITIONLIST t := out OF s; WHILE t :/=: REF TRANSITIONLIST(NIL) DO IF symbol OF this OF t = left THEN forward(to OF this OF t) ELSE SKIP FI; t := next OF t OD ELSE REF TRANSITIONLIST in := in OF s; WHILE in :/=: REF TRANSITIONLIST(NIL) DO IF symbol OF this OF in = this OF l THEN backward(this OF in, next OF l) FI; in := next OF in OD FI # end of 'explore' #; PROC forward = (REF STATE s) VOID: BEGIN REF TRANSITIONLIST out := out OF s; WHILE out :/=: REF TRANSITIONLIST(NIL) DO REF TRANSITION t = this OF out; IF scan OF t >= 1 THEN SKIP ELSE scan OF t := 1; CASE symbol OF t IN (SYMBOL s): IF is terminal OF s THEN look[number OF s] := TRUE ELSE FOR i FROM 1 TO nmb terminals DO look[i] ORAB bit(pl, number OF s, i) OD; IF empty OF s THEN forward(to OF t) FI FI, (REF PROD): lalr look ahead(t, look) ESAC; scan OF t := 0 FI; out := next OF out OD END # of 'forward' #; REF SYMBOLLIST rb := NIL; for right side(p, (REF SYMBOL s) VOID: rb := HEAP SYMBOLLIST := (s, rb)); # 'rb' now contains the right side backwards # backward(t, rb) EXIT give up: SKIP END # of 'lalr look ahead' #; # Make tables # # PR page PR # PROC make name table = VOID: FOR sy TO UPB symbol DO name[sy] := name OF symbol[sy] OD; PROC destroy grammar = VOID : BEGIN symbol := NIL; terminal := NIL; nonterminal := NIL; production := NIL END; PROC make transition table = VOID: # fill in 'm'. m[state number, symbol number], called 'x' below, indicates the action to be performed from the state when the symbol is the next input character. 'x' < 0: apply production - x . 'x' = 0: error. 'x' > 0: accept the symbol and enter state 'x'. # BEGIN FOR st TO nmb states DO FOR sy TO nsymbols DO m[st,sy]:= 0 OD OD; for all states( (REF STATE st) VOID: BEGIN INT stn = number OF st; REF TRANSITIONLIST tr := out OF st; WHILE tr :/=: REF TRANSITIONLIST (NIL) DO CASE symbol OF this OF tr IN (REF PRODUCTION pr): BEGIN INT pn = number OF pr, l = number OF left OF pr; productionlength [pn]:= (INT len:= 0; PROMOTION v := right OF pr; WHILE CASE v IN (REF CONF vc): (len +:= 1; v:= promote OF vc; TRUE ), (REF PRODUCTION): FALSE ESAC DO SKIP OD; len ); FOR i TO nsymbols DO IF bit(f,l,i) THEN m[stn,i]:= - pn FI OD END, (SYMBOL sy): m[stn, number OF sy] := number OF to OF this OF tr ESAC; tr:= next OF tr OD END ) # end of 'st' loop # END # of make transition matrix #; PROC destroy trees = VOID: BEGIN FOR i TO nsymbols DO symbol[i] := NIL OD; FOR i TO nmb productions DO production[i] := NIL OD; startstate := NIL END # of destroy trees #; # Squash matrix # # PR page PR # PROC squash matrix = VOID: BEGIN PROC add margin = (REF REF [,] INT margin, INT row, INT new value) INT: BEGIN PROC enlarge = VOID : BEGIN HEAP [ 1 : 1 UPB margin, 1 : 1 + (2 UPB margin) ] INT nmr; nmr[,1:2UPB margin]:= margin; FOR i TO 1 UPB margin DO nmr[i,2 UPB nmr]:=0 OD; margin:= nmr END #of enlarge # ; IF 2 UPB margin = 0 THEN enlarge FI; REF[] INT slice= margin[row,]; INT ii := 0; FOR i TO UPB slice WHILE ii := i; INT si = slice[i]; si /= new value AND si /= 0 DO SKIP OD; # assert slice[ii] = new value or slice[ii] = 0 or ii = UPB slice # IF INT si = slice[ii]; si /= new value AND si /= 0 THEN enlarge; ii +:= 1 FI; IF margin[row,ii]= 0 THEN margin[row, ii] := new value FI; ii END # of add margin#; apply margin := HEAP [ 1:nmb states, 1:0 ] INT; read margin := HEAP [1 : nsymbols, 1 : 0] INT; FOR st TO nmb states DO FOR sy TO nsymbols DO REF INT mx= m[st,sy]; IF mx > 0 THEN mx:= add margin(read margin,sy,mx) ELSE mx := - add margin(apply margin, sy, -mx) FI OD OD; INT nmb diff elem = 2 UPB read margin + 2 UPB apply margin + 1; element size := (INT twon:= 1, n:= 0; WHILE twon < nmb diff elem DO twon *:= 2; n +:= 1 OD; n); break := 2 UPB read margin; # For a packed element 'i' of size 'element size' in the array 'a', i = 0 will mean error, i <= break will mean (read; go to new state), and i > break will mean apply production i - break. # elements per word := bits width OVER element size; first word := (1 * nsymbols + 1) OVER elements per word; last word := (nmb states * nsymbols + nsymbols) OVER elements per word; HEAP [first word: last word] BITS a; FOR i FROM LWB a TO UPB a DO a[i] := 2 r 0 OD; FOR st TO nmb states DO FOR sy TO nsymbols DO INT i= st * nsymbols + sy; INT word index = i OVER elements per word; INT shift = (i MOD elements per word) * element size; BITS element = BIN IF INT mx = m[st, sy]; mx < 0 THEN break - mx ELSE mx FI; a[word index] ORAB element SHL shift OD OD; newm := a; m := NIL END # of squash matrix #; PROC write tables = VOID : IF output :/=: REF FILE(NIL) THEN put bin(output, (nmb symbols, nmb terminals, nmb productions, nmb states, UPB newm, 2 UPB apply margin, 2 UPB read margin, number OF start state, number OF end of file symbol)); FOR i TO UPB name DO put bin(output, UPB name[i]); FOR j TO UPB name[i] DO put bin(output, name[i][j]) OD OD; put bin(output, (newm, apply margin, read margin)); put bin(output, (target, production length)) FI # end of 'write tables' # ; # PR page PR # on line end(stand out, (REF FILE f)BOOL : (put(f, (newline, " ")); TRUE) ); -< g; SYMBOL start symbol = start OF g, end of file symbol = end of file OF g; REF PRODUCTION start production = start production OF g; REF [] SYMBOL symbol := symbols OF g, terminal := terminals OF g, nonterminal := nonterminals OF g; REF [] REF PRODUCTION production := productions OF g; INT nmb symbols = UPB symbol, n symbols = UPB symbol, nmb terminals = UPB terminal, nmb nonterminals = UPB nonterminal - LWB nonterminal + 1, nmb productions = UPB production, low nt = LWB nonterminal, high nt = UPB nonterminal; INT n symbols 32 = nmb symbols OVER bits width, low nt 32 = lownt OVER bits width, high nt 32 = highnt OVER bits width; -< nmb symbols; +< " symbols "; end line; -< nmb terminals; +< " terminals "; end line; -< nmb nonterminals; +< " nonterminals "; end line; -< nmb productions; +< " productions"; end line; [1 : n symbols] STRING name; make name table; time("Find empties"); find empty and useless nonterminals; time("Print symbols"); print symbols; time("Printed"); time("Bit arrays"); REF [,] BITS f:= HEAP [0:nsymbols 32, 1:nsymbols] BITS, plnonempty:= HEAP[lownt 32 : highnt 32, 1:nsymbols] BITS; REF [,] BITS pl; create bit arrays(pl); REF STATE startstate := NIL, newstates := NIL; INT nmb states := 0, nmb transitions := 0; time("FSM"); growfsm; -< nmb states; +< " states "; end line; -< nmb transitions; +< " transitions"; end line; time("End FSM"); IF ll1 opt THEN ll1 check FI; IF NOT IF s opt THEN IF time("First we try SLR(1) processing"); check look ahead(TRUE) THEN TRUE ELSE time("SLR(1) fails; try LALR(1)"); check look ahead(FALSE) FI ELSE time("LALR lookahead calculation"); check look ahead(FALSE) FI THEN error("inadequate states cause suppression of parse tables"); GOTO fail FI; IF output :=: REF FILE(NIL) THEN GOTO done FI; [1:nmb productions] INT target, production length; extract production data; REF[,] INT m:= HEAP[1:nmb states, 1:nmb symbols] INT; time("Transition table"); make transition table; destroy grammar; # no longer needed # destroy bit matrices # no longer needed # ; # Output variables for 'squash matrix' # REF [] BITS newm; REF [,] INT apply margin, read margin; INT element size, elements per word, first word, last word, break; time("Compress"); squash matrix; time("Output"); write tables; done: time("Finish"); TRUE ELSE error("invalid grammar"); time("Finish"); FALSE FI EXIT fail: time("Finish"); FALSE END # of 'generate parser' # ; # PR page PR # BEGIN BOOL pr opt, pl opt, ple opt, f opt, s opt, t opt, c opt, ll1 opt; PROC rfn = (REF STRING s) BOOL: # Read a string denotation from stand in. Yield TRUE if a string denotation is found, and assign it to 's'; otherwise yield FALSE and assign junk to 's'; # BEGIN CHAR c := " "; on logical file end(stand in, (REF FILE f) BOOL: GOTO x); s := ""; WHILE c = " " DO read(c); print(c) OD; IF c = "''" OR c = """" THEN on logical file end( stand in, (REF FILE f) BOOL: GOTO y ); CHAR q = c; read(c); print(c); WHILE IF c = q THEN read(c); print(c); c = q ELSE TRUE FI DO s +:= c; read(c); print(c) OD; TRUE ELIF c = "." THEN s := ""; FALSE ELIF c = "+" OR c = "-" THEN BOOL val := c = "+"; WHILE c /= " " DO IF c = "p" THEN read(c); print(c); IF c = "r" THEN pr opt := val ELIF c = "l" THEN pl opt := val ELSE print("?") FI ELIF c = ">" THEN ple opt := val ELIF c = "l" THEN ll1 opt := val ELIF c = "f" THEN f opt := val ELIF c = "g" THEN g opt := val ELIF c = "s" THEN s opt := val ELIF c = "t" THEN t opt := val # trace transitions # ELIF c = "c" THEN c opt := val # trace configurations # ELIF c = "+" THEN val := TRUE ELIF c = "-" THEN val := FALSE ELSE print("?") FI; read(c); print(c) OD; rfn(s) ELSE print("Invalid first character for file name"); s := ""; FALSE FI EXIT x: s := ""; FALSE EXIT y: print("Invalid or otherwise improper file name"); s := ""; FALSE END # of 'rfn' #; PROC find file = (REF FILE f, STRING idf, CHANNEL ch, UNION(STRUCT(INT p, l, c), VOID) mood, STRING channelname, REF STRING filename) INT: IF INT x = ( mood | (STRUCT(INTp, l, c) sz): establish(f, idf, ch, p OFsz, l OFsz, c OFsz) | open(f, idf, ch) ), STRINGaction = ( mood | (VOID): "open" | "establish" ); x = 0 THEN write((newline, "File ", action, "ed with idf """, idf, """ on channel """, channel name, """", newline)); file name := idf; 0 ELSE write(( newline, action, " failed on output file with idf """, idf, """ on channel """, channelname, """ returning code ", whole(x, 0), newline)); ( mood | (STRUCT(INTp, l, c) sz): write(( "p: ", whole(p OFsz, 0), ", l: ", whole(l OFsz, 0), ", c:", whole(c OFsz, 0), newline)) ); x FI; FILE input, output; STRING in name := "", out name := ""; WHILE pr opt := pl opt := ple opt := f opt := ll1 opt := FALSE; g opt := TRUE; s opt := TRUE; t opt := c opt := FALSE; IF char number(stand in) /= 1 THEN read(newline) FI; IF STRING s; rfn(s) THEN IF s = "" THEN s := "input" FI; IF s = in name THEN SKIP ELSE IF in name = "" OR in name = "input" THEN SKIP ELSE close(input); write(("Input file with idf """, inname, """ closed.", newline)) FI; IF s = "input" THEN input := stand in; in name := "" ELSE find file(input, s, standin channel, EMPTY, "standin channel", in name) FI FI; IF rfn(s) THEN IF s = out name THEN SKIP ELSE IF out name = "" THEN SKIP ELSE close(output); write(("Output file closed with idf """, out name, """", newline)) FI; find file(output, s, standback channel, STRUCT(INTp, l, c) (1, 1, 10000), "standback channel", outname) FI; TRUE ELSE print((newline, "No output file name")); FALSE FI ELSE print((newline, "No input file name")); FALSE FI DO print((newline, "Input from """, in name, """, ", "output to """, out name, """", newline, newline, newline)); generate parser(input, output, pr opt, pl opt, ple opt, f opt, s opt, t opt, c opt, ll1 opt) OD; IF out name /= "" THEN close(output); print(("Output file """, out name, """ closed. ", newline)) FI; time("Processing ended"); end line END END algol68g-2.8/test-set/a68g.ur.183.r541a.a680000644000175000001440000006656712224301300014361 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r541a # (print (("routine texts without parameters", newline)); INT vf = 47 * 10 + 45; INT ctr := 0, ctrt := 0, ctrloc; PROC ctrl = (INT inc) VOID: (ctr /= ctrloc + inc | print (("count er in test", ctrt, ctr, ctrloc + inc, newline))); # servitudes pour les corps de routines # OP MON = (REAL a) REAL: (ctr +:= 1; 3.1415), = = (BOOL a, INT b) INT: (a | b | ctr -:= 1), UNION (INT, BOOL) vu, MODE STRA = STRUCT (INT de, REF INT of), [, ] INT ta = 1, PROC pra = (UNION (INT, BOOL) a) INT: (a | (INT x): (ctr +:= 1; x)), INT ida = 1; MODE STRB = STRUCT (BOOL de, REF INT of), [, ] BOOL tb = TRUE, PROC prb = (UNION (INT, BOOL) a) BOOL: (a | (BOOL x): (ctr +:= 1; x)), BOOL idb = TRUE; # mode rendu : PROC INT # (MODE R = PROC INT; PROC test = (R proc) VOID: IF proc = 1 THEN ctr +:= 1 ELSE print (("er", ctrt, ctr - ctrloc, newline)) FI; OP ?=:= = (R x) R: (test (x); x); (ctrt := 1; ctrloc := ctr; test (INT: LOC INT := (ctr +:= 1; 1)); FOR ident FROM INT: LOC INT := (ctr +:= 1; 1) BY INT: LOC INT := (ctr +:= 1; 1) TO INT: LOC INT := (ctr +:= 1; 1) WHILE BOOL: LOC BOOL := (ctr +:= 1; TRUE) DO [INT: LOC INT := (ctr +:= 1; 1) : 4, -1 : INT: LOC INT := (ctr +:= 1; 1)] R ent; ent[INT: LOC INT := (ctr +:= 1; 1), 0] := ent[1, INT: LOC INT := (ctr +:= 1; 1)] := INT: LOC INT := (ctr +:= 1; 1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: LOC INT := (ctr +:= 1; 1); REAL e = 0.12345; INT: LOC INT := (ctr +:= 1; 1)); test (par); alfa := ?=:=(INT: LOC INT := (ctr +:= 1; 1)); R ident = INT: LOC INT := (ctr +:= 1; 1), R loc := CASE INT: LOC INT := (ctr +:= 1; 1) IN INT: LOC INT := (ctr +:= 1; 1), SKIP ESAC, tas := INT: LOC INT := (ctr +:= 1; 1); test (ident); test (loc); test (tas); PROC proc = R: INT: LOC INT := (ctr +:= 1; 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: LOC INT := (ctr +:= 1; 1), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: LOC INT := (ctr +:= 1; 1), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: LOC INT := (ctr +:= 1; 1)); UNION (R, CHAR) union := pr (proc, INT: LOC INT := (ctr +:= 1; 1), proc); test ((union | (R a): a)); (test (R BEGIN INT: LOC INT := (ctr +:= 1; 1) END), ?=:=(union; BOOL: LOC BOOL := (ctr +:= 1; TRUE) | INT: LOC INT := (ctr +:= 1; 1)), INT: LOC INT := (ctr +:= 1; 1), test ((BOOL bool = FALSE; union | (R): INT: LOC INT := (ctr +:= 1; 1), (CHAR car): SKIP))); ctrl (47)); (ctrt := 2; ctrloc := ctr; test (INT: INT: (ctr +:= 1; 1)); FOR ident FROM INT: INT: (ctr +:= 1; 1) BY INT: INT: (ctr +:= 1; 1) TO INT: INT: (ctr +:= 1; 1) WHILE BOOL: BOOL: (ctr +:= 1; TRUE) DO [INT: INT: (ctr +:= 1; 1) : 4, -1 : INT: INT: (ctr +:= 1; 1)] R ent; ent[INT: INT: (ctr +:= 1; 1), 0] := ent[1, INT: INT: (ctr +:= 1; 1)] := INT: INT: (ctr +:= 1; 1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: INT: (ctr +:= 1; 1); REAL e = 0.12345; INT: INT: (ctr +:= 1; 1)); test (par); alfa := ?=:=(INT: INT: (ctr +:= 1; 1)); R ident = INT: INT: (ctr +:= 1; 1), R loc := CASE INT: INT: (ctr +:= 1; 1) IN INT: INT: (ctr +:= 1; 1), SKIP ESAC, tas := INT: INT: (ctr +:= 1; 1); test (ident); test (loc); test (tas); PROC proc = R: INT: INT: (ctr +:= 1; 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: INT: (ctr +:= 1; 1), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: INT: (ctr +:= 1; 1), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: INT: (ctr +:= 1; 1)); UNION (R, CHAR) union := pr (proc, INT: INT: (ctr +:= 1; 1), proc); test ((union | (R a): a)); (test (R BEGIN INT: INT: (ctr +:= 1; 1) END), ?=:=(union; BOOL: BOOL: (ctr +:= 1; TRUE) | INT: INT: (ctr +:= 1; 1)), INT: INT: (ctr +:= 1; 1), test ((BOOL bool = FALSE; union | (R): INT: INT: (ctr +:= 1; 1), (CHAR car): SKIP))); ctrl (47)); (ctrt := 3; ctrloc := ctr; test (INT: 3.1415 = MON 0.5 = 1); FOR ident FROM INT: 3.1415 = MON 0.5 = 1 BY INT: 3.1415 = MON 0.5 = 1 TO INT: 3.1415 = MON 0.5 = 1 WHILE BOOL: 3.1415 = MON 0.5 = TRUE DO [INT: 3.1415 = MON 0.5 = 1 : 4, -1 : INT: 3.1415 = MON 0.5 = 1] R ent; ent[INT: 3.1415 = MON 0.5 = 1, 0] := ent[1, INT: 3.1415 = MON 0.5 = 1] := INT: 3.1415 = MON 0.5 = 1; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: 3.1415 = MON 0.5 = 1; REAL e = 0.12345; INT: 3.1415 = MON 0.5 = 1); test (par); alfa := ?=:=(INT: 3.1415 = MON 0.5 = 1); R ident = INT: 3.1415 = MON 0.5 = 1, R loc := CASE INT: 3.1415 = MON 0.5 = 1 IN INT: 3.1415 = MON 0.5 = 1, SKIP ESAC, tas := INT: 3.1415 = MON 0.5 = 1; test (ident); test (loc); test (tas); PROC proc = R: INT: 3.1415 = MON 0.5 = 1, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: 3.1415 = MON 0.5 = 1, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: 3.1415 = MON 0.5 = 1, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: 3.1415 = MON 0.5 = 1); UNION (R, CHAR) union := pr (proc, INT: 3.1415 = MON 0.5 = 1, proc); test ((union | (R a): a)); (test (R BEGIN INT: 3.1415 = MON 0.5 = 1 END), ?=:=(union; BOOL: 3.1415 = MON 0.5 = TRUE | INT: 3.1415 = MON 0.5 = 1), INT: 3.1415 = MON 0.5 = 1, test ((BOOL bool = FALSE; union | (R): INT: 3.1415 = MON 0.5 = 1, (CHAR car): SKIP))); ctrl (47)); (ctrt := 4; ctrloc := ctr; test (INT: de OF STRA (1, ctr +:= 1)); FOR ident FROM INT: de OF STRA (1, ctr +:= 1) BY INT: de OF STRA (1, ctr +:= 1) TO INT: de OF STRA (1, ctr +:= 1) WHILE BOOL: de OF STRB (TRUE, ctr +:= 1) DO [INT: de OF STRA (1, ctr +:= 1) : 4, -1 : INT: de OF STRA (1, ctr +:= 1)] R ent; ent[INT: de OF STRA (1, ctr +:= 1), 0] := ent[1, INT: de OF STRA (1, ctr +:= 1)] := INT: de OF STRA (1, ctr +:= 1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: de OF STRA (1, ctr +:= 1); REAL e = 0.12345; INT: de OF STRA (1, ctr +:= 1)); test (par); alfa := ?=:=(INT: de OF STRA (1, ctr +:= 1)); R ident = INT: de OF STRA (1, ctr +:= 1), R loc := CASE INT: de OF STRA (1, ctr +:= 1) IN INT: de OF STRA (1, ctr +:= 1), SKIP ESAC, tas := INT: de OF STRA (1, ctr +:= 1); test (ident); test (loc); test (tas); PROC proc = R: INT: de OF STRA (1, ctr +:= 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: de OF STRA (1, ctr +:= 1), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: de OF STRA (1, ctr +:= 1), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: de OF STRA (1, ctr +:= 1)); UNION (R, CHAR) union := pr (proc, INT: de OF STRA (1, ctr +:= 1), proc); test ((union | (R a): a)); (test (R BEGIN INT: de OF STRA (1, ctr +:= 1) END), ?=:=(union; BOOL: de OF STRB (TRUE, ctr +:= 1) | INT: de OF STRA (1, ctr +:= 1)), INT: de OF STRA (1, ctr +:= 1), test ((BOOL bool = FALSE; union | (R): INT: de OF STRA (1, ctr +:= 1), (CHAR car): SKIP))); ctrl (47)); (ctrt := 5; ctrloc := ctr; test (INT: ta[ida, (ctr +:= 1; 1)]); FOR ident FROM INT: ta[ida, (ctr +:= 1; 1)] BY INT: ta[ida, (ctr +:= 1; 1)] TO INT: ta[ida, (ctr +:= 1; 1)] WHILE BOOL: tb[ida, (ctr +:= 1; 1)] DO [INT: ta[ida, (ctr +:= 1; 1)] : 4, -1 : INT: ta[ida, (ctr +:= 1; 1)]] R ent; ent[INT: ta[ida, (ctr +:= 1; 1)], 0] := ent[1, INT: ta[ida, (ctr +:= 1; 1)]] := INT: ta[ida, (ctr +:= 1; 1)]; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: ta[ida, (ctr +:= 1; 1)]; REAL e = 0.12345; INT: ta[ida, (ctr +:= 1; 1)]); test (par); alfa := ?=:=(INT: ta[ida, (ctr +:= 1; 1)]); R ident = INT: ta[ida, (ctr +:= 1; 1)], R loc := CASE INT: ta[ida, (ctr +:= 1; 1)] IN INT: ta[ida, (ctr +:= 1; 1)], SKIP ESAC, tas := INT: ta[ida, (ctr +:= 1; 1)]; test (ident); test (loc); test (tas); PROC proc = R: INT: ta[ida, (ctr +:= 1; 1)], STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: ta[ida, (ctr +:= 1; 1)], (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: ta[ida, (ctr +:= 1; 1)], proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: ta[ida, (ctr +:= 1; 1)]); UNION (R, CHAR) union := pr (proc, INT: ta[ida, (ctr +:= 1; 1)], proc); test ((union | (R a): a)); (test (R BEGIN INT: ta[ida, (ctr +:= 1; 1)] END), ?=:=(union; BOOL: tb[ida, (ctr +:= 1; 1)] | INT: ta[ida, (ctr +:= 1; 1)]), INT: ta[ida, (ctr +:= 1; 1)], test ((BOOL bool = FALSE; union | (R): INT: ta[ida, (ctr +:= 1; 1)], (CHAR car): SKIP))); ctrl (47)); (ctrt := 6; ctrloc := ctr; test (INT: pra (1)); FOR ident FROM INT: pra (1) BY INT: pra (1) TO INT: pra (1) WHILE BOOL: prb (TRUE) DO [INT: pra (1) : 4, -1 : INT: pra (1)] R ent; ent[INT: pra (1), 0] := ent[1, INT: pra (1)] := INT: pra (1); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: pra (1); REAL e = 0.12345; INT: pra (1)); test (par); alfa := ?=:=(INT: pra (1)); R ident = INT: pra (1), R loc := CASE INT: pra (1) IN INT: pra (1), SKIP ESAC, tas := INT: pra (1); test (ident); test (loc); test (tas); PROC proc = R: INT: pra (1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: pra (1), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: pra (1), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: pra (1)); UNION (R, CHAR) union := pr (proc, INT: pra (1), proc); test ((union | (R a): a)); (test (R BEGIN INT: pra (1) END), ?=:=(union; BOOL: prb (TRUE) | INT: pra (1)), INT: pra (1), test ((BOOL bool = FALSE; union | (R): INT: pra (1), (CHAR car): SKIP))); ctrl (47)); (ctrt := 7; ctrloc := ctr; test (INT: INT (ctr +:= 1; ida | 1, SKIP)); FOR ident FROM INT: INT (ctr +:= 1; ida | 1, SKIP) BY INT: INT (ctr +:= 1; ida | 1, SKIP) TO INT: INT (ctr +:= 1; ida | 1, SKIP) WHILE BOOL: BOOL (ctr +:= 1; ida | TRUE, SKIP) DO [INT: INT (ctr +:= 1; ida | 1, SKIP) : 4, -1 : INT: INT (ctr +:= 1; ida | 1, SKIP)] R ent; ent[INT: INT (ctr +:= 1; ida | 1, SKIP), 0] := ent[1, INT: INT (ctr +:= 1; ida | 1, SKIP)] := INT: INT (ctr +:= 1; ida | 1, SKIP); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: INT (ctr +:= 1; ida | 1, SKIP); REAL e = 0.12345; INT: INT (ctr +:= 1; ida | 1, SKIP)); test (par); alfa := ?=:=(INT: INT (ctr +:= 1; ida | 1, SKIP)); R ident = INT: INT (ctr +:= 1; ida | 1, SKIP), R loc := CASE INT: INT (ctr +:= 1; ida | 1, SKIP) IN INT: INT (ctr +:= 1; ida | 1, SKIP), SKIP ESAC, tas := INT: INT (ctr +:= 1; ida | 1, SKIP); test (ident); test (loc); test (tas); PROC proc = R: INT: INT (ctr +:= 1; ida | 1, SKIP), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: INT (ctr +:= 1; ida | 1, SKIP), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: INT (ctr +:= 1; ida | 1, SKIP), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: INT (ctr +:= 1; ida | 1, SKIP)); UNION (R, CHAR) union := pr (proc, INT: INT (ctr +:= 1; ida | 1, SKIP), proc); test ((union | (R a): a)); (test (R BEGIN INT: INT (ctr +:= 1; ida | 1, SKIP) END), ?=:=(union; BOOL: BOOL (ctr +:= 1; ida | TRUE, SKIP) | INT: INT (ctr +:= 1; ida | 1, SKIP)), INT: INT (ctr +:= 1; ida | 1, SKIP), test ((BOOL bool = FALSE; union | (R): INT: INT (ctr +:= 1; ida | 1, SKIP), (CHAR car): SKIP))); ctrl (47)); (ctrt := 8; ctrloc := ctr; test (INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END); FOR ident FROM INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END BY INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END TO INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END WHILE BOOL: BEGIN INT x; ctr +:= 1; e: TRUE EXIT f: SKIP END DO [INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END : 4, -1 : INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END] R ent; ent[INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, 0] := ent[1, INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END] := INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END; REAL e = 0.12345; INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END); test (par); alfa := ?=:=(INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END); R ident = INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, R loc := CASE INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END IN INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, SKIP ESAC, tas := INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END; test (ident); test (loc); test (tas); PROC proc = R: INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END); UNION (R, CHAR) union := pr (proc, INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, proc); test ((union | (R a): a)); (test (R BEGIN INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END END), ?=:=(union; BOOL: BEGIN INT x; ctr +:= 1; e: TRUE EXIT f: SKIP END | INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END), INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, test ((BOOL bool = FALSE; union | (R): INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, (CHAR car): SKIP))); ctrl (47)); (ctrt := 9; ctrloc := ctr; test (INT: (NOT idb | SKIP | ctr +:= 1; ida)); FOR ident FROM INT: (NOT idb | SKIP | ctr +:= 1; ida) BY INT: (NOT idb | SKIP | ctr +:= 1; ida) TO INT: (NOT idb | SKIP | ctr +:= 1; ida) WHILE BOOL: (NOT idb | SKIP | ctr +:= 1; idb) DO [INT: (NOT idb | SKIP | ctr +:= 1; ida) : 4, -1 : INT: (NOT idb | SKIP | ctr +:= 1; ida)] R ent; ent[INT: (NOT idb | SKIP | ctr +:= 1; ida), 0] := ent[1, INT: (NOT idb | SKIP | ctr +:= 1; ida)] := INT: (NOT idb | SKIP | ctr +:= 1; ida); test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: (NOT idb | SKIP | ctr +:= 1; ida); REAL e = 0.12345; INT: (NOT idb | SKIP | ctr +:= 1; ida)); test (par); alfa := ?=:=(INT: (NOT idb | SKIP | ctr +:= 1; ida)); R ident = INT: (NOT idb | SKIP | ctr +:= 1; ida), R loc := CASE INT: (NOT idb | SKIP | ctr +:= 1; ida) IN INT: (NOT idb | SKIP | ctr +:= 1; ida), SKIP ESAC, tas := INT: (NOT idb | SKIP | ctr +:= 1; ida); test (ident); test (loc); test (tas); PROC proc = R: INT: (NOT idb | SKIP | ctr +:= 1; ida), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: (NOT idb | SKIP | ctr +:= 1; ida), (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: (NOT idb | SKIP | ctr +:= 1; ida), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: (NOT idb | SKIP | ctr +:= 1; ida)); UNION (R, CHAR) union := pr (proc, INT: (NOT idb | SKIP | ctr +:= 1; ida), proc); test ((union | (R a): a)); (test (R BEGIN INT: (NOT idb | SKIP | ctr +:= 1; ida) END), ?=:=(union; BOOL: (NOT idb | SKIP | ctr +:= 1; idb) | INT: (NOT idb | SKIP | ctr +:= 1; ida)), INT: (NOT idb | SKIP | ctr +:= 1; ida), test ((BOOL bool = FALSE; union | (R): INT: (NOT idb | SKIP | ctr +:= 1; ida), (CHAR car): SKIP))); ctrl (47)); (ctrt := 10; ctrloc := ctr; test (INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); FOR ident FROM INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC BY INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC TO INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC WHILE BOOL: CASE vu := (ctr +:= 1; TRUE) IN (BOOL x): x ESAC DO [INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC : 4, -1 : INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC] R ent; ent[INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, 0] := ent[1, INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC] := INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC; REAL e = 0.12345; INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); test (par); alfa := ?=:=(INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); R ident = INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, R loc := CASE INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC IN INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, SKIP ESAC, tas := INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC; test (ident); test (loc); test (tas); PROC proc = R: INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC); UNION (R, CHAR) union := pr (proc, INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, proc); test ((union | (R a): a)); (test (R BEGIN INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC END), ?=:=(union; BOOL: CASE vu := (ctr +:= 1; TRUE) IN (BOOL x): x ESAC | INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC), INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, test ((BOOL bool = FALSE; union | (R): INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, (CHAR car): SKIP))); ctrl (47)); SKIP); # mode rendu : INT # (MODE R = INT; PROC test = (R proc) VOID: IF proc = 1 THEN ctr +:= 1 ELSE print (("er", ctrt, ctr - ctrloc, newline)) FI; OP ?=:= = (R x) R: (test (x); x); (ctrt := 11; ctrloc := ctr; test (INT: LOC INT := (ctr +:= 1; 1)); FOR ident FROM INT: INT: (ctr +:= 1; 1) BY INT: pra (1) TO INT: ta[ida, (ctr +:= 1; 1)] WHILE BOOL: tb[ida, (ctr +:= 1; 1)] DO [INT: de OF STRA (1, ctr +:= 1) : 4, -1 : INT: LOC INT := (ctr +:= 1; 1)] R ent; ent[INT: CASE vu := (ctr +:= 1; 1) IN (INT x): x ESAC, 0] := ent[1, INT: INT: (ctr +:= 1; 1)] := INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END; test (ent[1, 0]); test (ent[1, 1]) OD; R alfa, R par = (SKIP; INT: LOC INT := (ctr +:= 1; 1); REAL e = 0.12345; INT: INT (ctr +:= 1; ida | 1, SKIP)); test (par); alfa := ?=:=(INT: INT: (ctr +:= 1; 1)); R ident = INT: INT (ctr +:= 1; ida | 1, SKIP), R loc := CASE INT: de OF STRA (1, ctr +:= 1) IN INT: ta[ida, (ctr +:= 1; 1)], SKIP ESAC, tas := INT: pra (1); test (ident); test (loc); test (tas); PROC proc = R: INT: INT: (ctr +:= 1; 1), STRUCT (COMPL of, STRUCT (R de, COMPL of) de) struct := ((0.11, 0), (INT: BEGIN INT x; ctr +:= 1; e: 1 EXIT f: SKIP END, (0, 1e0))); test (de OF de OF struct); [] R apd = (ident, par, loc, INT: (NOT idb | SKIP | ctr +:= 1; ida), proc, tas, de OF de OF struct); test (apd[4]); test (apd[5]); PROC pr := (R rep, reprep, PROC R procrep) R: (test (rep); test (reprep); INT: INT (ctr +:= 1; ida | 1, SKIP)); UNION (R, CHAR) union := pr (proc, INT: INT (ctr +:= 1; ida | 1, SKIP), proc); test ((union | (R a): a)); (test (R BEGIN INT: pra (1) END), ?=:=(union; BOOL: prb (TRUE) | INT: pra (1)), INT: de OF STRA (1, ctr +:= 1), test ((BOOL bool = FALSE; union | (R): INT: de OF STRA (1, ctr +:= 1), (CHAR car): SKIP))); ctrl (45)); SKIP); print ((ctr, " tests ", (ctr = vf | "ok" | "error"))))algol68g-2.8/test-set/a68g.mc.169.stow06.a680000644000175000001440000000240112224301274014627 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #stow06# BEGIN # Against over-optimization of string comparison # STRING str = "string with step > 1"; STRING ref str := str; [1 : UPB str] STRUCT (REAL flub, CHAR c) rst; print (("Result must be:", newline, str, ".", newline, str, ".", newline, "First test OK", newline, "Second test OK", newline, newline, "Result is:", newline)); FOR i TO UPB str DO c OF rst[i] := ref str[i] OD; print ((c OF rst, ".", newline, ref str, ".", newline)); IF c OF rst = str AND c OF rst = ref str THEN print (("First test OK", newline)) ELSE print (("Erroneous string, is: ", c OF rst, " , must be: ", str, newline)) FI; c OF rst := str; IF c OF rst /= str OR c OF rst /= ref str THEN print (("Erroneous string, is: ", c OF rst, " , must be: ", str, newline)) ELSE print (("Second test OK", newline)) FI ENDalgol68g-2.8/test-set/a68g.mc.059.idef03.a680000644000175000001440000000077712224301227014551 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #idef03# BEGIN INT i = 1; PROC a = VOID: (INT i = 2; b); PROC b = VOID: print (i); a # +1 # ENDalgol68g-2.8/test-set/a68g.mc.160.smio11.a680000644000175000001440000000340612224301263014571 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #smio11# BEGIN # Simple application of all formats with all allowed modes # printf (($"Integral "2(18x2d)l$, 1, LOC INT := 1)); printf (($"Real "2(15x2d.2d)l$, 2.0, LOC REAL := 2.0, 3, LOC INT := 3)); printf (($"Complex "2(7x2d.2dxix2d.2d)l$, 4.0 I 4.0, LOC COMPL := 4.0 I 4.0, 5.0, LOC REAL := 5.0, 6, LOC INT := 6)); print (newline); printf (($"Boolean "2(19xb)l$, TRUE, LOC BOOL := TRUE)); printf (($"String "2(16x4a)l$, "uvwx", LOC STRING := "uvwx")); printf (($"Character "2(19x1a)l$, STRING ("y"), LOC STRING := "y", "z", LOC CHAR := "z")); printf (($"Bits "2(18x16r2d)l$, 2r10101011, LOC BITS := 2r10101011)); print (newline); printf (($"Boolean choice "2(17xb("cde", "***"))l$, TRUE, LOC BOOL := TRUE)); printf (($"Integral choice"2(17xc("fgh"))l$, 1, LOC INT := 1)); print (newline); printf (($"General float "2(12xg(8, 2, 2))l$, 1.0, LOC REAL := 1.0, 2, LOC INT := 2)); printf (($"General fixed "2(14xg(6, 2))l$, 3.0, LOC REAL := 3.0, 4, LOC INT := 4)); printf (($"General whole "2(18xg(2))l$, 5.0, LOC REAL := 5.0, 6, LOC INT := 6)); print (newline); printf (($"General "g10x, gl$, 7, LOC INT := 7, 8.0, LOC REAL := 8.0, 9.0 I 9.0, LOC COMPL := 9.0 I 9.0, TRUE, LOC BOOL := TRUE, 2r1, LOC BITS := 2r1, "w", LOC CHAR := "w", "xyz", LOC STRING := "xyz")) ENDalgol68g-2.8/test-set/a68g.mc.042.decl01.a680000644000175000001440000000144212224301224014522 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #decl01# BEGIN # Some declarers # [1:10] INT i, [1:10] STRUCT (REF [] INT i, BOOL j) k, [1:10] STRUCT([1:10] INT i, BOOLj)l, [1:10] REF [] INT p, # formal, so no bounds allowed: # [1:10] PROC [1:10] INT q, STRUCT (REF [1:10] INT i, BOOLj) m, [1:10] REF [1:10] INT mn, PROC([1:10] INT) VOID pp, UNION([1:10] INT, BOOL)nm, [1:10] INT u=(1); MODE N = STRUCT(REAL a, b, a); # error, 'a' occurs twice # SKIP END algol68g-2.8/test-set/a68g.mc.049.flex01.a680000644000175000001440000000127212224301225014562 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #flex01# ( # OK # MODE S = FLEX [1 : 0] CHAR, T = [1 : 0] CHAR; REF STRING n = LOC S:= "Next line will be empty, then a"; UNION(REF S, REF T) f = LOC T := ""; UNION(STRING, CHAR) u = UNION(S, T, CHAR) ("a"); print((n, newline)); print(((f | (REF S s):s , (REF T t):t), newline)); print((u, newline)) ) algol68g-2.8/test-set/a68g.ur.197.r812.a680000644000175000001440000007545312224301311014222 00000000000000# This program is part of the Rennes Test Set, automatically generated from the Algol 68 grammar using a formalism of B. Houssais (University of Rennes, 1975). This test set is available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR # r812 # (print (("real denotations", newline)); INT vf = 704; INT ctr := 0, ct := 0; REAL erc := 0, super := 0, er; PROC r = (REAL a, b) VOID: ((b = 0 | a = 0 | (er := ABS ((a - b) / b)) < 1e-5) | ctr +:= 1; (b /= 0 | ct +:= 1; erc +:= er; (er > super | super := er)) | print (("er real", a, b, newline))); r (0.1 * 2.73801, 2.7380079e-01); r (0.1e1 * 2.73801, 2.7380094e+00); r (0.1e+0 * 2.73801, 2.7380079e-01); r (0.1e-0000 * 2.73801, 2.7380079e-01); r (0.1e4 * 2.73801, 2.7380092e+03); r (0.1e+10 * 2.73801, 2.7380093e+09); r (0.1e-16 * 2.73801, 2.7380088e-17); r (0.1e64 * 2.73801, 2.7380090e+63); r (0.1e+00011 * 2.73801, 2.7380088e+10); r (0.0 * 2.73801, 0.0000000e+00); r (0.0e-1 * 2.73801, 0.0000000e+00); r (0.0e0 * 2.73801, 0.0000000e+00); r (0.0e+0000 * 2.73801, 0.0000000e+00); r (0.0e-4 * 2.73801, 0.0000000e+00); r (0.0e10 * 2.73801, 0.0000000e+00); r (0.0e+16 * 2.73801, 0.0000000e+00); r (0.0e-64 * 2.73801, 0.0000000e+00); r (0.0e00011 * 2.73801, 0.0000000e+00); r (0.0000 * 2.73801, 0.0000000e+00); r (0.0000e+1 * 2.73801, 0.0000000e+00); r (0.0000e-0 * 2.73801, 0.0000000e+00); r (0.0000e0000 * 2.73801, 0.0000000e+00); r (0.0000e+4 * 2.73801, 0.0000000e+00); r (0.0000e-10 * 2.73801, 0.0000000e+00); r (0.0000e16 * 2.73801, 0.0000000e+00); r (0.0000e+64 * 2.73801, 0.0000000e+00); r (0.0000e-00011 * 2.73801, 0.0000000e+00); r (0.4 * 2.73801, 1.0952033e+00); r (0.4e1 * 2.73801, 1.0952037e+01); r (0.4e+0 * 2.73801, 1.0952033e+00); r (0.4e-0000 * 2.73801, 1.0952033e+00); r (0.4e4 * 2.73801, 1.0952035e+04); r (0.4e+10 * 2.73801, 1.0952036e+10); r (0.4e-16 * 2.73801, 1.0952035e-16); r (0.4e64 * 2.73801, 1.0952036e+64); r (0.4e+00011 * 2.73801, 1.0952035e+11); r (0.10 * 2.73801, 2.7380079e-01); r (0.10e-1 * 2.73801, 2.7380086e-02); r (0.10e0 * 2.73801, 2.7380079e-01); r (0.10e+0000 * 2.73801, 2.7380079e-01); r (0.10e-4 * 2.73801, 2.7380083e-05); r (0.10e10 * 2.73801, 2.7380093e+09); r (0.10e+16 * 2.73801, 2.7380091e+15); r (0.10e-64 * 2.73801, 2.7380081e-65); r (0.10e00011 * 2.73801, 2.7380088e+10); r (0.16 * 2.73801, 4.3808138e-01); r (0.16e+1 * 2.73801, 4.3808126e+00); r (0.16e-0 * 2.73801, 4.3808138e-01); r (0.16e0000 * 2.73801, 4.3808138e-01); r (0.16e+4 * 2.73801, 4.3808125e+03); r (0.16e-10 * 2.73801, 4.3808123e-11); r (0.16e16 * 2.73801, 4.3808145e+15); r (0.16e+64 * 2.73801, 4.3808148e+63); r (0.16e-00011 * 2.73801, 4.3808134e-12); r (0.64 * 2.73801, 1.7523250e+00); r (0.64e1 * 2.73801, 1.7523254e+01); r (0.64e+0 * 2.73801, 1.7523250e+00); r (0.64e-0000 * 2.73801, 1.7523250e+00); r (0.64e4 * 2.73801, 1.7523257e+04); r (0.64e+10 * 2.73801, 1.7523257e+10); r (0.64e-16 * 2.73801, 1.7523258e-16); r (0.64e64 * 2.73801, 1.7523257e+64); r (0.64e+00011 * 2.73801, 1.7523258e+11); r (0.00011 * 2.73801, 3.0118087e-04); r (0.00011e-1 * 2.73801, 3.0118098e-05); r (0.00011e0 * 2.73801, 3.0118087e-04); r (0.00011e+0000 * 2.73801, 3.0118087e-04); r (0.00011e-4 * 2.73801, 3.0118094e-08); r (0.00011e10 * 2.73801, 3.0118100e+06); r (0.00011e+16 * 2.73801, 3.0118080e+12); r (0.00011e-64 * 2.73801, 3.0118100e-68); r (0.00011e00011 * 2.73801, 3.0118096e+07); r (0.255 * 2.73801, 6.9819235e-01); r (0.255e+1 * 2.73801, 6.9819211e+00); r (0.255e-0 * 2.73801, 6.9819235e-01); r (0.255e0000 * 2.73801, 6.9819235e-01); r (0.255e+4 * 2.73801, 6.9819218e+03); r (0.255e-10 * 2.73801, 6.9819205e-11); r (0.255e16 * 2.73801, 6.9819203e+15); r (0.255e+64 * 2.73801, 6.9819198e+63); r (0.255e-00011 * 2.73801, 6.9819219e-12); r (0.256 * 2.73801, 7.0093035e-01); r (0.256e1 * 2.73801, 7.0093021e+00); r (0.256e+0 * 2.73801, 7.0093035e-01); r (0.256e-0000 * 2.73801, 7.0093035e-01); r (0.256e4 * 2.73801, 7.0093007e+03); r (0.256e+10 * 2.73801, 7.0093004e+09); r (0.256e-16 * 2.73801, 7.0093021e-17); r (0.256e64 * 2.73801, 7.0093005e+63); r (0.256e+00011 * 2.73801, 7.0092980e+10); r (0.4095 * 2.73801, 1.1212139e+00); r (0.4095e-1 * 2.73801, 1.1212146e-01); r (0.4095e0 * 2.73801, 1.1212139e+00); r (0.4095e+0000 * 2.73801, 1.1212139e+00); r (0.4095e-4 * 2.73801, 1.1212145e-04); r (0.4095e10 * 2.73801, 1.1212144e+10); r (0.4095e+16 * 2.73801, 1.1212145e+16); r (0.4095e-64 * 2.73801, 1.1212147e-64); r (0.4095e00011 * 2.73801, 1.1212147e+11); r (0.10000 * 2.73801, 2.7380079e-01); r (0.10000e+1 * 2.73801, 2.7380084e+00); r (0.10000e-0 * 2.73801, 2.7380079e-01); r (0.10000e0000 * 2.73801, 2.7380079e-01); r (0.10000e+4 * 2.73801, 2.7380085e+03); r (0.10000e-10 * 2.73801, 2.7380084e-11); r (0.10000e16 * 2.73801, 2.7380091e+15); r (0.10000e+64 * 2.73801, 2.7380090e+63); r (0.10000e-00011 * 2.73801, 2.7380077e-12); r (0.32768 * 2.73801, 8.9719086e-01); r (0.32768e1 * 2.73801, 8.9719066e+00); r (0.32768e+0 * 2.73801, 8.9719086e-01); r (0.32768e-0000 * 2.73801, 8.9719086e-01); r (0.32768e4 * 2.73801, 8.9719062e+03); r (0.32768e+10 * 2.73801, 8.9719070e+09); r (0.32768e-16 * 2.73801, 8.9719079e-17); r (0.32768e64 * 2.73801, 8.9719054e+63); r (0.32768e+00011 * 2.73801, 8.9719046e+10); r (0.131001 * 2.73801, 3.5868191e-01); r (0.131001e-1 * 2.73801, 3.5868193e-02); r (0.131001e0 * 2.73801, 3.5868191e-01); r (0.131001e+0000 * 2.73801, 3.5868191e-01); r (0.131001e-4 * 2.73801, 3.5868186e-05); r (0.131001e10 * 2.73801, 3.5868193e+09); r (0.131001e+16 * 2.73801, 3.5868192e+15); r (0.131001e-64 * 2.73801, 3.5868195e-65); r (0.131001e00011 * 2.73801, 3.5868188e+10); r (0.1000000000 * 2.73801, 2.7380079e-01); r (0.1000000000e+1 * 2.73801, 2.7380084e+00); r (0.1000000000e-0 * 2.73801, 2.7380079e-01); r (0.1000000000e0000 * 2.73801, 2.7380079e-01); r (0.1000000000e+4 * 2.73801, 2.7380085e+03); r (0.1000000000e-10 * 2.73801, 2.7380084e-11); r (0.1000000000e16 * 2.73801, 2.7380091e+15); r (0.1000000000e+64 * 2.73801, 2.7380090e+63); r (0.1000000000e-00011 * 2.73801, 2.7380077e-12); r (0.2147483646 * 2.73801, 5.8798289e-01); r (0.2147483646e1 * 2.73801, 5.8798274e+00); r (0.2147483646e+0 * 2.73801, 5.8798289e-01); r (0.2147483646e-0000 * 2.73801, 5.8798289e-01); r (0.2147483646e4 * 2.73801, 5.8798281e+03); r (0.2147483646e+10 * 2.73801, 5.8798284e+09); r (0.2147483646e-16 * 2.73801, 5.8798274e-17); r (0.2147483646e64 * 2.73801, 5.8798302e+63); r (0.2147483646e+00011 * 2.73801, 5.8798292e+10); r (1.1 * 2.73801, 3.0118083e+00); r (1.0e-1 * 2.73801, 2.7380079e-01); r (1.10e0 * 2.73801, 3.0118083e+00); r (1.4e+0000 * 2.73801, 3.8332118e+00); r (1.4e-4 * 2.73801, 3.8332119e-04); r (1.0000e10 * 2.73801, 2.7380088e+10); r (1.1e+16 * 2.73801, 3.0118101e+16); r (1.00011e-64 * 2.73801, 2.7383098e-64); r (1.0e00011 * 2.73801, 2.7380075e+11); r (0.64 * 2.73801, 1.7523250e+00); r (0.1e+1 * 2.73801, 2.7380094e+00); r (0.16e-0 * 2.73801, 4.3808138e-01); r (0.0e0000 * 2.73801, 0.0000000e+00); r (0.16e+4 * 2.73801, 4.3808125e+03); r (0.0000e-10 * 2.73801, 0.0000000e+00); r (0.4e16 * 2.73801, 1.0952033e+16); r (0.10e+64 * 2.73801, 2.7380090e+63); r (0.0e-00011 * 2.73801, 0.0000000e+00); r (0000.64 * 2.73801, 1.7523250e+00); r (0000.64e1 * 2.73801, 1.7523254e+01); r (0000.16e+0 * 2.73801, 4.3808138e-01); r (0000.16e-0000 * 2.73801, 4.3808138e-01); r (0000.10e4 * 2.73801, 2.7380092e+03); r (0000.10e+10 * 2.73801, 2.7380093e+09); r (0000.10e-16 * 2.73801, 2.7380088e-17); r (0000.0000e64 * 2.73801, 0.0000000e+00); r (0000.0000e+00011 * 2.73801, 0.0000000e+00); r (4.0000 * 2.73801, 1.0952034e+01); r (4.16e-1 * 2.73801, 1.1390113e+00); r (4.00011e0 * 2.73801, 1.0952337e+01); r (4.0000e+0000 * 2.73801, 1.0952034e+01); r (4.4e-4 * 2.73801, 1.2047237e-03); r (4.16e10 * 2.73801, 1.1390117e+11); r (4.16e+16 * 2.73801, 1.1390115e+17); r (4.1e-64 * 2.73801, 1.1225838e-63); r (4.64e00011 * 2.73801, 1.2704358e+12); r (10.64 * 2.73801, 2.9132415e+01); r (10.4e+1 * 2.73801, 2.8475292e+02); r (10.10e-0 * 2.73801, 2.7653884e+01); r (10.4e0000 * 2.73801, 2.8475296e+01); r (10.16e+4 * 2.73801, 2.7818175e+05); r (10.4e-10 * 2.73801, 2.8475293e-09); r (10.0e16 * 2.73801, 2.7380079e+17); r (10.64e+64 * 2.73801, 2.9132410e+65); r (10.64e-00011 * 2.73801, 2.9132407e-10); r (16.64 * 2.73801, 4.5560470e+01); r (16.64e1 * 2.73801, 4.5560473e+02); r (16.0e+0 * 2.73801, 4.3808135e+01); r (16.10e-0000 * 2.73801, 4.4081924e+01); r (16.10e4 * 2.73801, 4.4081950e+05); r (16.10e+10 * 2.73801, 4.4081944e+11); r (16.16e-16 * 2.73801, 4.4246222e-15); r (16.4e64 * 2.73801, 4.4903342e+65); r (16.4e+00011 * 2.73801, 4.4903327e+12); r (64.0 * 2.73801, 1.7523255e+02); r (64.0e-1 * 2.73801, 1.7523254e+01); r (64.4e0 * 2.73801, 1.7632778e+02); r (64.10e+0000 * 2.73801, 1.7550637e+02); r (64.4e-4 * 2.73801, 1.7632775e-02); r (64.00011e10 * 2.73801, 1.7523288e+12); r (64.4e+16 * 2.73801, 1.7632780e+18); r (64.0000e-64 * 2.73801, 1.7523256e-62); r (64.10e00011 * 2.73801, 1.7550639e+13); r (00011.0 * 2.73801, 3.0118087e+01); r (00011.0e+1 * 2.73801, 3.0118090e+02); r (00011.16e-0 * 2.73801, 3.0556182e+01); r (00011.4e0000 * 2.73801, 3.1213302e+01); r (00011.4e+4 * 2.73801, 3.1213306e+05); r (00011.1e-10 * 2.73801, 3.0391900e-09); r (00011.64e16 * 2.73801, 3.1870409e+17); r (00011.0000e+64 * 2.73801, 3.0118076e+65); r (00011.0e-00011 * 2.73801, 3.0118085e-10); r (255.0000 * 2.73801, 6.9819213e+02); r (255.0000e1 * 2.73801, 6.9819218e+03); r (255.4e+0 * 2.73801, 6.9928735e+02); r (255.0000e-0000 * 2.73801, 6.9819213e+02); r (255.16e4 * 2.73801, 6.9863040e+06); r (255.00011e+10 * 2.73801, 6.9819254e+12); r (255.64e-16 * 2.73801, 6.9994465e-14); r (255.16e64 * 2.73801, 6.9863013e+66); r (255.4e+00011 * 2.73801, 6.9928728e+13); r (256.0 * 2.73801, 7.0093017e+02); r (256.0e-1 * 2.73801, 7.0093002e+01); r (256.1e0 * 2.73801, 7.0120361e+02); r (256.1e+0000 * 2.73801, 7.0120361e+02); r (256.0000e-4 * 2.73801, 7.0092976e-02); r (256.0e10 * 2.73801, 7.0093027e+12); r (256.1e+16 * 2.73801, 7.0120386e+18); r (256.0000e-64 * 2.73801, 7.0093016e-62); r (256.64e00011 * 2.73801, 7.0268231e+13); r (4095.10 * 2.73801, 1.1212421e+04); r (4095.0000e+1 * 2.73801, 1.1212143e+05); r (4095.16e-0 * 2.73801, 1.1212585e+04); r (4095.0e0000 * 2.73801, 1.1212144e+04); r (4095.64e+4 * 2.73801, 1.1213900e+08); r (4095.0000e-10 * 2.73801, 1.1212141e-06); r (4095.10e16 * 2.73801, 1.1212416e+20); r (4095.1e+64 * 2.73801, 1.1212414e+68); r (4095.0000e-00011 * 2.73801, 1.1212148e-07); r (10000.4 * 2.73801, 2.7381183e+04); r (10000.10e1 * 2.73801, 2.7380350e+05); r (10000.00011e+0 * 2.73801, 2.7380093e+04); r (10000.4e-0000 * 2.73801, 2.7381183e+04); r (10000.10e4 * 2.73801, 2.7380352e+08); r (10000.16e+10 * 2.73801, 2.7380527e+14); r (10000.1e-16 * 2.73801, 2.7380363e-12); r (10000.0000e64 * 2.73801, 2.7380090e+68); r (10000.00011e+00011 * 2.73801, 2.7380091e+15); r (32768.0 * 2.73801, 8.9719062e+04); r (32768.4e-1 * 2.73801, 8.9720156e+03); r (32768.00011e0 * 2.73801, 8.9719062e+04); r (32768.0e+0000 * 2.73801, 8.9719062e+04); r (32768.64e-4 * 2.73801, 8.9720821e+00); r (32768.00011e10 * 2.73801, 8.9719075e+14); r (32768.16e+16 * 2.73801, 8.9719445e+20); r (32768.0000e-64 * 2.73801, 8.9719091e-60); r (32768.00011e00011 * 2.73801, 8.9719075e+15); r (131001.0000 * 2.73801, 3.5868175e+05); r (131001.1e+1 * 2.73801, 3.5868220e+06); r (131001.64e-0 * 2.73801, 3.5868368e+05); r (131001.4e0000 * 2.73801, 3.5868300e+05); r (131001.64e+4 * 2.73801, 3.5868367e+09); r (131001.0e-10 * 2.73801, 3.5868186e-05); r (131001.10e16 * 2.73801, 3.5868215e+21); r (131001.10e+64 * 2.73801, 3.5868218e+69); r (131001.10e-00011 * 2.73801, 3.5868215e-06); r (1000000000.1 * 2.73801, 2.7380093e+09); r (1000000000.4e1 * 2.73801, 2.7380088e+10); r (1000000000.4e+0 * 2.73801, 2.7380093e+09); r (1000000000.16e-0000 * 2.73801, 2.7380093e+09); r (1000000000.10e4 * 2.73801, 2.7380080e+13); r (1000000000.4e+10 * 2.73801, 2.7380091e+19); r (1000000000.16e-16 * 2.73801, 2.7380082e-07); r (1000000000.0e64 * 2.73801, 2.7380090e+73); r (1000000000.0e+00011 * 2.73801, 2.7380089e+20); r (2147483646.0000 * 2.73801, 5.8798284e+09); r (2147483646.10e-1 * 2.73801, 5.8798284e+08); r (2147483646.0e0 * 2.73801, 5.8798284e+09); r (2147483646.64e+0000 * 2.73801, 5.8798284e+09); r (2147483646.0000e-4 * 2.73801, 5.8798287e+05); r (2147483646.0000e10 * 2.73801, 5.8798293e+19); r (2147483646.16e+16 * 2.73801, 5.8798277e+25); r (2147483646.10e-64 * 2.73801, 5.8798303e-55); r (2147483646.4e00011 * 2.73801, 5.8798293e+20); r (1.4095 * 2.73801, 3.8592214e+00); r (1.4095e+1 * 2.73801, 3.8592239e+01); r (1.32768e-0 * 2.73801, 3.6351985e+00); r (1.255e0000 * 2.73801, 3.4361991e+00); r (1.4095e+4 * 2.73801, 3.8592242e+04); r (1.256e-10 * 2.73801, 3.4389380e-10); r (1.255e16 * 2.73801, 3.4362010e+16); r (1.32768e+64 * 2.73801, 3.6351995e+64); r (1.256e-00011 * 2.73801, 3.4389394e-11); r (0.32768 * 2.73801, 8.9719086e-01); r (0.256e1 * 2.73801, 7.0093021e+00); r (0.255e+0 * 2.73801, 6.9819235e-01); r (0.256e-0000 * 2.73801, 7.0093035e-01); r (0.255e4 * 2.73801, 6.9819218e+03); r (0.32768e+10 * 2.73801, 8.9719070e+09); r (0.256e-16 * 2.73801, 7.0093021e-17); r (0.10000e64 * 2.73801, 2.7380090e+63); r (0.255e+00011 * 2.73801, 6.9819170e+10); r (0000.10000 * 2.73801, 2.7380079e-01); r (0000.256e-1 * 2.73801, 7.0092976e-02); r (0000.255e0 * 2.73801, 6.9819235e-01); r (0000.10000e+0000 * 2.73801, 2.7380079e-01); r (0000.32768e-4 * 2.73801, 8.9719047e-05); r (0000.255e10 * 2.73801, 6.9819228e+09); r (0000.32768e+16 * 2.73801, 8.9719075e+15); r (0000.255e-64 * 2.73801, 6.9819222e-65); r (0000.32768e00011 * 2.73801, 8.9719046e+10); r (4.32768 * 2.73801, 1.1849226e+01); r (4.4095e+1 * 2.73801, 1.2073248e+02); r (4.32768e-0 * 2.73801, 1.1849226e+01); r (4.10000e0000 * 2.73801, 1.1225836e+01); r (4.256e+4 * 2.73801, 1.1652962e+05); r (4.255e-10 * 2.73801, 1.1650225e-09); r (4.4095e16 * 2.73801, 1.2073249e+17); r (4.255e+64 * 2.73801, 1.1650220e+65); r (4.4095e-00011 * 2.73801, 1.2073249e-10); r (10.256 * 2.73801, 2.8081008e+01); r (10.4095e1 * 2.73801, 2.8501293e+02); r (10.256e+0 * 2.73801, 2.8081008e+01); r (10.32768e-0000 * 2.73801, 2.8277282e+01); r (10.32768e4 * 2.73801, 2.8277268e+05); r (10.256e+10 * 2.73801, 2.8081016e+11); r (10.255e-16 * 2.73801, 2.8078280e-15); r (10.255e64 * 2.73801, 2.8078279e+65); r (10.255e+00011 * 2.73801, 2.8078285e+12); r (16.256 * 2.73801, 4.4509063e+01); r (16.10000e-1 * 2.73801, 4.4081935e+00); r (16.256e0 * 2.73801, 4.4509063e+01); r (16.255e+0000 * 2.73801, 4.4506301e+01); r (16.32768e-4 * 2.73801, 4.4705308e-03); r (16.32768e10 * 2.73801, 4.4705336e+11); r (16.32768e+16 * 2.73801, 4.4705338e+17); r (16.256e-64 * 2.73801, 4.4509059e-63); r (16.4095e00011 * 2.73801, 4.4929332e+12); r (64.32768 * 2.73801, 1.7612976e+02); r (64.256e+1 * 2.73801, 1.7593347e+03); r (64.4095e-0 * 2.73801, 1.7635377e+02); r (64.255e0000 * 2.73801, 1.7593075e+02); r (64.4095e+4 * 2.73801, 1.7635380e+06); r (64.10000e-10 * 2.73801, 1.7550632e-08); r (64.32768e16 * 2.73801, 1.7612977e+18); r (64.10000e+64 * 2.73801, 1.7550623e+66); r (64.10000e-00011 * 2.73801, 1.7550636e-09); r (00011.256 * 2.73801, 3.0819030e+01); r (00011.32768e1 * 2.73801, 3.1015283e+02); r (00011.255e+0 * 2.73801, 3.0816284e+01); r (00011.256e-0000 * 2.73801, 3.0819030e+01); r (00011.4095e4 * 2.73801, 3.1239318e+05); r (00011.32768e+10 * 2.73801, 3.1015279e+11); r (00011.10000e-16 * 2.73801, 3.0391900e-15); r (00011.10000e64 * 2.73801, 3.0391888e+65); r (00011.10000e+00011 * 2.73801, 3.0391884e+12); r (255.255 * 2.73801, 6.9889038e+02); r (255.256e-1 * 2.73801, 6.9889297e+01); r (255.10000e0 * 2.73801, 6.9846606e+02); r (255.256e+0000 * 2.73801, 6.9889331e+02); r (255.256e-4 * 2.73801, 6.9889307e-02); r (255.10000e10 * 2.73801, 6.9846612e+12); r (255.255e+16 * 2.73801, 6.9889038e+18); r (255.4095e-64 * 2.73801, 6.9931332e-62); r (255.10000e00011 * 2.73801, 6.9846586e+13); r (256.256 * 2.73801, 7.0163085e+02); r (256.10000e+1 * 2.73801, 7.0120390e+03); r (256.32768e-0 * 2.73801, 7.0182739e+02); r (256.32768e0000 * 2.73801, 7.0182739e+02); r (256.256e+4 * 2.73801, 7.0163130e+06); r (256.4095e-10 * 2.73801, 7.0205146e-08); r (256.4095e16 * 2.73801, 7.0205136e+18); r (256.256e+64 * 2.73801, 7.0163125e+66); r (256.10000e-00011 * 2.73801, 7.0120407e-09); r (4095.4095 * 2.73801, 1.1213269e+04); r (4095.32768e1 * 2.73801, 1.1213043e+05); r (4095.255e+0 * 2.73801, 1.1212843e+04); r (4095.255e-0000 * 2.73801, 1.1212843e+04); r (4095.10000e4 * 2.73801, 1.1212419e+08); r (4095.32768e+10 * 2.73801, 1.1213042e+14); r (4095.10000e-16 * 2.73801, 1.1212419e-12); r (4095.10000e64 * 2.73801, 1.1212414e+68); r (4095.10000e+00011 * 2.73801, 1.1212417e+15); r (10000.255 * 2.73801, 2.7380789e+04); r (10000.255e-1 * 2.73801, 2.7380788e+03); r (10000.10000e0 * 2.73801, 2.7380359e+04); r (10000.4095e+0000 * 2.73801, 2.7381203e+04); r (10000.4095e-4 * 2.73801, 2.7381181e+00); r (10000.255e10 * 2.73801, 2.7380788e+14); r (10000.256e+16 * 2.73801, 2.7380793e+20); r (10000.32768e-64 * 2.73801, 2.7380974e-60); r (10000.255e00011 * 2.73801, 2.7380789e+15); r (32768.10000 * 2.73801, 8.9719312e+04); r (32768.255e+1 * 2.73801, 8.9719775e+05); r (32768.4095e-0 * 2.73801, 8.9720187e+04); r (32768.256e0000 * 2.73801, 8.9719750e+04); r (32768.256e+4 * 2.73801, 8.9719782e+08); r (32768.4095e-10 * 2.73801, 8.9720188e-06); r (32768.256e16 * 2.73801, 8.9719754e+20); r (32768.32768e+64 * 2.73801, 8.9719984e+68); r (32768.10000e-00011 * 2.73801, 8.9719361e-07); r (131001.32768 * 2.73801, 3.5868281e+05); r (131001.256e1 * 2.73801, 3.5868250e+06); r (131001.4095e+0 * 2.73801, 3.5868300e+05); r (131001.4095e-0000 * 2.73801, 3.5868300e+05); r (131001.255e4 * 2.73801, 3.5868262e+09); r (131001.255e+10 * 2.73801, 3.5868265e+15); r (131001.256e-16 * 2.73801, 3.5868252e-11); r (131001.4095e64 * 2.73801, 3.5868296e+69); r (131001.4095e+00011 * 2.73801, 3.5868302e+16); r (1000000000.256 * 2.73801, 2.7380093e+09); r (1000000000.256e-1 * 2.73801, 2.7380070e+08); r (1000000000.10000e0 * 2.73801, 2.7380093e+09); r (1000000000.255e+0000 * 2.73801, 2.7380093e+09); r (1000000000.256e-4 * 2.73801, 2.7380093e+05); r (1000000000.255e10 * 2.73801, 2.7380091e+19); r (1000000000.4095e+16 * 2.73801, 2.7380077e+25); r (1000000000.32768e-64 * 2.73801, 2.7380084e-55); r (1000000000.256e00011 * 2.73801, 2.7380089e+20); r (2147483646.10000 * 2.73801, 5.8798284e+09); r (2147483646.256e+1 * 2.73801, 5.8798292e+10); r (2147483646.4095e-0 * 2.73801, 5.8798284e+09); r (2147483646.256e0000 * 2.73801, 5.8798284e+09); r (2147483646.10000e+4 * 2.73801, 5.8798253e+13); r (2147483646.256e-10 * 2.73801, 5.8798289e-01); r (2147483646.10000e16 * 2.73801, 5.8798277e+25); r (2147483646.10000e+64 * 2.73801, 5.8798295e+73); r (2147483646.255e-00011 * 2.73801, 5.8798298e-02); r (1.131001 * 2.73801, 3.0966892e+00); r (1.131001e1 * 2.73801, 3.0966903e+01); r (1.1000000000e+0 * 2.73801, 3.0118083e+00); r (1.131001e-0000 * 2.73801, 3.0966892e+00); r (1.131001e4 * 2.73801, 3.0966906e+04); r (1.1000000000e+10 * 2.73801, 3.0118092e+10); r (1.2147483646e-16 * 2.73801, 3.3259913e-16); r (1.1000000000e64 * 2.73801, 3.0118099e+64); r (1.2147483646e+00011 * 2.73801, 3.3259906e+11); r (0.1000000000 * 2.73801, 2.7380079e-01); r (0.1000000000e-1 * 2.73801, 2.7380086e-02); r (0.2147483646e0 * 2.73801, 5.8798289e-01); r (0.1000000000e+0000 * 2.73801, 2.7380079e-01); r (0.1000000000e-4 * 2.73801, 2.7380083e-05); r (0.2147483646e10 * 2.73801, 5.8798284e+09); r (0.1000000000e+16 * 2.73801, 2.7380091e+15); r (0.1000000000e-64 * 2.73801, 2.7380081e-65); r (0.131001e00011 * 2.73801, 3.5868188e+10); r (0000.1000000000 * 2.73801, 2.7380079e-01); r (0000.1000000000e+1 * 2.73801, 2.7380084e+00); r (0000.2147483646e-0 * 2.73801, 5.8798289e-01); r (0000.131001e0000 * 2.73801, 3.5868191e-01); r (0000.2147483646e+4 * 2.73801, 5.8798281e+03); r (0000.131001e-10 * 2.73801, 3.5868197e-11); r (0000.2147483646e16 * 2.73801, 5.8798274e+15); r (0000.2147483646e+64 * 2.73801, 5.8798302e+63); r (0000.131001e-00011 * 2.73801, 3.5868174e-12); r (4.1000000000 * 2.73801, 1.1225836e+01); r (4.2147483646e1 * 2.73801, 1.1540017e+02); r (4.1000000000e+0 * 2.73801, 1.1225836e+01); r (4.131001e-0000 * 2.73801, 1.1310717e+01); r (4.2147483646e4 * 2.73801, 1.1540018e+05); r (4.1000000000e+10 * 2.73801, 1.1225831e+11); r (4.2147483646e-16 * 2.73801, 1.1540017e-15); r (4.1000000000e64 * 2.73801, 1.1225828e+65); r (4.2147483646e+00011 * 2.73801, 1.1540019e+12); r (10.1000000000 * 2.73801, 2.7653884e+01); r (10.1000000000e-1 * 2.73801, 2.7653875e+00); r (10.1000000000e0 * 2.73801, 2.7653884e+01); r (10.131001e+0000 * 2.73801, 2.7738769e+01); r (10.2147483646e-4 * 2.73801, 2.7968075e-03); r (10.2147483646e10 * 2.73801, 2.7968058e+11); r (10.131001e+16 * 2.73801, 2.7738761e+17); r (10.131001e-64 * 2.73801, 2.7738764e-63); r (10.2147483646e00011 * 2.73801, 2.7968069e+12); r (16.2147483646 * 2.73801, 4.4396102e+01); r (16.1000000000e+1 * 2.73801, 4.4081933e+02); r (16.2147483646e-0 * 2.73801, 4.4396102e+01); r (16.2147483646e0000 * 2.73801, 4.4396102e+01); r (16.1000000000e+4 * 2.73801, 4.4081931e+05); r (16.131001e-10 * 2.73801, 4.4166803e-09); r (16.131001e16 * 2.73801, 4.4166818e+17); r (16.131001e+64 * 2.73801, 4.4166812e+65); r (16.1000000000e-00011 * 2.73801, 4.4081938e-10); r (64.2147483646 * 2.73801, 1.7582055e+02); r (64.131001e1 * 2.73801, 1.7559121e+03); r (64.2147483646e+0 * 2.73801, 1.7582055e+02); r (64.131001e-0000 * 2.73801, 1.7559126e+02); r (64.1000000000e4 * 2.73801, 1.7550630e+06); r (64.1000000000e+10 * 2.73801, 1.7550635e+12); r (64.131001e-16 * 2.73801, 1.7559125e-14); r (64.1000000000e64 * 2.73801, 1.7550623e+66); r (64.131001e+00011 * 2.73801, 1.7559125e+13); r (00011.2147483646 * 2.73801, 3.0706069e+01); r (00011.131001e-1 * 2.73801, 3.0476779e+00); r (00011.131001e0 * 2.73801, 3.0476776e+01); r (00011.1000000000e+0000 * 2.73801, 3.0391891e+01); r (00011.2147483646e-4 * 2.73801, 3.0706080e-03); r (00011.1000000000e10 * 2.73801, 3.0391894e+11); r (00011.2147483646e+16 * 2.73801, 3.0706068e+17); r (00011.131001e-64 * 2.73801, 3.0476761e-63); r (00011.2147483646e00011 * 2.73801, 3.0706059e+12); r (255.131001 * 2.73801, 6.9855102e+02); r (255.2147483646e+1 * 2.73801, 6.9878007e+03); r (255.2147483646e-0 * 2.73801, 6.9878027e+02); r (255.1000000000e0000 * 2.73801, 6.9846606e+02); r (255.131001e+4 * 2.73801, 6.9855100e+06); r (255.131001e-10 * 2.73801, 6.9855104e-08); r (255.131001e16 * 2.73801, 6.9855074e+18); r (255.2147483646e+64 * 2.73801, 6.9878022e+66); r (255.2147483646e-00011 * 2.73801, 6.9878005e-09); r (256.1000000000 * 2.73801, 7.0120361e+02); r (256.131001e1 * 2.73801, 7.0128867e+03); r (256.2147483646e+0 * 2.73801, 7.0151782e+02); r (256.131001e-0000 * 2.73801, 7.0128857e+02); r (256.131001e4 * 2.73801, 7.0128900e+06); r (256.1000000000e+10 * 2.73801, 7.0120395e+12); r (256.131001e-16 * 2.73801, 7.0128852e-14); r (256.131001e64 * 2.73801, 7.0128897e+66); r (256.131001e+00011 * 2.73801, 7.0128863e+13); r (4095.2147483646 * 2.73801, 1.1212734e+04); r (4095.131001e-1 * 2.73801, 1.1212502e+03); r (4095.2147483646e0 * 2.73801, 1.1212734e+04); r (4095.1000000000e+0000 * 2.73801, 1.1212421e+04); r (4095.2147483646e-4 * 2.73801, 1.1212730e+00); r (4095.1000000000e10 * 2.73801, 1.1212418e+14); r (4095.2147483646e+16 * 2.73801, 1.1212735e+20); r (4095.2147483646e-64 * 2.73801, 1.1212734e-60); r (4095.1000000000e00011 * 2.73801, 1.1212417e+15); r (10000.131001 * 2.73801, 2.7380445e+04); r (10000.2147483646e+1 * 2.73801, 2.7380675e+05); r (10000.1000000000e-0 * 2.73801, 2.7380359e+04); r (10000.131001e0000 * 2.73801, 2.7380445e+04); r (10000.2147483646e+4 * 2.73801, 2.7380659e+08); r (10000.2147483646e-10 * 2.73801, 2.7380674e-06); r (10000.1000000000e16 * 2.73801, 2.7380364e+20); r (10000.131001e+64 * 2.73801, 2.7380447e+68); r (10000.1000000000e-00011 * 2.73801, 2.7380360e-07); r (32768.2147483646 * 2.73801, 8.9719625e+04); r (32768.2147483646e1 * 2.73801, 8.9719675e+05); r (32768.1000000000e+0 * 2.73801, 8.9719312e+04); r (32768.131001e-0000 * 2.73801, 8.9719437e+04); r (32768.1000000000e4 * 2.73801, 8.9719296e+08); r (32768.131001e+10 * 2.73801, 8.9719450e+14); r (32768.2147483646e-16 * 2.73801, 8.9719655e-12); r (32768.1000000000e64 * 2.73801, 8.9719325e+68); r (32768.131001e+00011 * 2.73801, 8.9719418e+15); r (131001.2147483646 * 2.73801, 3.5868243e+05); r (131001.1000000000e-1 * 2.73801, 3.5868222e+04); r (131001.2147483646e0 * 2.73801, 3.5868243e+05); r (131001.2147483646e+0000 * 2.73801, 3.5868243e+05); r (131001.131001e-4 * 2.73801, 3.5868225e+01); r (131001.2147483646e10 * 2.73801, 3.5868251e+15); r (131001.131001e+16 * 2.73801, 3.5868232e+21); r (131001.1000000000e-64 * 2.73801, 3.5868206e-59); r (131001.2147483646e00011 * 2.73801, 3.5868246e+16); r (1000000000.1000000000 * 2.73801, 2.7380093e+09); r (1000000000.2147483646e+1 * 2.73801, 2.7380088e+10); r (1000000000.1000000000e-0 * 2.73801, 2.7380093e+09); r (1000000000.1000000000e0000 * 2.73801, 2.7380093e+09); r (1000000000.131001e+4 * 2.73801, 2.7380080e+13); r (1000000000.131001e-10 * 2.73801, 2.7380079e-01); r (1000000000.2147483646e16 * 2.73801, 2.7380077e+25); r (1000000000.131001e+64 * 2.73801, 2.7380090e+73); r (1000000000.2147483646e-00011 * 2.73801, 2.7380086e-02); r (2147483646.2147483646 * 2.73801, 5.8798284e+09); r (2147483646.1000000000e1 * 2.73801, 5.8798292e+10); r (2147483646.131001e+0 * 2.73801, 5.8798284e+09); r (2147483646.2147483646e-0000 * 2.73801, 5.8798284e+09); r (2147483646.131001e4 * 2.73801, 5.8798253e+13); r (2147483646.131001e+10 * 2.73801, 5.8798293e+19); r (2147483646.1000000000e-16 * 2.73801, 5.8798298e-07); r (2147483646.1000000000e64 * 2.73801, 5.8798295e+73); r (2147483646.1000000000e+00011 * 2.73801, 5.8798293e+20); r (1e-1 * 2.73801, 2.7380079e-01); r (1e0 * 2.73801, 2.7380094e+00); r (1e+0000 * 2.73801, 2.7380094e+00); r (1e-4 * 2.73801, 2.7380068e-04); r (1e10 * 2.73801, 2.7380088e+10); r (1e+16 * 2.73801, 2.7380085e+16); r (1e-64 * 2.73801, 2.7380084e-64); r (1e00011 * 2.73801, 2.7380075e+11); r (0e+1 * 2.73801, 0.0000000e+00); r (0e-0 * 2.73801, 0.0000000e+00); r (0e0000 * 2.73801, 0.0000000e+00); r (0e+4 * 2.73801, 0.0000000e+00); r (0e-10 * 2.73801, 0.0000000e+00); r (0e16 * 2.73801, 0.0000000e+00); r (0e+64 * 2.73801, 0.0000000e+00); r (0e-00011 * 2.73801, 0.0000000e+00); r (0000e1 * 2.73801, 0.0000000e+00); r (0000e+0 * 2.73801, 0.0000000e+00); r (0000e-0000 * 2.73801, 0.0000000e+00); r (0000e4 * 2.73801, 0.0000000e+00); r (0000e+10 * 2.73801, 0.0000000e+00); r (0000e-16 * 2.73801, 0.0000000e+00); r (0000e64 * 2.73801, 0.0000000e+00); r (0000e+00011 * 2.73801, 0.0000000e+00); r (4e-1 * 2.73801, 1.0952033e+00); r (4e0 * 2.73801, 1.0952037e+01); r (4e+0000 * 2.73801, 1.0952037e+01); r (4e-4 * 2.73801, 1.0952029e-03); r (4e10 * 2.73801, 1.0952035e+11); r (4e+16 * 2.73801, 1.0952036e+17); r (4e-64 * 2.73801, 1.0952035e-63); r (4e00011 * 2.73801, 1.0952036e+12); r (10e+1 * 2.73801, 2.7380078e+02); r (10e-0 * 2.73801, 2.7380081e+01); r (10e0000 * 2.73801, 2.7380081e+01); r (10e+4 * 2.73801, 2.7380093e+05); r (10e-10 * 2.73801, 2.7380089e-09); r (10e16 * 2.73801, 2.7380079e+17); r (10e+64 * 2.73801, 2.7380085e+65); r (10e-00011 * 2.73801, 2.7380075e-10); r (16e1 * 2.73801, 4.3808129e+02); r (16e+0 * 2.73801, 4.3808151e+01); r (16e-0000 * 2.73801, 4.3808151e+01); r (16e4 * 2.73801, 4.3808150e+05); r (16e+10 * 2.73801, 4.3808142e+11); r (16e-16 * 2.73801, 4.3808137e-15); r (16e64 * 2.73801, 4.3808124e+65); r (16e+00011 * 2.73801, 4.3808121e+12); r (64e-1 * 2.73801, 1.7523254e+01); r (64e0 * 2.73801, 1.7523260e+02); r (64e+0000 * 2.73801, 1.7523260e+02); r (64e-4 * 2.73801, 1.7523247e-02); r (64e10 * 2.73801, 1.7523256e+12); r (64e+16 * 2.73801, 1.7523257e+18); r (64e-64 * 2.73801, 1.7523256e-62); r (64e00011 * 2.73801, 1.7523257e+13); r (00011e+1 * 2.73801, 3.0118090e+02); r (00011e-0 * 2.73801, 3.0118103e+01); r (00011e0000 * 2.73801, 3.0118103e+01); r (00011e+4 * 2.73801, 3.0118100e+05); r (00011e-10 * 2.73801, 3.0118099e-09); r (00011e16 * 2.73801, 3.0118090e+17); r (00011e+64 * 2.73801, 3.0118076e+65); r (00011e-00011 * 2.73801, 3.0118085e-10); r (255e1 * 2.73801, 6.9819218e+03); r (255e+0 * 2.73801, 6.9819238e+02); r (255e-0000 * 2.73801, 6.9819238e+02); r (255e4 * 2.73801, 6.9819240e+06); r (255e+10 * 2.73801, 6.9819223e+12); r (255e-16 * 2.73801, 6.9819204e-14); r (255e64 * 2.73801, 6.9819192e+66); r (255e+00011 * 2.73801, 6.9819206e+13); r (256e-1 * 2.73801, 7.0093002e+01); r (256e0 * 2.73801, 7.0093041e+02); r (256e+0000 * 2.73801, 7.0093041e+02); r (256e-4 * 2.73801, 7.0092976e-02); r (256e10 * 2.73801, 7.0093027e+12); r (256e+16 * 2.73801, 7.0093019e+18); r (256e-64 * 2.73801, 7.0093016e-62); r (256e00011 * 2.73801, 7.0092993e+13); r (4095e+1 * 2.73801, 1.1212143e+05); r (4095e-0 * 2.73801, 1.1212148e+04); r (4095e0000 * 2.73801, 1.1212148e+04); r (4095e+4 * 2.73801, 1.1212147e+08); r (4095e-10 * 2.73801, 1.1212141e-06); r (4095e16 * 2.73801, 1.1212147e+20); r (4095e+64 * 2.73801, 1.1212141e+68); r (4095e-00011 * 2.73801, 1.1212148e-07); r (10000e1 * 2.73801, 2.7380093e+05); r (10000e+0 * 2.73801, 2.7380093e+04); r (10000e-0000 * 2.73801, 2.7380093e+04); r (10000e4 * 2.73801, 2.7380070e+08); r (10000e+10 * 2.73801, 2.7380091e+14); r (10000e-16 * 2.73801, 2.7380077e-12); r (10000e64 * 2.73801, 2.7380090e+68); r (10000e+00011 * 2.73801, 2.7380091e+15); r (32768e-1 * 2.73801, 8.9719062e+03); r (32768e0 * 2.73801, 8.9719062e+04); r (32768e+0000 * 2.73801, 8.9719062e+04); r (32768e-4 * 2.73801, 8.9719066e+00); r (32768e10 * 2.73801, 8.9719075e+14); r (32768e+16 * 2.73801, 8.9719051e+20); r (32768e-64 * 2.73801, 8.9719091e-60); r (32768e00011 * 2.73801, 8.9719075e+15); r (131001e+1 * 2.73801, 3.5868190e+06); r (131001e-0 * 2.73801, 3.5868193e+05); r (131001e0000 * 2.73801, 3.5868193e+05); r (131001e+4 * 2.73801, 3.5868193e+09); r (131001e-10 * 2.73801, 3.5868186e-05); r (131001e16 * 2.73801, 3.5868193e+21); r (131001e+64 * 2.73801, 3.5868185e+69); r (131001e-00011 * 2.73801, 3.5868188e-06); r (1000000000e1 * 2.73801, 2.7380088e+10); r (1000000000e+0 * 2.73801, 2.7380093e+09); r (1000000000e-0000 * 2.73801, 2.7380093e+09); r (1000000000e4 * 2.73801, 2.7380080e+13); r (1000000000e+10 * 2.73801, 2.7380091e+19); r (1000000000e-16 * 2.73801, 2.7380082e-07); r (1000000000e64 * 2.73801, 2.7380090e+73); r (1000000000e+00011 * 2.73801, 2.7380089e+20); r (2147483646e-1 * 2.73801, 5.8798284e+08); r (2147483646e0 * 2.73801, 5.8798284e+09); r (2147483646e+0000 * 2.73801, 5.8798284e+09); r (2147483646e-4 * 2.73801, 5.8798287e+05); r (2147483646e10 * 2.73801, 5.8798293e+19); r (2147483646e+16 * 2.73801, 5.8798277e+25); r (2147483646e-64 * 2.73801, 5.8798303e-55); r (2147483646e00011 * 2.73801, 5.8798293e+20); print ((ctr, " tests real ", (ctr = vf | "ok" | "error"), newline, "mean rel.differ. : ", fixed (erc / ct, 0, 9), newline, "max rel diff : ", fixed (super, 0, 9)))) ## ## ## algol68g-2.8/test-set/a68g.mc.133.scop08.a680000644000175000001440000000100212224301257014565 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #scop08# BEGIN # Scope error # BEGIN (REF REF INT p) VOID: (p := LOC INT := 3; print (p)) END (LOC REF INT) ENDalgol68g-2.8/test-set/a68g.mc.171.stow08.a680000644000175000001440000000230612224301275014627 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #stow08# BEGIN # Test king size indices and midget slices # INT i := 0; WHILE i <= (maxint - 1) OVER 2 DO INT maxdex = i := 2 * i + 1; INT mindex = -maxdex; print ((newline, "Bounds: ", maxdex, mindex, newline)); [maxdex : maxdex] REAL maxvec; maxvec[maxdex] := 1; print (("Bounds of maxvec: ", LWB maxvec, UPB maxvec, newline)); [mindex : mindex] REAL minvec; minvec[mindex] := 1; print (("Bounds of minvec: ", LWB minvec, UPB minvec, newline)); HEAP [maxdex : mindex] REAL flatvec; print (("Bounds of flatvec:", LWB flatvec, UPB flatvec, newline)); REF [] REAL u := flatvec; HEAP [1] REAL v; v[LWB u : UPB u@LWB u] := u OD ENDalgol68g-2.8/test-set/a68g.mc.134.scop09.a680000644000175000001440000000142612224301257014601 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #scop09# BEGIN # Scope error # print (("Need not run", newline)); PROC VOID pv = (MODE M = INT; VOID: HEAP M # actual declarer # ); PROC VOID qw = (MODE M = [1 : a] INT; INT a = 1; VOID: HEAP M # actual declarer # ); pv; qw ENDalgol68g-2.8/test-set/a68g.mc.130.scop05.a680000644000175000001440000000157312224301257014574 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #scop05# # No scope error # ([8] REF [] INT a; FOR i TO UPB a # non-local # WHILE PRIO + = 3; TRUE # non-local # DO # non-local # CASE UNION (INT, REAL) (i) # non-local # IN (INT k): # non-local # BEGIN l: # non-local # a[k] := LOC [k] INT; FOR i TO k DO a[k][i] := k + i OD END ESAC OD; print (("A triangle of integers, ascending downwards and to the right", newline)); FOR i TO UPB a DO print ((a[i], newline)) OD)algol68g-2.8/test-set/a68g.mc.104.numr08.a680000644000175000001440000000477712224301251014620 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #numr08# BEGIN #Test sqrt# PROC warn = (STRING s) VOID: BEGIN print ((newline, "++++test error: ", s, newline, newline)) END; REAL eps = 20.0 * smallreal; #moan if discrepancy is larger than this# REAL sumdelta := 0, sumsqdelta := 0, maxdelta := 0, at, INT count := 0; PROC test = (REAL r) VOID: BEGIN REAL s = sqrt (r); REAL t = s * s; REAL d = ABS ((r - t) / r); IF d > eps THEN print ("sqrt("); print (r); print (") = "); print (s); warn ("relative error in sqrt*sqrt exceeds 20*smallreal") ELSE REAL dd = d / smallreal; sumdelta +:= dd; sumsqdelta +:= dd * dd; count +:= 1; IF dd > maxdelta THEN maxdelta := dd; at := r FI FI END; REAL r := pi, REAL l = maxreal / 4; WHILE test (r); r < l DO r *:= pi OD; r := 1 / pi; WHILE test (r); REAL s = r; r /:= pi; r + r < s AND r /= 0 DO SKIP OD; IF REAL r = sqrt (0); r /= 0 THEN print ("sqrt(0)="); print (fixed (r, -(realwidth + 1), realwidth - 1)); warn ("sqrt(0) should be 0") FI; IF count /= 0 THEN print ((newline, "Except when indicated above,", newline, "Maximum relative error=smallreal*")); print (fixed (maxdelta, -(realwidth % 2 + 2), realwidth % 2)); print ((newline, "Average relative error=smallreal*")); print (fixed (sumdelta / count, -(realwidth % 2 + 2), realwidth % 2)); print ((newline, "R.M.S. relative error =smallreal*")); print (fixed (sqrt (sumdelta / count), -(realwidth % 2 + 2), realwidth % 2)); print (newline) FI ENDalgol68g-2.8/test-set/a68g.mc.094.null07.a680000644000175000001440000000062212224301247014606 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #null07# IF BOOL (SKIP) THEN SKIP FIalgol68g-2.8/test-set/a68g.mc.135.scop10.a680000644000175000001440000000137612224301257014576 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #scop10# BEGIN # No scope error # PROC VOID pv = (MODE M = INT; VOID: HEAP REF M # formal declarer # ); PROC VOID qw = (MODE M = [1 : a] INT; INT a = 1; VOID: HEAP REF M # formal declarer # ); pv; qw ENDalgol68g-2.8/test-set/a68g.mc.128.scop03.a680000644000175000001440000000105512224301256014573 00000000000000# This program is part of the Revised Mathematisch Centrum Algol 68 Test Set by Dick Grune [1979]. This program is distributed with Algol 68 Genie with kind permission of Dick Grune.' These test sets are available from: www.dickgrune.com/CS/Algol68 or from the Vrije Universiteit Amsterdam: ftp://ftp.cs.vu.nl/pub/dick/Algol68/ # PR quiet PR #scop03# BEGIN # No scope error # PROC VOID pv= (l: VOID: (MODE M1= [1:($n(( #l;# HEAP INT):= 3) "a" $; 1)] INT; M1 x:= 1; SKIP )); pv; print("End of test") END algol68g-2.8/depcomp0000755000175000001440000004271311551405127011310 00000000000000#! /bin/sh # depcomp - compile a program generating dependencies as side-effects scriptversion=2007-03-29.01 # Copyright (C) 1999, 2000, 2003, 2004, 2005, 2006, 2007 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 2, 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, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA # 02110-1301, USA. # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Originally written by Alexandre Oliva . case $1 in '') echo "$0: No command. Try \`$0 --help' for more information." 1>&2 exit 1; ;; -h | --h*) cat <<\EOF Usage: depcomp [--help] [--version] PROGRAM [ARGS] Run PROGRAMS ARGS to compile a file, generating dependencies as side-effects. Environment variables: depmode Dependency tracking mode. source Source file read by `PROGRAMS ARGS'. object Object file output by `PROGRAMS ARGS'. DEPDIR directory where to store dependencies. depfile Dependency file to output. tmpdepfile Temporary file to use when outputing dependencies. libtool Whether libtool is used (yes/no). Report bugs to . EOF exit $? ;; -v | --v*) echo "depcomp $scriptversion" exit $? ;; esac if test -z "$depmode" || test -z "$source" || test -z "$object"; then echo "depcomp: Variables source, object and depmode must be set" 1>&2 exit 1 fi # Dependencies for sub/bar.o or sub/bar.obj go into sub/.deps/bar.Po. depfile=${depfile-`echo "$object" | sed 's|[^\\/]*$|'${DEPDIR-.deps}'/&|;s|\.\([^.]*\)$|.P\1|;s|Pobj$|Po|'`} tmpdepfile=${tmpdepfile-`echo "$depfile" | sed 's/\.\([^.]*\)$/.T\1/'`} rm -f "$tmpdepfile" # Some modes work just like other modes, but use different flags. We # parameterize here, but still list the modes in the big case below, # to make depend.m4 easier to write. Note that we *cannot* use a case # here, because this file can only contain one case statement. if test "$depmode" = hp; then # HP compiler uses -M and no extra arg. gccflag=-M depmode=gcc fi if test "$depmode" = dashXmstdout; then # This is just like dashmstdout with a different argument. dashmflag=-xM depmode=dashmstdout fi case "$depmode" in gcc3) ## gcc 3 implements dependency tracking that does exactly what ## we want. Yay! Note: for some reason libtool 1.4 doesn't like ## it if -MD -MP comes after the -MF stuff. Hmm. ## Unfortunately, FreeBSD c89 acceptance of flags depends upon ## the command line argument order; so add the flags where they ## appear in depend2.am. Note that the slowdown incurred here ## affects only configure: in makefiles, %FASTDEP% shortcuts this. for arg do case $arg in -c) set fnord "$@" -MT "$object" -MD -MP -MF "$tmpdepfile" "$arg" ;; *) set fnord "$@" "$arg" ;; esac shift # fnord shift # $arg done "$@" stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi mv "$tmpdepfile" "$depfile" ;; gcc) ## There are various ways to get dependency output from gcc. Here's ## why we pick this rather obscure method: ## - Don't want to use -MD because we'd like the dependencies to end ## up in a subdir. Having to rename by hand is ugly. ## (We might end up doing this anyway to support other compilers.) ## - The DEPENDENCIES_OUTPUT environment variable makes gcc act like ## -MM, not -M (despite what the docs say). ## - Using -M directly means running the compiler twice (even worse ## than renaming). if test -z "$gccflag"; then gccflag=-MD, fi "$@" -Wp,"$gccflag$tmpdepfile" stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" echo "$object : \\" > "$depfile" alpha=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz ## The second -e expression handles DOS-style file names with drive letters. sed -e 's/^[^:]*: / /' \ -e 's/^['$alpha']:\/[^:]*: / /' < "$tmpdepfile" >> "$depfile" ## This next piece of magic avoids the `deleted header file' problem. ## The problem is that when a header file which appears in a .P file ## is deleted, the dependency causes make to die (because there is ## typically no way to rebuild the header). We avoid this by adding ## dummy dependencies for each header file. Too bad gcc doesn't do ## this for us directly. tr ' ' ' ' < "$tmpdepfile" | ## Some versions of gcc put a space before the `:'. On the theory ## that the space means something, we add a space to the output as ## well. ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; hp) # This case exists only to let depend.m4 do its work. It works by # looking at the text of this script. This case will never be run, # since it is checked for above. exit 1 ;; sgi) if test "$libtool" = yes; then "$@" "-Wp,-MDupdate,$tmpdepfile" else "$@" -MDupdate "$tmpdepfile" fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" if test -f "$tmpdepfile"; then # yes, the sourcefile depend on other files echo "$object : \\" > "$depfile" # Clip off the initial element (the dependent). Don't try to be # clever and replace this with sed code, as IRIX sed won't handle # lines with more than a fixed number of characters (4096 in # IRIX 6.2 sed, 8192 in IRIX 6.5). We also remove comment lines; # the IRIX cc adds comments like `#:fec' to the end of the # dependency line. tr ' ' ' ' < "$tmpdepfile" \ | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' | \ tr ' ' ' ' >> $depfile echo >> $depfile # The second pass generates a dummy entry for each header file. tr ' ' ' ' < "$tmpdepfile" \ | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' -e 's/$/:/' \ >> $depfile else # The sourcefile does not contain any dependencies, so just # store a dummy comment line, to avoid errors with the Makefile # "include basename.Plo" scheme. echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" ;; aix) # The C for AIX Compiler uses -M and outputs the dependencies # in a .u file. In older versions, this file always lives in the # current directory. Also, the AIX compiler puts `$object:' at the # start of each line; $object doesn't have directory information. # Version 6 uses the directory in both cases. dir=`echo "$object" | sed -e 's|/[^/]*$|/|'` test "x$dir" = "x$object" && dir= base=`echo "$object" | sed -e 's|^.*/||' -e 's/\.o$//' -e 's/\.lo$//'` if test "$libtool" = yes; then tmpdepfile1=$dir$base.u tmpdepfile2=$base.u tmpdepfile3=$dir.libs/$base.u "$@" -Wc,-M else tmpdepfile1=$dir$base.u tmpdepfile2=$dir$base.u tmpdepfile3=$dir$base.u "$@" -M fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" do test -f "$tmpdepfile" && break done if test -f "$tmpdepfile"; then # Each line is of the form `foo.o: dependent.h'. # Do two passes, one to just change these to # `$object: dependent.h' and one to simply `dependent.h:'. sed -e "s,^.*\.[a-z]*:,$object:," < "$tmpdepfile" > "$depfile" # That's a tab and a space in the []. sed -e 's,^.*\.[a-z]*:[ ]*,,' -e 's,$,:,' < "$tmpdepfile" >> "$depfile" else # The sourcefile does not contain any dependencies, so just # store a dummy comment line, to avoid errors with the Makefile # "include basename.Plo" scheme. echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" ;; icc) # Intel's C compiler understands `-MD -MF file'. However on # icc -MD -MF foo.d -c -o sub/foo.o sub/foo.c # ICC 7.0 will fill foo.d with something like # foo.o: sub/foo.c # foo.o: sub/foo.h # which is wrong. We want: # sub/foo.o: sub/foo.c # sub/foo.o: sub/foo.h # sub/foo.c: # sub/foo.h: # ICC 7.1 will output # foo.o: sub/foo.c sub/foo.h # and will wrap long lines using \ : # foo.o: sub/foo.c ... \ # sub/foo.h ... \ # ... "$@" -MD -MF "$tmpdepfile" stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" # Each line is of the form `foo.o: dependent.h', # or `foo.o: dep1.h dep2.h \', or ` dep3.h dep4.h \'. # Do two passes, one to just change these to # `$object: dependent.h' and one to simply `dependent.h:'. sed "s,^[^:]*:,$object :," < "$tmpdepfile" > "$depfile" # Some versions of the HPUX 10.20 sed can't process this invocation # correctly. Breaking it into two sed invocations is a workaround. sed 's,^[^:]*: \(.*\)$,\1,;s/^\\$//;/^$/d;/:$/d' < "$tmpdepfile" | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; hp2) # The "hp" stanza above does not work with aCC (C++) and HP's ia64 # compilers, which have integrated preprocessors. The correct option # to use with these is +Maked; it writes dependencies to a file named # 'foo.d', which lands next to the object file, wherever that # happens to be. # Much of this is similar to the tru64 case; see comments there. dir=`echo "$object" | sed -e 's|/[^/]*$|/|'` test "x$dir" = "x$object" && dir= base=`echo "$object" | sed -e 's|^.*/||' -e 's/\.o$//' -e 's/\.lo$//'` if test "$libtool" = yes; then tmpdepfile1=$dir$base.d tmpdepfile2=$dir.libs/$base.d "$@" -Wc,+Maked else tmpdepfile1=$dir$base.d tmpdepfile2=$dir$base.d "$@" +Maked fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile1" "$tmpdepfile2" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" do test -f "$tmpdepfile" && break done if test -f "$tmpdepfile"; then sed -e "s,^.*\.[a-z]*:,$object:," "$tmpdepfile" > "$depfile" # Add `dependent.h:' lines. sed -ne '2,${; s/^ *//; s/ \\*$//; s/$/:/; p;}' "$tmpdepfile" >> "$depfile" else echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" "$tmpdepfile2" ;; tru64) # The Tru64 compiler uses -MD to generate dependencies as a side # effect. `cc -MD -o foo.o ...' puts the dependencies into `foo.o.d'. # At least on Alpha/Redhat 6.1, Compaq CCC V6.2-504 seems to put # dependencies in `foo.d' instead, so we check for that too. # Subdirectories are respected. dir=`echo "$object" | sed -e 's|/[^/]*$|/|'` test "x$dir" = "x$object" && dir= base=`echo "$object" | sed -e 's|^.*/||' -e 's/\.o$//' -e 's/\.lo$//'` if test "$libtool" = yes; then # With Tru64 cc, shared objects can also be used to make a # static library. This mechanism is used in libtool 1.4 series to # handle both shared and static libraries in a single compilation. # With libtool 1.4, dependencies were output in $dir.libs/$base.lo.d. # # With libtool 1.5 this exception was removed, and libtool now # generates 2 separate objects for the 2 libraries. These two # compilations output dependencies in $dir.libs/$base.o.d and # in $dir$base.o.d. We have to check for both files, because # one of the two compilations can be disabled. We should prefer # $dir$base.o.d over $dir.libs/$base.o.d because the latter is # automatically cleaned when .libs/ is deleted, while ignoring # the former would cause a distcleancheck panic. tmpdepfile1=$dir.libs/$base.lo.d # libtool 1.4 tmpdepfile2=$dir$base.o.d # libtool 1.5 tmpdepfile3=$dir.libs/$base.o.d # libtool 1.5 tmpdepfile4=$dir.libs/$base.d # Compaq CCC V6.2-504 "$@" -Wc,-MD else tmpdepfile1=$dir$base.o.d tmpdepfile2=$dir$base.d tmpdepfile3=$dir$base.d tmpdepfile4=$dir$base.d "$@" -MD fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" "$tmpdepfile4" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" "$tmpdepfile4" do test -f "$tmpdepfile" && break done if test -f "$tmpdepfile"; then sed -e "s,^.*\.[a-z]*:,$object:," < "$tmpdepfile" > "$depfile" # That's a tab and a space in the []. sed -e 's,^.*\.[a-z]*:[ ]*,,' -e 's,$,:,' < "$tmpdepfile" >> "$depfile" else echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" ;; #nosideeffect) # This comment above is used by automake to tell side-effect # dependency tracking mechanisms from slower ones. dashmstdout) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout, regardless of -o. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test $1 != '--mode=compile'; do shift done shift fi # Remove `-o $object'. IFS=" " for arg do case $arg in -o) shift ;; $object) shift ;; *) set fnord "$@" "$arg" shift # fnord shift # $arg ;; esac done test -z "$dashmflag" && dashmflag=-M # Require at least two characters before searching for `:' # in the target name. This is to cope with DOS-style filenames: # a dependency such as `c:/foo/bar' could be seen as target `c' otherwise. "$@" $dashmflag | sed 's:^[ ]*[^: ][^:][^:]*\:[ ]*:'"$object"'\: :' > "$tmpdepfile" rm -f "$depfile" cat < "$tmpdepfile" > "$depfile" tr ' ' ' ' < "$tmpdepfile" | \ ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; dashXmstdout) # This case only exists to satisfy depend.m4. It is never actually # run, as this mode is specially recognized in the preamble. exit 1 ;; makedepend) "$@" || exit $? # Remove any Libtool call if test "$libtool" = yes; then while test $1 != '--mode=compile'; do shift done shift fi # X makedepend shift cleared=no for arg in "$@"; do case $cleared in no) set ""; shift cleared=yes ;; esac case "$arg" in -D*|-I*) set fnord "$@" "$arg"; shift ;; # Strip any option that makedepend may not understand. Remove # the object too, otherwise makedepend will parse it as a source file. -*|$object) ;; *) set fnord "$@" "$arg"; shift ;; esac done obj_suffix="`echo $object | sed 's/^.*\././'`" touch "$tmpdepfile" ${MAKEDEPEND-makedepend} -o"$obj_suffix" -f"$tmpdepfile" "$@" rm -f "$depfile" cat < "$tmpdepfile" > "$depfile" sed '1,2d' "$tmpdepfile" | tr ' ' ' ' | \ ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" "$tmpdepfile".bak ;; cpp) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test $1 != '--mode=compile'; do shift done shift fi # Remove `-o $object'. IFS=" " for arg do case $arg in -o) shift ;; $object) shift ;; *) set fnord "$@" "$arg" shift # fnord shift # $arg ;; esac done "$@" -E | sed -n -e '/^# [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' \ -e '/^#line [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' | sed '$ s: \\$::' > "$tmpdepfile" rm -f "$depfile" echo "$object : \\" > "$depfile" cat < "$tmpdepfile" >> "$depfile" sed < "$tmpdepfile" '/^$/d;s/^ //;s/ \\$//;s/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; msvisualcpp) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout, regardless of -o, # because we must use -o when running libtool. "$@" || exit $? IFS=" " for arg do case "$arg" in "-Gm"|"/Gm"|"-Gi"|"/Gi"|"-ZI"|"/ZI") set fnord "$@" shift shift ;; *) set fnord "$@" "$arg" shift shift ;; esac done "$@" -E | sed -n '/^#line [0-9][0-9]* "\([^"]*\)"/ s::echo "`cygpath -u \\"\1\\"`":p' | sort | uniq > "$tmpdepfile" rm -f "$depfile" echo "$object : \\" > "$depfile" . "$tmpdepfile" | sed 's% %\\ %g' | sed -n '/^\(.*\)$/ s:: \1 \\:p' >> "$depfile" echo " " >> "$depfile" . "$tmpdepfile" | sed 's% %\\ %g' | sed -n '/^\(.*\)$/ s::\1\::p' >> "$depfile" rm -f "$tmpdepfile" ;; none) exec "$@" ;; *) echo "Unknown depmode $depmode" 1>&2 exit 1 ;; esac exit 0 # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-end: "$" # End: algol68g-2.8/doc/0000777000175000001440000000000012224301437010552 500000000000000algol68g-2.8/doc/a68g.10000644000175000001440000001562112224300717011322 00000000000000.Dd October 6, 2013 .Dt A68G 1 PRM .Os LINUX . .Sh NAME a68g \- Algol 68 Genie, an Algol 68 compiler-interpreter . .Sh SYNOPSIS a68g .Op Fl -apropos | -help | -info Ar [string] .Op Fl -assertions | Fl -no-assertions .Op Fl -backtrace | Fl -no-backtrace .Op Fl -brackets .Op Fl -check | Fl -no-run .Op Fl -compile | Fl -no-compile .Op Fl -clock .Op Fl -debug | Fl -monitor .Op Fl -echo Ar string .Op Fl -execute Ar unit | -x Ar unit .Op Fl -exit | Fl - .Op Fl -extensive .Op Fl f | Fl -file Ar string .Op Fl -frame Ar number .Op Fl -handles Ar number .Op Fl -heap Ar number .Op Fl -listing .Op Fl -moids .Op Fl O | Fl O0 | Fl O1 | Fl O2 | Fl O3 .Op Fl -object | Fl -no-object .Op Fl -overhead Ar number .Op Fl -optimise | Fl -no-optimise .Op Fl -pedantic .Op Fl -portcheck | -no-portcheck .Op Fl -pragmats | Fl -no-pragmats .Op Fl -precision Ar number .Op Fl -prelude-listing .Op Fl -pretty-print .Op Fl -print Ar unit | -p Ar unit .Op Fl -quiet .Op Fl -quote-stropping .Op Fl -reductions .Op Fl -rerun .Op Fl -run .Op Fl -script Ar string .Op Fl -source | Fl -no-source .Op Fl -stack Ar number .Op Fl -statistics .Op Fl -strict .Op Fl -terminal .Op Fl -time-limit Ar number .Op Fl -trace | Fl -no-trace .Op Fl -tree | Fl -no-tree .Op Fl -unused .Op Fl -upper-stropping .Op Fl -verbose .Op Fl -version .Op Fl -warnings | Fl -no-warnings .Op Fl -xref | Fl -no-xref .Ar filename . .Sh DESCRIPTION Algol 68 Genie (Algol68G) is an Algol 68 compiler-interpreter. It can be used for executing Algol 68 programs or scripts. Algol 68 is a rather lean orthogonal general-purpose language that is a beautiful means for denoting algorithms. Algol 68 was designed as a general-purpose programming language by IFIP Working Group 2.1 (Algorithmic Languages and Calculi) that has continuing responsibility for Algol 60 and Algol 68. .Pp Algol 68 Genie and its documentation can be obtained from .Pp http://jmvdveer.home.xs4all.nl/ . .Sh OPTIONS Options are passed to a68g either from the file .a68g.rc in the working directory, the environment variable A68G_OPTIONS, the command-line or from pragmats. .Pp Option precedence is as follows: pragmat options supersede command-line options, command-line options supersede options in environment variable A68G_OPTIONS, A68G_OPTIONS supersedes options in .a68g.rc. .Pp Listing options, tracing options and -pragmat, -nopragmat, take their effect when they are encountered in a left-to-right pass of the program text, and can thus be used, for example, to generate a cross reference for a particular part of the program. .Pp Where numeric arguments are required, suffices k, M or G are allowed for multiplication with 2 ** 10, 2 ** 20 or 2 ** 30 respectively. .Bl -tag -width Ds . .It Fl -apropos | -help | -info Ar [string] Print info on options if string is omitted, or print info on string otherwise. . .It Fl -assertions | Fl -no-assertions Control elaboration of assertions. . .It Fl -backtrace | Fl -no-backtrace Control whether a stack backtrace is done in case a runtime-error occurs. . .It Fl -brackets Consider [ .. ] and { .. } as being equivalent to ( .. ). Traditional Algol 68 syntax allows ( .. ) to replace [ .. ] in bounds and slices. . .It Fl -check | Fl -no-run Check syntax only, the interpreter does not start. . .It Fl -clock Report execution time excluding time needed for compilation. . .It Fl -compile | -no-compile Switch compilation of units on or off. Compilation omits many of the runtime checks offered by the interpreter proper. The program is not executed and a shell script is generated combining source code and its shared library. This shell script can be used as a pseudo-executable. . .It Fl -debug | Fl -monitor Start in the monitor. Invoke the monitor in case a runtime-error occurs; the program will pause in the monitor on the line that contains the error. . .It Fl -echo Ar string Echo string to standout. . .It Fl -execute Ar unit | Fl -x Ar unit Execute the Algol 68 unit. In this way one-liners can be executed from the command line. . .It Fl -exit | - Ignore further options. . .It Fl -extensive Generate an extensive listing. . .It Fl f | -file Ar string Accept string as filename in case it conflicts with shell syntax. . .It Fl -frame Ar number Set the frame stack size to .Ar number bytes. . .It Fl -handles Ar number Set the handle space size to .Ar number bytes. . .It Fl -heap Ar number Set the heap size to .Ar number bytes. . .It Fl -listing Generate a concise listing. . .It Fl -moids Generate an overview of modes in the listing file. . .It Fl -object | Fl -no-object Control the listing of C code in the listing file. . .It Fl -optimise | -no-optimise Switch compilation of units on or off. Compilation omits many of the runtime checks offered by the interpreter proper. This option is equivalent to -O2. . .It Fl O | O0 | O1 | O2 | O3 Switch compilation of units on and pass the option to the back-end C compiler to set the optimiser level. . .It Fl -overhead Ar number Set overhead for stack checking. . .It Fl -pedantic Equivalent to --warnings --portcheck . .It Fl -portcheck | Fl -no-portcheck Enable or disable portability warning messages. . .It Fl -pragmats | Fl -no-pragmats Control elaboration of pragmats. . .It Fl -precision Ar number Set the precision for LONG LONG modes to .Ar number significant digits. . .It Fl -prelude-listing Generate a listing of preludes. . .It Fl -pretty-print Pretty-print the source file. . .It Fl -print Ar unit | Fl -p Ar unit Print the value yielded by the Algol 68 unit. In this way one-liners can be executed from the command line. . .It Fl -quiet Suppress all warning messages. . .It Fl -quote-stropping Use quote stropping. . .It Fl -reductions Print reductions made by the parser. . .It Fl -rerun Use compiled code of a previous run. . .It Fl -run Override the --no-run option. . .It Fl -script Ar string Takes string as source file name and skips further option processing so these can be handled by the script. . .It Fl -source | Fl -no-source Control the listing of source lines in the listing file. . .It Fl -stack Ar number Set the stack size to .Ar number bytes. . .It Fl -statistics Generate statistics in the listing file. . .It Fl -strict Ignores extensions to Algol 68 syntax. . .It Fl -time-limit Ar number Interrupt the interpreter after .Ar number seconds, generating a time limit exceeded error. . .It Fl -trace | Fl -no-trace Control tracing of the running program. . .It Fl -tree | Fl -no-tree Control listing of the syntax tree in the listing file. . .It Fl -unused Generate an overview of unused tags in the listing file. . .It Fl -upper-stropping Use upper stropping, which is the default stropping regime. . .It Fl -verbose Use verbose mode. . .It Fl -version Print the version of the running image of a68g. . .It Fl -warnings | Fl -no-warnings Enable warning messages or suppress suppressible warning messages. . .It Fl -xref | Fl -no-xref Control generation of a cross-reference in the listing file. . .El . .Sh AUTHOR Author of Algol 68 Genie is Marcel van der Veer . algol68g-2.8/missing0000755000175000001440000002557711551405127011343 00000000000000#! /bin/sh # Common stub for a few missing GNU programs while installing. scriptversion=2006-05-10.23 # Copyright (C) 1996, 1997, 1999, 2000, 2002, 2003, 2004, 2005, 2006 # Free Software Foundation, Inc. # Originally by Fran,cois Pinard , 1996. # 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 2, 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, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA # 02110-1301, USA. # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. if test $# -eq 0; then echo 1>&2 "Try \`$0 --help' for more information" exit 1 fi run=: sed_output='s/.* --output[ =]\([^ ]*\).*/\1/p' sed_minuso='s/.* -o \([^ ]*\).*/\1/p' # In the cases where this matters, `missing' is being run in the # srcdir already. if test -f configure.ac; then configure_ac=configure.ac else configure_ac=configure.in fi msg="missing on your system" case $1 in --run) # Try to run requested program, and just exit if it succeeds. run= shift "$@" && exit 0 # Exit code 63 means version mismatch. This often happens # when the user try to use an ancient version of a tool on # a file that requires a minimum version. In this case we # we should proceed has if the program had been absent, or # if --run hadn't been passed. if test $? = 63; then run=: msg="probably too old" fi ;; -h|--h|--he|--hel|--help) echo "\ $0 [OPTION]... PROGRAM [ARGUMENT]... Handle \`PROGRAM [ARGUMENT]...' for when PROGRAM is missing, or return an error status if there is no known handling for PROGRAM. Options: -h, --help display this help and exit -v, --version output version information and exit --run try to run the given command, and emulate it if it fails Supported PROGRAM values: aclocal touch file \`aclocal.m4' autoconf touch file \`configure' autoheader touch file \`config.h.in' autom4te touch the output file, or create a stub one automake touch all \`Makefile.in' files bison create \`y.tab.[ch]', if possible, from existing .[ch] flex create \`lex.yy.c', if possible, from existing .c help2man touch the output file lex create \`lex.yy.c', if possible, from existing .c makeinfo touch the output file tar try tar, gnutar, gtar, then tar without non-portable flags yacc create \`y.tab.[ch]', if possible, from existing .[ch] Send bug reports to ." exit $? ;; -v|--v|--ve|--ver|--vers|--versi|--versio|--version) echo "missing $scriptversion (GNU Automake)" exit $? ;; -*) echo 1>&2 "$0: Unknown \`$1' option" echo 1>&2 "Try \`$0 --help' for more information" exit 1 ;; esac # Now exit if we have it, but it failed. Also exit now if we # don't have it and --version was passed (most likely to detect # the program). case $1 in lex|yacc) # Not GNU programs, they don't have --version. ;; tar) if test -n "$run"; then echo 1>&2 "ERROR: \`tar' requires --run" exit 1 elif test "x$2" = "x--version" || test "x$2" = "x--help"; then exit 1 fi ;; *) if test -z "$run" && ($1 --version) > /dev/null 2>&1; then # We have it, but it failed. exit 1 elif test "x$2" = "x--version" || test "x$2" = "x--help"; then # Could not run --version or --help. This is probably someone # running `$TOOL --version' or `$TOOL --help' to check whether # $TOOL exists and not knowing $TOOL uses missing. exit 1 fi ;; esac # If it does not exist, or fails to run (possibly an outdated version), # try to emulate it. case $1 in aclocal*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`acinclude.m4' or \`${configure_ac}'. You might want to install the \`Automake' and \`Perl' packages. Grab them from any GNU archive site." touch aclocal.m4 ;; autoconf) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`${configure_ac}'. You might want to install the \`Autoconf' and \`GNU m4' packages. Grab them from any GNU archive site." touch configure ;; autoheader) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`acconfig.h' or \`${configure_ac}'. You might want to install the \`Autoconf' and \`GNU m4' packages. Grab them from any GNU archive site." files=`sed -n 's/^[ ]*A[CM]_CONFIG_HEADER(\([^)]*\)).*/\1/p' ${configure_ac}` test -z "$files" && files="config.h" touch_files= for f in $files; do case $f in *:*) touch_files="$touch_files "`echo "$f" | sed -e 's/^[^:]*://' -e 's/:.*//'`;; *) touch_files="$touch_files $f.in";; esac done touch $touch_files ;; automake*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`Makefile.am', \`acinclude.m4' or \`${configure_ac}'. You might want to install the \`Automake' and \`Perl' packages. Grab them from any GNU archive site." find . -type f -name Makefile.am -print | sed 's/\.am$/.in/' | while read f; do touch "$f"; done ;; autom4te) echo 1>&2 "\ WARNING: \`$1' is needed, but is $msg. You might have modified some files without having the proper tools for further handling them. You can get \`$1' as part of \`Autoconf' from any GNU archive site." file=`echo "$*" | sed -n "$sed_output"` test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"` if test -f "$file"; then touch $file else test -z "$file" || exec >$file echo "#! /bin/sh" echo "# Created by GNU Automake missing as a replacement of" echo "# $ $@" echo "exit 0" chmod +x $file exit 1 fi ;; bison|yacc) echo 1>&2 "\ WARNING: \`$1' $msg. You should only need it if you modified a \`.y' file. You may need the \`Bison' package in order for those modifications to take effect. You can get \`Bison' from any GNU archive site." rm -f y.tab.c y.tab.h if test $# -ne 1; then eval LASTARG="\${$#}" case $LASTARG in *.y) SRCFILE=`echo "$LASTARG" | sed 's/y$/c/'` if test -f "$SRCFILE"; then cp "$SRCFILE" y.tab.c fi SRCFILE=`echo "$LASTARG" | sed 's/y$/h/'` if test -f "$SRCFILE"; then cp "$SRCFILE" y.tab.h fi ;; esac fi if test ! -f y.tab.h; then echo >y.tab.h fi if test ! -f y.tab.c; then echo 'main() { return 0; }' >y.tab.c fi ;; lex|flex) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified a \`.l' file. You may need the \`Flex' package in order for those modifications to take effect. You can get \`Flex' from any GNU archive site." rm -f lex.yy.c if test $# -ne 1; then eval LASTARG="\${$#}" case $LASTARG in *.l) SRCFILE=`echo "$LASTARG" | sed 's/l$/c/'` if test -f "$SRCFILE"; then cp "$SRCFILE" lex.yy.c fi ;; esac fi if test ! -f lex.yy.c; then echo 'main() { return 0; }' >lex.yy.c fi ;; help2man) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified a dependency of a manual page. You may need the \`Help2man' package in order for those modifications to take effect. You can get \`Help2man' from any GNU archive site." file=`echo "$*" | sed -n "$sed_output"` test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"` if test -f "$file"; then touch $file else test -z "$file" || exec >$file echo ".ab help2man is required to generate this page" exit 1 fi ;; makeinfo) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified a \`.texi' or \`.texinfo' file, or any other file indirectly affecting the aspect of the manual. The spurious call might also be the consequence of using a buggy \`make' (AIX, DU, IRIX). You might want to install the \`Texinfo' package or the \`GNU make' package. Grab either from any GNU archive site." # The file to touch is that specified with -o ... file=`echo "$*" | sed -n "$sed_output"` test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"` if test -z "$file"; then # ... or it is the one specified with @setfilename ... infile=`echo "$*" | sed 's/.* \([^ ]*\) *$/\1/'` file=`sed -n ' /^@setfilename/{ s/.* \([^ ]*\) *$/\1/ p q }' $infile` # ... or it is derived from the source name (dir/f.texi becomes f.info) test -z "$file" && file=`echo "$infile" | sed 's,.*/,,;s,.[^.]*$,,'`.info fi # If the file does not exist, the user really needs makeinfo; # let's fail without touching anything. test -f $file || exit 1 touch $file ;; tar) shift # We have already tried tar in the generic part. # Look for gnutar/gtar before invocation to avoid ugly error # messages. if (gnutar --version > /dev/null 2>&1); then gnutar "$@" && exit 0 fi if (gtar --version > /dev/null 2>&1); then gtar "$@" && exit 0 fi firstarg="$1" if shift; then case $firstarg in *o*) firstarg=`echo "$firstarg" | sed s/o//` tar "$firstarg" "$@" && exit 0 ;; esac case $firstarg in *h*) firstarg=`echo "$firstarg" | sed s/h//` tar "$firstarg" "$@" && exit 0 ;; esac fi echo 1>&2 "\ WARNING: I can't seem to be able to run \`tar' with the given arguments. You may want to install GNU tar or Free paxutils, or check the command line arguments." exit 1 ;; *) echo 1>&2 "\ WARNING: \`$1' is needed, and is $msg. You might have modified some files without having the proper tools for further handling them. Check the \`README' file, it often tells you about the needed prerequisites for installing this package. You may also peek at any GNU archive site, in case some other package would contain this missing \`$1' program." exit 1 ;; esac exit 0 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-end: "$" # End: algol68g-2.8/aclocal.m40000644000175000001440000010130512224300572011560 00000000000000# generated automatically by aclocal 1.10.1 -*- Autoconf -*- # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, # 2005, 2006, 2007, 2008 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl m4_if(AC_AUTOCONF_VERSION, [2.63],, [m4_warning([this file was generated for autoconf 2.63. You have another version of autoconf. It may work, but is not guaranteed to. If you have problems, you may need to regenerate the build system entirely. To do so, use the procedure documented by the package, typically `autoreconf'.])]) # Copyright (C) 2002, 2003, 2005, 2006, 2007 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_AUTOMAKE_VERSION(VERSION) # ---------------------------- # Automake X.Y traces this macro to ensure aclocal.m4 has been # generated from the m4 files accompanying Automake X.Y. # (This private macro should not be called outside this file.) AC_DEFUN([AM_AUTOMAKE_VERSION], [am__api_version='1.10' dnl Some users find AM_AUTOMAKE_VERSION and mistake it for a way to dnl require some minimum version. Point them to the right macro. m4_if([$1], [1.10.1], [], [AC_FATAL([Do not call $0, use AM_INIT_AUTOMAKE([$1]).])])dnl ]) # _AM_AUTOCONF_VERSION(VERSION) # ----------------------------- # aclocal traces this macro to find the Autoconf version. # This is a private macro too. Using m4_define simplifies # the logic in aclocal, which can simply ignore this definition. m4_define([_AM_AUTOCONF_VERSION], []) # AM_SET_CURRENT_AUTOMAKE_VERSION # ------------------------------- # Call AM_AUTOMAKE_VERSION and AM_AUTOMAKE_VERSION so they can be traced. # This function is AC_REQUIREd by AC_INIT_AUTOMAKE. AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], [AM_AUTOMAKE_VERSION([1.10.1])dnl m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl _AM_AUTOCONF_VERSION(AC_AUTOCONF_VERSION)]) # AM_AUX_DIR_EXPAND -*- Autoconf -*- # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets # $ac_aux_dir to `$srcdir/foo'. In other projects, it is set to # `$srcdir', `$srcdir/..', or `$srcdir/../..'. # # Of course, Automake must honor this variable whenever it calls a # tool from the auxiliary directory. The problem is that $srcdir (and # therefore $ac_aux_dir as well) can be either absolute or relative, # depending on how configure is run. This is pretty annoying, since # it makes $ac_aux_dir quite unusable in subdirectories: in the top # source directory, any form will work fine, but in subdirectories a # relative path needs to be adjusted first. # # $ac_aux_dir/missing # fails when called from a subdirectory if $ac_aux_dir is relative # $top_srcdir/$ac_aux_dir/missing # fails if $ac_aux_dir is absolute, # fails when called from a subdirectory in a VPATH build with # a relative $ac_aux_dir # # The reason of the latter failure is that $top_srcdir and $ac_aux_dir # are both prefixed by $srcdir. In an in-source build this is usually # harmless because $srcdir is `.', but things will broke when you # start a VPATH build or use an absolute $srcdir. # # So we could use something similar to $top_srcdir/$ac_aux_dir/missing, # iff we strip the leading $srcdir from $ac_aux_dir. That would be: # am_aux_dir='\$(top_srcdir)/'`expr "$ac_aux_dir" : "$srcdir//*\(.*\)"` # and then we would define $MISSING as # MISSING="\${SHELL} $am_aux_dir/missing" # This will work as long as MISSING is not called from configure, because # unfortunately $(top_srcdir) has no meaning in configure. # However there are other variables, like CC, which are often used in # configure, and could therefore not use this "fixed" $ac_aux_dir. # # Another solution, used here, is to always expand $ac_aux_dir to an # absolute PATH. The drawback is that using absolute paths prevent a # configured tree to be moved without reconfiguration. AC_DEFUN([AM_AUX_DIR_EXPAND], [dnl Rely on autoconf to set up CDPATH properly. AC_PREREQ([2.50])dnl # expand $ac_aux_dir to an absolute path am_aux_dir=`cd $ac_aux_dir && pwd` ]) # AM_CONDITIONAL -*- Autoconf -*- # Copyright (C) 1997, 2000, 2001, 2003, 2004, 2005, 2006 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 8 # AM_CONDITIONAL(NAME, SHELL-CONDITION) # ------------------------------------- # Define a conditional. AC_DEFUN([AM_CONDITIONAL], [AC_PREREQ(2.52)dnl ifelse([$1], [TRUE], [AC_FATAL([$0: invalid condition: $1])], [$1], [FALSE], [AC_FATAL([$0: invalid condition: $1])])dnl AC_SUBST([$1_TRUE])dnl AC_SUBST([$1_FALSE])dnl _AM_SUBST_NOTMAKE([$1_TRUE])dnl _AM_SUBST_NOTMAKE([$1_FALSE])dnl if $2; then $1_TRUE= $1_FALSE='#' else $1_TRUE='#' $1_FALSE= fi AC_CONFIG_COMMANDS_PRE( [if test -z "${$1_TRUE}" && test -z "${$1_FALSE}"; then AC_MSG_ERROR([[conditional "$1" was never defined. Usually this means the macro was only invoked conditionally.]]) fi])]) # Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 9 # There are a few dirty hacks below to avoid letting `AC_PROG_CC' be # written in clear, in which case automake, when reading aclocal.m4, # will think it sees a *use*, and therefore will trigger all it's # C support machinery. Also note that it means that autoscan, seeing # CC etc. in the Makefile, will ask for an AC_PROG_CC use... # _AM_DEPENDENCIES(NAME) # ---------------------- # See how the compiler implements dependency checking. # NAME is "CC", "CXX", "GCJ", or "OBJC". # We try a few techniques and use that to set a single cache variable. # # We don't AC_REQUIRE the corresponding AC_PROG_CC since the latter was # modified to invoke _AM_DEPENDENCIES(CC); we would have a circular # dependency, and given that the user is not expected to run this macro, # just rely on AC_PROG_CC. AC_DEFUN([_AM_DEPENDENCIES], [AC_REQUIRE([AM_SET_DEPDIR])dnl AC_REQUIRE([AM_OUTPUT_DEPENDENCY_COMMANDS])dnl AC_REQUIRE([AM_MAKE_INCLUDE])dnl AC_REQUIRE([AM_DEP_TRACK])dnl ifelse([$1], CC, [depcc="$CC" am_compiler_list=], [$1], CXX, [depcc="$CXX" am_compiler_list=], [$1], OBJC, [depcc="$OBJC" am_compiler_list='gcc3 gcc'], [$1], UPC, [depcc="$UPC" am_compiler_list=], [$1], GCJ, [depcc="$GCJ" am_compiler_list='gcc3 gcc'], [depcc="$$1" am_compiler_list=]) AC_CACHE_CHECK([dependency style of $depcc], [am_cv_$1_dependencies_compiler_type], [if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named `D' -- because `-MD' means `put the output # in D'. mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_$1_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n ['s/^#*\([a-zA-Z0-9]*\))$/\1/p'] < ./depcomp` fi for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using `: > sub/conftst$i.h' creates only sub/conftst1.h with # Solaris 8's {/usr,}/bin/sh. touch sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf case $depmode in nosideeffect) # after this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; none) break ;; esac # We check with `-c' and `-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle `-M -o', and we need to detect this. if depmode=$depmode \ source=sub/conftest.c object=sub/conftest.${OBJEXT-o} \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c -o sub/conftest.${OBJEXT-o} sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftest.${OBJEXT-o} sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thusly: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_$1_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_$1_dependencies_compiler_type=none fi ]) AC_SUBST([$1DEPMODE], [depmode=$am_cv_$1_dependencies_compiler_type]) AM_CONDITIONAL([am__fastdep$1], [ test "x$enable_dependency_tracking" != xno \ && test "$am_cv_$1_dependencies_compiler_type" = gcc3]) ]) # AM_SET_DEPDIR # ------------- # Choose a directory name for dependency files. # This macro is AC_REQUIREd in _AM_DEPENDENCIES AC_DEFUN([AM_SET_DEPDIR], [AC_REQUIRE([AM_SET_LEADING_DOT])dnl AC_SUBST([DEPDIR], ["${am__leading_dot}deps"])dnl ]) # AM_DEP_TRACK # ------------ AC_DEFUN([AM_DEP_TRACK], [AC_ARG_ENABLE(dependency-tracking, [ --disable-dependency-tracking speeds up one-time build --enable-dependency-tracking do not reject slow dependency extractors]) if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' fi AM_CONDITIONAL([AMDEP], [test "x$enable_dependency_tracking" != xno]) AC_SUBST([AMDEPBACKSLASH])dnl _AM_SUBST_NOTMAKE([AMDEPBACKSLASH])dnl ]) # Generate code to set up dependency tracking. -*- Autoconf -*- # Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. #serial 3 # _AM_OUTPUT_DEPENDENCY_COMMANDS # ------------------------------ AC_DEFUN([_AM_OUTPUT_DEPENDENCY_COMMANDS], [for mf in $CONFIG_FILES; do # Strip MF so we end up with the name of the file. mf=`echo "$mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile or not. # We used to match only the files named `Makefile.in', but # some people rename them; so instead we look at the file content. # Grep'ing the first line is not enough: some people post-process # each Makefile.in and add a new line on top of each file to say so. # Grep'ing the whole file is not good either: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then dirpart=`AS_DIRNAME("$mf")` else continue fi # Extract the definition of DEPDIR, am__include, and am__quote # from the Makefile without running `make'. DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` test -z "$DEPDIR" && continue am__include=`sed -n 's/^am__include = //p' < "$mf"` test -z "am__include" && continue am__quote=`sed -n 's/^am__quote = //p' < "$mf"` # When using ansi2knr, U may be empty or an underscore; expand it U=`sed -n 's/^U = //p' < "$mf"` # Find all dependency output files, they are included files with # $(DEPDIR) in their names. We invoke sed twice because it is the # simplest approach to changing $(DEPDIR) to its actual value in the # expansion. for file in `sed -n " s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g' -e 's/\$U/'"$U"'/g'`; do # Make sure the directory exists. test -f "$dirpart/$file" && continue fdir=`AS_DIRNAME(["$file"])` AS_MKDIR_P([$dirpart/$fdir]) # echo "creating $dirpart/$file" echo '# dummy' > "$dirpart/$file" done done ])# _AM_OUTPUT_DEPENDENCY_COMMANDS # AM_OUTPUT_DEPENDENCY_COMMANDS # ----------------------------- # This macro should only be invoked once -- use via AC_REQUIRE. # # This code is only required when automatic dependency tracking # is enabled. FIXME. This creates each `.P' file that we will # need in order to bootstrap the dependency handling code. AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS], [AC_CONFIG_COMMANDS([depfiles], [test x"$AMDEP_TRUE" != x"" || _AM_OUTPUT_DEPENDENCY_COMMANDS], [AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir"]) ]) # Do all the work for Automake. -*- Autoconf -*- # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, # 2005, 2006, 2008 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 13 # This macro actually does too much. Some checks are only needed if # your package does certain things. But this isn't really a big deal. # AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE]) # AM_INIT_AUTOMAKE([OPTIONS]) # ----------------------------------------------- # The call with PACKAGE and VERSION arguments is the old style # call (pre autoconf-2.50), which is being phased out. PACKAGE # and VERSION should now be passed to AC_INIT and removed from # the call to AM_INIT_AUTOMAKE. # We support both call styles for the transition. After # the next Automake release, Autoconf can make the AC_INIT # arguments mandatory, and then we can depend on a new Autoconf # release and drop the old call support. AC_DEFUN([AM_INIT_AUTOMAKE], [AC_PREREQ([2.60])dnl dnl Autoconf wants to disallow AM_ names. We explicitly allow dnl the ones we care about. m4_pattern_allow([^AM_[A-Z]+FLAGS$])dnl AC_REQUIRE([AM_SET_CURRENT_AUTOMAKE_VERSION])dnl AC_REQUIRE([AC_PROG_INSTALL])dnl if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." AC_SUBST([am__isrc], [' -I$(srcdir)'])_AM_SUBST_NOTMAKE([am__isrc])dnl # test to see if srcdir already configured if test -f $srcdir/config.status; then AC_MSG_ERROR([source directory already configured; run "make distclean" there first]) fi fi # test whether we have cygpath if test -z "$CYGPATH_W"; then if (cygpath --version) >/dev/null 2>/dev/null; then CYGPATH_W='cygpath -w' else CYGPATH_W=echo fi fi AC_SUBST([CYGPATH_W]) # Define the identity of the package. dnl Distinguish between old-style and new-style calls. m4_ifval([$2], [m4_ifval([$3], [_AM_SET_OPTION([no-define])])dnl AC_SUBST([PACKAGE], [$1])dnl AC_SUBST([VERSION], [$2])], [_AM_SET_OPTIONS([$1])dnl dnl Diagnose old-style AC_INIT with new-style AM_AUTOMAKE_INIT. m4_if(m4_ifdef([AC_PACKAGE_NAME], 1)m4_ifdef([AC_PACKAGE_VERSION], 1), 11,, [m4_fatal([AC_INIT should be called with package and version arguments])])dnl AC_SUBST([PACKAGE], ['AC_PACKAGE_TARNAME'])dnl AC_SUBST([VERSION], ['AC_PACKAGE_VERSION'])])dnl _AM_IF_OPTION([no-define],, [AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE", [Name of package]) AC_DEFINE_UNQUOTED(VERSION, "$VERSION", [Version number of package])])dnl # Some tools Automake needs. AC_REQUIRE([AM_SANITY_CHECK])dnl AC_REQUIRE([AC_ARG_PROGRAM])dnl AM_MISSING_PROG(ACLOCAL, aclocal-${am__api_version}) AM_MISSING_PROG(AUTOCONF, autoconf) AM_MISSING_PROG(AUTOMAKE, automake-${am__api_version}) AM_MISSING_PROG(AUTOHEADER, autoheader) AM_MISSING_PROG(MAKEINFO, makeinfo) AM_PROG_INSTALL_SH AM_PROG_INSTALL_STRIP AC_REQUIRE([AM_PROG_MKDIR_P])dnl # We need awk for the "check" target. The system "awk" is bad on # some platforms. AC_REQUIRE([AC_PROG_AWK])dnl AC_REQUIRE([AC_PROG_MAKE_SET])dnl AC_REQUIRE([AM_SET_LEADING_DOT])dnl _AM_IF_OPTION([tar-ustar], [_AM_PROG_TAR([ustar])], [_AM_IF_OPTION([tar-pax], [_AM_PROG_TAR([pax])], [_AM_PROG_TAR([v7])])]) _AM_IF_OPTION([no-dependencies],, [AC_PROVIDE_IFELSE([AC_PROG_CC], [_AM_DEPENDENCIES(CC)], [define([AC_PROG_CC], defn([AC_PROG_CC])[_AM_DEPENDENCIES(CC)])])dnl AC_PROVIDE_IFELSE([AC_PROG_CXX], [_AM_DEPENDENCIES(CXX)], [define([AC_PROG_CXX], defn([AC_PROG_CXX])[_AM_DEPENDENCIES(CXX)])])dnl AC_PROVIDE_IFELSE([AC_PROG_OBJC], [_AM_DEPENDENCIES(OBJC)], [define([AC_PROG_OBJC], defn([AC_PROG_OBJC])[_AM_DEPENDENCIES(OBJC)])])dnl ]) ]) # When config.status generates a header, we must update the stamp-h file. # This file resides in the same directory as the config header # that is generated. The stamp files are numbered to have different names. # Autoconf calls _AC_AM_CONFIG_HEADER_HOOK (when defined) in the # loop where config.status creates the headers, so we can generate # our stamp files there. AC_DEFUN([_AC_AM_CONFIG_HEADER_HOOK], [# Compute $1's index in $config_headers. _am_arg=$1 _am_stamp_count=1 for _am_header in $config_headers :; do case $_am_header in $_am_arg | $_am_arg:* ) break ;; * ) _am_stamp_count=`expr $_am_stamp_count + 1` ;; esac done echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_count]) # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_PROG_INSTALL_SH # ------------------ # Define $install_sh. AC_DEFUN([AM_PROG_INSTALL_SH], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl install_sh=${install_sh-"\$(SHELL) $am_aux_dir/install-sh"} AC_SUBST(install_sh)]) # Copyright (C) 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 2 # Check whether the underlying file-system supports filenames # with a leading dot. For instance MS-DOS doesn't. AC_DEFUN([AM_SET_LEADING_DOT], [rm -rf .tst 2>/dev/null mkdir .tst 2>/dev/null if test -d .tst; then am__leading_dot=. else am__leading_dot=_ fi rmdir .tst 2>/dev/null AC_SUBST([am__leading_dot])]) # Check to see how 'make' treats includes. -*- Autoconf -*- # Copyright (C) 2001, 2002, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 3 # AM_MAKE_INCLUDE() # ----------------- # Check to see how make treats includes. AC_DEFUN([AM_MAKE_INCLUDE], [am_make=${MAKE-make} cat > confinc << 'END' am__doit: @echo done .PHONY: am__doit END # If we don't find an include directive, just comment out the code. AC_MSG_CHECKING([for style of include used by $am_make]) am__include="#" am__quote= _am_result=none # First try GNU make style include. echo "include confinc" > confmf # We grep out `Entering directory' and `Leaving directory' # messages which can occur if `w' ends up in MAKEFLAGS. # In particular we don't look at `^make:' because GNU make might # be invoked under some other name (usually "gmake"), in which # case it prints its new name instead of `make'. if test "`$am_make -s -f confmf 2> /dev/null | grep -v 'ing directory'`" = "done"; then am__include=include am__quote= _am_result=GNU fi # Now try BSD make style include. if test "$am__include" = "#"; then echo '.include "confinc"' > confmf if test "`$am_make -s -f confmf 2> /dev/null`" = "done"; then am__include=.include am__quote="\"" _am_result=BSD fi fi AC_SUBST([am__include]) AC_SUBST([am__quote]) AC_MSG_RESULT([$_am_result]) rm -f confinc confmf ]) # Copyright (C) 1999, 2000, 2001, 2003, 2004, 2005 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 5 # AM_PROG_CC_C_O # -------------- # Like AC_PROG_CC_C_O, but changed for automake. AC_DEFUN([AM_PROG_CC_C_O], [AC_REQUIRE([AC_PROG_CC_C_O])dnl AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl AC_REQUIRE_AUX_FILE([compile])dnl # FIXME: we rely on the cache variable name because # there is no other way. set dummy $CC ac_cc=`echo $[2] | sed ['s/[^a-zA-Z0-9_]/_/g;s/^[0-9]/_/']` if eval "test \"`echo '$ac_cv_prog_cc_'${ac_cc}_c_o`\" != yes"; then # Losing compiler, so override with the script. # FIXME: It is wrong to rewrite CC. # But if we don't then we get into trouble of one sort or another. # A longer-term fix would be to have automake use am__CC in this case, # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" CC="$am_aux_dir/compile $CC" fi dnl Make sure AC_PROG_CC is never called again, or it will override our dnl setting of CC. m4_define([AC_PROG_CC], [m4_fatal([AC_PROG_CC cannot be called after AM_PROG_CC_C_O])]) ]) # Fake the existence of programs that GNU maintainers use. -*- Autoconf -*- # Copyright (C) 1997, 1999, 2000, 2001, 2003, 2004, 2005 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 5 # AM_MISSING_PROG(NAME, PROGRAM) # ------------------------------ AC_DEFUN([AM_MISSING_PROG], [AC_REQUIRE([AM_MISSING_HAS_RUN]) $1=${$1-"${am_missing_run}$2"} AC_SUBST($1)]) # AM_MISSING_HAS_RUN # ------------------ # Define MISSING if not defined so far and test if it supports --run. # If it does, set am_missing_run to use it, otherwise, to nothing. AC_DEFUN([AM_MISSING_HAS_RUN], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl AC_REQUIRE_AUX_FILE([missing])dnl test x"${MISSING+set}" = xset || MISSING="\${SHELL} $am_aux_dir/missing" # Use eval to expand $SHELL if eval "$MISSING --run true"; then am_missing_run="$MISSING --run " else am_missing_run= AC_MSG_WARN([`missing' script is too old or missing]) fi ]) # Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_PROG_MKDIR_P # --------------- # Check for `mkdir -p'. AC_DEFUN([AM_PROG_MKDIR_P], [AC_PREREQ([2.60])dnl AC_REQUIRE([AC_PROG_MKDIR_P])dnl dnl Automake 1.8 to 1.9.6 used to define mkdir_p. We now use MKDIR_P, dnl while keeping a definition of mkdir_p for backward compatibility. dnl @MKDIR_P@ is magic: AC_OUTPUT adjusts its value for each Makefile. dnl However we cannot define mkdir_p as $(MKDIR_P) for the sake of dnl Makefile.ins that do not define MKDIR_P, so we do our own dnl adjustment using top_builddir (which is defined more often than dnl MKDIR_P). AC_SUBST([mkdir_p], ["$MKDIR_P"])dnl case $mkdir_p in [[\\/$]]* | ?:[[\\/]]*) ;; */*) mkdir_p="\$(top_builddir)/$mkdir_p" ;; esac ]) # Helper functions for option handling. -*- Autoconf -*- # Copyright (C) 2001, 2002, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 3 # _AM_MANGLE_OPTION(NAME) # ----------------------- AC_DEFUN([_AM_MANGLE_OPTION], [[_AM_OPTION_]m4_bpatsubst($1, [[^a-zA-Z0-9_]], [_])]) # _AM_SET_OPTION(NAME) # ------------------------------ # Set option NAME. Presently that only means defining a flag for this option. AC_DEFUN([_AM_SET_OPTION], [m4_define(_AM_MANGLE_OPTION([$1]), 1)]) # _AM_SET_OPTIONS(OPTIONS) # ---------------------------------- # OPTIONS is a space-separated list of Automake options. AC_DEFUN([_AM_SET_OPTIONS], [AC_FOREACH([_AM_Option], [$1], [_AM_SET_OPTION(_AM_Option)])]) # _AM_IF_OPTION(OPTION, IF-SET, [IF-NOT-SET]) # ------------------------------------------- # Execute IF-SET if OPTION is set, IF-NOT-SET otherwise. AC_DEFUN([_AM_IF_OPTION], [m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])]) # Check to make sure that the build environment is sane. -*- Autoconf -*- # Copyright (C) 1996, 1997, 2000, 2001, 2003, 2005 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 4 # AM_SANITY_CHECK # --------------- AC_DEFUN([AM_SANITY_CHECK], [AC_MSG_CHECKING([whether build environment is sane]) # Just in case sleep 1 echo timestamp > conftest.file # Do `set' in a subshell so we don't clobber the current shell's # arguments. Must try -L first in case configure is actually a # symlink; some systems play weird games with the mod time of symlinks # (eg FreeBSD returns the mod time of the symlink's containing # directory). if ( set X `ls -Lt $srcdir/configure conftest.file 2> /dev/null` if test "$[*]" = "X"; then # -L didn't work. set X `ls -t $srcdir/configure conftest.file` fi rm -f conftest.file if test "$[*]" != "X $srcdir/configure conftest.file" \ && test "$[*]" != "X conftest.file $srcdir/configure"; then # If neither matched, then we have a broken ls. This can happen # if, for instance, CONFIG_SHELL is bash and it inherits a # broken ls alias from the environment. This has actually # happened. Such a system could not be considered "sane". AC_MSG_ERROR([ls -t appears to fail. Make sure there is not a broken alias in your environment]) fi test "$[2]" = conftest.file ) then # Ok. : else AC_MSG_ERROR([newly created file is older than distributed files! Check your system clock]) fi AC_MSG_RESULT(yes)]) # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_PROG_INSTALL_STRIP # --------------------- # One issue with vendor `install' (even GNU) is that you can't # specify the program used to strip binaries. This is especially # annoying in cross-compiling environments, where the build's strip # is unlikely to handle the host's binaries. # Fortunately install-sh will honor a STRIPPROG variable, so we # always use install-sh in `make install-strip', and initialize # STRIPPROG with the value of the STRIP variable (set by the user). AC_DEFUN([AM_PROG_INSTALL_STRIP], [AC_REQUIRE([AM_PROG_INSTALL_SH])dnl # Installed binaries are usually stripped using `strip' when the user # run `make install-strip'. However `strip' might not be the right # tool to use in cross-compilation environments, therefore Automake # will honor the `STRIP' environment variable to overrule this program. dnl Don't test for $cross_compiling = yes, because it might be `maybe'. if test "$cross_compiling" != no; then AC_CHECK_TOOL([STRIP], [strip], :) fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" AC_SUBST([INSTALL_STRIP_PROGRAM])]) # Copyright (C) 2006 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # _AM_SUBST_NOTMAKE(VARIABLE) # --------------------------- # Prevent Automake from outputting VARIABLE = @VARIABLE@ in Makefile.in. # This macro is traced by Automake. AC_DEFUN([_AM_SUBST_NOTMAKE]) # Check how to create a tarball. -*- Autoconf -*- # Copyright (C) 2004, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 2 # _AM_PROG_TAR(FORMAT) # -------------------- # Check how to create a tarball in format FORMAT. # FORMAT should be one of `v7', `ustar', or `pax'. # # Substitute a variable $(am__tar) that is a command # writing to stdout a FORMAT-tarball containing the directory # $tardir. # tardir=directory && $(am__tar) > result.tar # # Substitute a variable $(am__untar) that extract such # a tarball read from stdin. # $(am__untar) < result.tar AC_DEFUN([_AM_PROG_TAR], [# Always define AMTAR for backward compatibility. AM_MISSING_PROG([AMTAR], [tar]) m4_if([$1], [v7], [am__tar='${AMTAR} chof - "$$tardir"'; am__untar='${AMTAR} xf -'], [m4_case([$1], [ustar],, [pax],, [m4_fatal([Unknown tar format])]) AC_MSG_CHECKING([how to create a $1 tar archive]) # Loop over all known methods to create a tar archive until one works. _am_tools='gnutar m4_if([$1], [ustar], [plaintar]) pax cpio none' _am_tools=${am_cv_prog_tar_$1-$_am_tools} # Do not fold the above two line into one, because Tru64 sh and # Solaris sh will not grok spaces in the rhs of `-'. for _am_tool in $_am_tools do case $_am_tool in gnutar) for _am_tar in tar gnutar gtar; do AM_RUN_LOG([$_am_tar --version]) && break done am__tar="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$$tardir"' am__tar_="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$tardir"' am__untar="$_am_tar -xf -" ;; plaintar) # Must skip GNU tar: if it does not support --format= it doesn't create # ustar tarball either. (tar --version) >/dev/null 2>&1 && continue am__tar='tar chf - "$$tardir"' am__tar_='tar chf - "$tardir"' am__untar='tar xf -' ;; pax) am__tar='pax -L -x $1 -w "$$tardir"' am__tar_='pax -L -x $1 -w "$tardir"' am__untar='pax -r' ;; cpio) am__tar='find "$$tardir" -print | cpio -o -H $1 -L' am__tar_='find "$tardir" -print | cpio -o -H $1 -L' am__untar='cpio -i -H $1 -d' ;; none) am__tar=false am__tar_=false am__untar=false ;; esac # If the value was cached, stop now. We just wanted to have am__tar # and am__untar set. test -n "${am_cv_prog_tar_$1}" && break # tar/untar a dummy directory, and stop if the command works rm -rf conftest.dir mkdir conftest.dir echo GrepMe > conftest.dir/file AM_RUN_LOG([tardir=conftest.dir && eval $am__tar_ >conftest.tar]) rm -rf conftest.dir if test -s conftest.tar; then AM_RUN_LOG([$am__untar /dev/null 2>&1 && break fi done rm -rf conftest.dir AC_CACHE_VAL([am_cv_prog_tar_$1], [am_cv_prog_tar_$1=$_am_tool]) AC_MSG_RESULT([$am_cv_prog_tar_$1])]) AC_SUBST([am__tar]) AC_SUBST([am__untar]) ]) # _AM_PROG_TAR algol68g-2.8/config.guess0000644000175000001440000012673111755213203012251 00000000000000#! /bin/sh # Attempt to guess a canonical system name. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, # 2011 Free Software Foundation, Inc. timestamp='2011-06-03' # This file 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 2 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, write to the Free Software # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA # 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Originally written by Per Bothner. Please send patches (context # diff format) to and include a ChangeLog # entry. # # This script attempts to guess a canonical system name similar to # config.sub. If it succeeds, it prints the system name on stdout, and # exits with 0. Otherwise, it exits with 1. # # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" >&2 exit 1 ;; * ) break ;; esac done if test $# != 0; then echo "$me: too many arguments$help" >&2 exit 1 fi trap 'exit 1' 1 2 15 # CC_FOR_BUILD -- compiler used by this script. Note that the use of a # compiler to aid in system detection is discouraged as it requires # temporary files to be created and, as you can see below, it is a # headache to deal with in a portable fashion. # Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still # use `HOST_CC' if defined, but it is deprecated. # Portable tmp directory creation inspired by the Autoconf team. set_cc_for_build=' trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; : ${TMPDIR=/tmp} ; { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; dummy=$tmp/dummy ; tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; case $CC_FOR_BUILD,$HOST_CC,$CC in ,,) echo "int x;" > $dummy.c ; for c in cc gcc c89 c99 ; do if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then CC_FOR_BUILD="$c"; break ; fi ; done ; if test x"$CC_FOR_BUILD" = x ; then CC_FOR_BUILD=no_compiler_found ; fi ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; esac ; set_cc_for_build= ;' # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) if (test -f /.attbin/uname) >/dev/null 2>&1 ; then PATH=$PATH:/.attbin ; export PATH fi UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown # Note: order is significant - the case branches are not exclusive. case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in *:NetBSD:*:*) # NetBSD (nbsd) targets should (where applicable) match one or # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently # switched to ELF, *-*-netbsd* would select the old # object file format. This provides both forward # compatibility and a consistent mechanism for selecting the # object file format. # # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". sysctl="sysctl -n hw.machine_arch" UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ /usr/sbin/$sysctl 2>/dev/null || echo unknown)` case "${UNAME_MACHINE_ARCH}" in armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; *) machine=${UNAME_MACHINE_ARCH}-unknown ;; esac # The Operating System including object format, if it has switched # to ELF recently, or will in the future. case "${UNAME_MACHINE_ARCH}" in arm*|i386|m68k|ns32k|sh3*|sparc|vax) eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ELF__ then # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). # Return netbsd for either. FIX? os=netbsd else os=netbsdelf fi ;; *) os=netbsd ;; esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need # kernel version information, so it can be replaced with a # suitable tag, in the style of linux-gnu. case "${UNAME_VERSION}" in Debian*) release='-gnu' ;; *) release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. echo "${machine}-${os}${release}" exit ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} exit ;; *:ekkoBSD:*:*) echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} exit ;; *:SolidBSD:*:*) echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} exit ;; macppc:MirBSD:*:*) echo powerpc-unknown-mirbsd${UNAME_RELEASE} exit ;; *:MirBSD:*:*) echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in *4.0) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` ;; *5.*) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` ;; esac # According to Compaq, /usr/sbin/psrinfo has been available on # OSF/1 and Tru64 systems produced since 1995. I hope that # covers most systems running today. This code pipes the CPU # types through head -n 1, so we only detect the type of CPU 0. ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case "$ALPHA_CPU_TYPE" in "EV4 (21064)") UNAME_MACHINE="alpha" ;; "EV4.5 (21064)") UNAME_MACHINE="alpha" ;; "LCA4 (21066/21068)") UNAME_MACHINE="alpha" ;; "EV5 (21164)") UNAME_MACHINE="alphaev5" ;; "EV5.6 (21164A)") UNAME_MACHINE="alphaev56" ;; "EV5.6 (21164PC)") UNAME_MACHINE="alphapca56" ;; "EV5.7 (21164PC)") UNAME_MACHINE="alphapca57" ;; "EV6 (21264)") UNAME_MACHINE="alphaev6" ;; "EV6.7 (21264A)") UNAME_MACHINE="alphaev67" ;; "EV6.8CB (21264C)") UNAME_MACHINE="alphaev68" ;; "EV6.8AL (21264B)") UNAME_MACHINE="alphaev68" ;; "EV6.8CX (21264D)") UNAME_MACHINE="alphaev68" ;; "EV6.9A (21264/EV69A)") UNAME_MACHINE="alphaev69" ;; "EV7 (21364)") UNAME_MACHINE="alphaev7" ;; "EV7.9 (21364A)") UNAME_MACHINE="alphaev79" ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` # Reset EXIT trap before exiting to avoid spurious non-zero exit code. exitcode=$? trap '' 0 exit $exitcode ;; Alpha\ *:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # Should we change UNAME_MACHINE based on the output of uname instead # of the specific Alpha model? echo alpha-pc-interix exit ;; 21064:Windows_NT:50:3) echo alpha-dec-winnt3.5 exit ;; Amiga*:UNIX_System_V:4.0:*) echo m68k-unknown-sysv4 exit ;; *:[Aa]miga[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-amigaos exit ;; *:[Mm]orph[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-morphos exit ;; *:OS/390:*:*) echo i370-ibm-openedition exit ;; *:z/VM:*:*) echo s390-ibm-zvmoe exit ;; *:OS400:*:*) echo powerpc-ibm-os400 exit ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) echo arm-acorn-riscix${UNAME_RELEASE} exit ;; arm:riscos:*:*|arm:RISCOS:*:*) echo arm-unknown-riscos exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp exit ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then echo pyramid-pyramid-sysv3 else echo pyramid-pyramid-bsd fi exit ;; NILE*:*:*:dcosx) echo pyramid-pyramid-svr4 exit ;; DRS?6000:unix:4.0:6*) echo sparc-icl-nx6 exit ;; DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in sparc) echo sparc-icl-nx7; exit ;; esac ;; s390x:SunOS:*:*) echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4H:SunOS:5.*:*) echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) echo i386-pc-auroraux${UNAME_RELEASE} exit ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) eval $set_cc_for_build SUN_ARCH="i386" # If there is a compiler, see if it is configured for 64-bit objects. # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. # This test works for both compilers. if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then SUN_ARCH="x86_64" fi fi echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:*:*) case "`/usr/bin/arch -k`" in Series*|S4*) UNAME_RELEASE=`uname -v` ;; esac # Japanese Language versions have a version number like `4.1.3-JL'. echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` exit ;; sun3*:SunOS:*:*) echo m68k-sun-sunos${UNAME_RELEASE} exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) echo m68k-sun-sunos${UNAME_RELEASE} ;; sun4) echo sparc-sun-sunos${UNAME_RELEASE} ;; esac exit ;; aushp:SunOS:*:*) echo sparc-auspex-sunos${UNAME_RELEASE} exit ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not # "atarist" or "atariste" at least should have a processor # > m68000). The system name ranges from "MiNT" over "FreeMiNT" # to the lowercase version "mint" (or "freemint"). Finally # the system name "TOS" denotes a system which is actually not # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) echo m68k-milan-mint${UNAME_RELEASE} exit ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) echo m68k-hades-mint${UNAME_RELEASE} exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) echo m68k-unknown-mint${UNAME_RELEASE} exit ;; m68k:machten:*:*) echo m68k-apple-machten${UNAME_RELEASE} exit ;; powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} exit ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit ;; RISC*:ULTRIX:*:*) echo mips-dec-ultrix${UNAME_RELEASE} exit ;; VAX*:ULTRIX*:*:*) echo vax-dec-ultrix${UNAME_RELEASE} exit ;; 2020:CLIX:*:* | 2430:CLIX:*:*) echo clipper-intergraph-clix${UNAME_RELEASE} exit ;; mips:*:*:UMIPS | mips:*:*:RISCos) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __cplusplus #include /* for printf() prototype */ int main (int argc, char *argv[]) { #else int main (argc, argv) int argc; char *argv[]; { #endif #if defined (host_mips) && defined (MIPSEB) #if defined (SYSTYPE_SYSV) printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_SVR4) printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); #endif #endif exit (-1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && SYSTEM_NAME=`$dummy $dummyarg` && { echo "$SYSTEM_NAME"; exit; } echo mips-mips-riscos${UNAME_RELEASE} exit ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax exit ;; Motorola:*:4.3:PL8-*) echo powerpc-harris-powermax exit ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) echo powerpc-harris-powermax exit ;; Night_Hawk:Power_UNIX:*:*) echo powerpc-harris-powerunix exit ;; m88k:CX/UX:7*:*) echo m88k-harris-cxux7 exit ;; m88k:*:4*:R4*) echo m88k-motorola-sysv4 exit ;; m88k:*:3*:R3*) echo m88k-motorola-sysv3 exit ;; AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] then if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ [ ${TARGET_BINARY_INTERFACE}x = x ] then echo m88k-dg-dgux${UNAME_RELEASE} else echo m88k-dg-dguxbcs${UNAME_RELEASE} fi else echo i586-dg-dgux${UNAME_RELEASE} fi exit ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) echo m88k-dolphin-sysv3 exit ;; M88*:*:R3*:*) # Delta 88k system running SVR3 echo m88k-motorola-sysv3 exit ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) echo m88k-tektronix-sysv3 exit ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) echo m68k-tektronix-bsd exit ;; *:IRIX*:*:*) echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` exit ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) echo i386-ibm-aix exit ;; ia64:AIX:*:*) if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} exit ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include main() { if (!__power_pc()) exit(1); puts("powerpc-ibm-aix3.2.5"); exit(0); } EOF if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` then echo "$SYSTEM_NAME" else echo rs6000-ibm-aix3.2.5 fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then echo rs6000-ibm-aix3.2.4 else echo rs6000-ibm-aix3.2 fi exit ;; *:AIX:*:[4567]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc fi if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${IBM_ARCH}-ibm-aix${IBM_REV} exit ;; *:AIX:*:*) echo rs6000-ibm-aix exit ;; ibmrt:4.4BSD:*|romp-ibm:BSD:*) echo romp-ibm-bsd4.4 exit ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to exit ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) echo rs6000-bull-bosx exit ;; DPX/2?00:B.O.S.:*:*) echo m68k-bull-sysv3 exit ;; 9000/[34]??:4.3bsd:1.*:*) echo m68k-hp-bsd exit ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 exit ;; 9000/[34678]??:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; 9000/[678][0-9][0-9]) if [ -x /usr/bin/getconf ]; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` case "${sc_cpu_version}" in 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 case "${sc_kernel_bits}" in 32) HP_ARCH="hppa2.0n" ;; 64) HP_ARCH="hppa2.0w" ;; '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 esac ;; esac fi if [ "${HP_ARCH}" = "" ]; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #define _HPUX_SOURCE #include #include int main () { #if defined(_SC_KERNEL_BITS) long bits = sysconf(_SC_KERNEL_BITS); #endif long cpu = sysconf (_SC_CPU_VERSION); switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0"); break; case CPU_PA_RISC1_1: puts ("hppa1.1"); break; case CPU_PA_RISC2_0: #if defined(_SC_KERNEL_BITS) switch (bits) { case 64: puts ("hppa2.0w"); break; case 32: puts ("hppa2.0n"); break; default: puts ("hppa2.0"); break; } break; #else /* !defined(_SC_KERNEL_BITS) */ puts ("hppa2.0"); break; #endif default: puts ("hppa1.0"); break; } exit (0); } EOF (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac if [ ${HP_ARCH} = "hppa2.0w" ] then eval $set_cc_for_build # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler # generating 64-bit code. GNU and HP use different nomenclature: # # $ CC_FOR_BUILD=cc ./config.guess # => hppa2.0w-hp-hpux11.23 # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | grep -q __LP64__ then HP_ARCH="hppa2.0w" else HP_ARCH="hppa64" fi fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} exit ;; ia64:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ia64-hp-hpux${HPUX_REV} exit ;; 3050*:HI-UX:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include int main () { long cpu = sysconf (_SC_CPU_VERSION); /* The order matters, because CPU_IS_HP_MC68K erroneously returns true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct results, however. */ if (CPU_IS_PA_RISC (cpu)) { switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; default: puts ("hppa-hitachi-hiuxwe2"); break; } } else if (CPU_IS_HP_MC68K (cpu)) puts ("m68k-hitachi-hiuxwe2"); else puts ("unknown-hitachi-hiuxwe2"); exit (0); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } echo unknown-hitachi-hiuxwe2 exit ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) echo hppa1.1-hp-bsd exit ;; 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd exit ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix exit ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) echo hppa1.1-hp-osf exit ;; hp8??:OSF1:*:*) echo hppa1.0-hp-osf exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then echo ${UNAME_MACHINE}-unknown-osf1mk else echo ${UNAME_MACHINE}-unknown-osf1 fi exit ;; parisc*:Lites*:*:*) echo hppa1.1-hp-lites exit ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) echo c1-convex-bsd exit ;; C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) echo c34-convex-bsd exit ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) echo c38-convex-bsd exit ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) echo c4-convex-bsd exit ;; CRAY*Y-MP:*:*:*) echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*[A-Z]90:*:*:*) echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' exit ;; CRAY*TS:*:*:*) echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*T3E:*:*:*) echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*SV1:*:*:*) echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; *:UNICOS/mp:*:*) echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; 5000:UNIX_System_V:4.*:*) FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit ;; sparc*:BSD/OS:*:*) echo sparc-unknown-bsdi${UNAME_RELEASE} exit ;; *:BSD/OS:*:*) echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} exit ;; *:FreeBSD:*:*) case ${UNAME_MACHINE} in pc98) echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; amd64) echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; *) echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; esac exit ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin exit ;; *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; i*:windows32*:*) # uname -m includes "-pc" on this system. echo ${UNAME_MACHINE}-mingw32 exit ;; i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 exit ;; *:Interix*:*) case ${UNAME_MACHINE} in x86) echo i586-pc-interix${UNAME_RELEASE} exit ;; authenticamd | genuineintel | EM64T) echo x86_64-unknown-interix${UNAME_RELEASE} exit ;; IA64) echo ia64-unknown-interix${UNAME_RELEASE} exit ;; esac ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) echo i${UNAME_MACHINE}-pc-mks exit ;; 8664:Windows_NT:*) echo x86_64-pc-mks exit ;; i*:Windows_NT*:* | Pentium*:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we # UNAME_MACHINE based on the output of uname instead of i386? echo i586-pc-interix exit ;; i*:UWIN*:*) echo ${UNAME_MACHINE}-pc-uwin exit ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) echo x86_64-unknown-cygwin exit ;; p*:CYGWIN*:*) echo powerpcle-unknown-cygwin exit ;; prep*:SunOS:5.*:*) echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; *:GNU:*:*) # the GNU system echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix exit ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in EV5) UNAME_MACHINE=alphaev5 ;; EV56) UNAME_MACHINE=alphaev56 ;; PCA56) UNAME_MACHINE=alphapca56 ;; PCA57) UNAME_MACHINE=alphapca56 ;; EV6) UNAME_MACHINE=alphaev6 ;; EV67) UNAME_MACHINE=alphaev67 ;; EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep -q ld.so.1 if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} exit ;; arm*:Linux:*:*) eval $set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then echo ${UNAME_MACHINE}-unknown-linux-gnu else if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_PCS_VFP then echo ${UNAME_MACHINE}-unknown-linux-gnueabi else echo ${UNAME_MACHINE}-unknown-linux-gnueabihf fi fi exit ;; avr32*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; cris:Linux:*:*) echo cris-axis-linux-gnu exit ;; crisv32:Linux:*:*) echo crisv32-axis-linux-gnu exit ;; frv:Linux:*:*) echo frv-unknown-linux-gnu exit ;; i*86:Linux:*:*) LIBC=gnu eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __dietlibc__ LIBC=dietlibc #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` echo "${UNAME_MACHINE}-pc-linux-${LIBC}" exit ;; ia64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; m32r*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; m68*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; mips:Linux:*:* | mips64:Linux:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #undef CPU #undef ${UNAME_MACHINE} #undef ${UNAME_MACHINE}el #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) CPU=${UNAME_MACHINE}el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) CPU=${UNAME_MACHINE} #else CPU= #endif #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } ;; or32:Linux:*:*) echo or32-unknown-linux-gnu exit ;; padre:Linux:*:*) echo sparc-unknown-linux-gnu exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) echo hppa64-unknown-linux-gnu exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in PA7*) echo hppa1.1-unknown-linux-gnu ;; PA8*) echo hppa2.0-unknown-linux-gnu ;; *) echo hppa-unknown-linux-gnu ;; esac exit ;; ppc64:Linux:*:*) echo powerpc64-unknown-linux-gnu exit ;; ppc:Linux:*:*) echo powerpc-unknown-linux-gnu exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux exit ;; sh64*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; sh*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; tile*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; vax:Linux:*:*) echo ${UNAME_MACHINE}-dec-linux-gnu exit ;; x86_64:Linux:*:*) echo x86_64-unknown-linux-gnu exit ;; xtensa*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. # earlier versions are messed up and put the nodename in both # sysname and nodename. echo i386-sequent-sysv4 exit ;; i*86:UNIX_SV:4.2MP:2.*) # Unixware is an offshoot of SVR4, but it has its own version # number series starting with 2... # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. # Use sysv4.2uw... so that sysv4* matches it. echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} exit ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. echo ${UNAME_MACHINE}-pc-os2-emx exit ;; i*86:XTS-300:*:STOP) echo ${UNAME_MACHINE}-unknown-stop exit ;; i*86:atheos:*:*) echo ${UNAME_MACHINE}-unknown-atheos exit ;; i*86:syllable:*:*) echo ${UNAME_MACHINE}-pc-syllable exit ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) echo i386-unknown-lynxos${UNAME_RELEASE} exit ;; i*86:*DOS:*:*) echo ${UNAME_MACHINE}-pc-msdosdjgpp exit ;; i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} else echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} fi exit ;; i*86:*:5:[678]*) # UnixWare 7.x, OpenUNIX and OpenServer 6. case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ && UNAME_MACHINE=i586 (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ && UNAME_MACHINE=i686 (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ && UNAME_MACHINE=i686 echo ${UNAME_MACHINE}-pc-sco$UNAME_REL else echo ${UNAME_MACHINE}-pc-sysv32 fi exit ;; pc:*:*:*) # Left here for compatibility: # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i586. # Note: whatever this is, it MUST be the same as what config.sub # prints for the "djgpp" host, or else GDB configury will decide that # this is a cross-build. echo i586-pc-msdosdjgpp exit ;; Intel:Mach:3*:*) echo i386-pc-mach3 exit ;; paragon:*:*:*) echo i860-intel-osf1 exit ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 fi exit ;; mini*:CTIX:SYS*5:*) # "miniframe" echo m68010-convergent-sysv exit ;; mc68k:UNIX:SYSTEM5:3.51m) echo m68k-convergent-sysv exit ;; M680?0:D-NIX:5.3:*) echo m68k-diab-dnix exit ;; M68*:*:R3V[5678]*:*) test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4; exit; } ;; NCR*:*:4.2:* | MPRAS*:*:4.2:*) OS_REL='.3' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) echo m68k-unknown-lynxos${UNAME_RELEASE} exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit ;; TSUNAMI:LynxOS:2.*:*) echo sparc-unknown-lynxos${UNAME_RELEASE} exit ;; rs6000:LynxOS:2.*:*) echo rs6000-unknown-lynxos${UNAME_RELEASE} exit ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) echo powerpc-unknown-lynxos${UNAME_RELEASE} exit ;; SM[BE]S:UNIX_SV:*:*) echo mips-dde-sysv${UNAME_RELEASE} exit ;; RM*:ReliantUNIX-*:*:*) echo mips-sni-sysv4 exit ;; RM*:SINIX-*:*:*) echo mips-sni-sysv4 exit ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` echo ${UNAME_MACHINE}-sni-sysv4 else echo ns32k-sni-sysv fi exit ;; PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort # says echo i586-unisys-sysv4 exit ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm echo hppa1.1-stratus-sysv4 exit ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. echo i860-stratus-sysv4 exit ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. echo ${UNAME_MACHINE}-stratus-vos exit ;; *:VOS:*:*) # From Paul.Green@stratus.com. echo hppa1.1-stratus-vos exit ;; mc68*:A/UX:*:*) echo m68k-apple-aux${UNAME_RELEASE} exit ;; news*:NEWS-OS:6*:*) echo mips-sony-newsos6 exit ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else echo mips-unknown-sysv${UNAME_RELEASE} fi exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. echo powerpc-be-beos exit ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. echo powerpc-apple-beos exit ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. echo i586-pc-beos exit ;; BePC:Haiku:*:*) # Haiku running on Intel PC compatible. echo i586-pc-haiku exit ;; SX-4:SUPER-UX:*:*) echo sx4-nec-superux${UNAME_RELEASE} exit ;; SX-5:SUPER-UX:*:*) echo sx5-nec-superux${UNAME_RELEASE} exit ;; SX-6:SUPER-UX:*:*) echo sx6-nec-superux${UNAME_RELEASE} exit ;; SX-7:SUPER-UX:*:*) echo sx7-nec-superux${UNAME_RELEASE} exit ;; SX-8:SUPER-UX:*:*) echo sx8-nec-superux${UNAME_RELEASE} exit ;; SX-8R:SUPER-UX:*:*) echo sx8r-nec-superux${UNAME_RELEASE} exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit ;; *:Rhapsody:*:*) echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} exit ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown case $UNAME_PROCESSOR in i386) eval $set_cc_for_build if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then UNAME_PROCESSOR="x86_64" fi fi ;; unknown) UNAME_PROCESSOR=powerpc ;; esac echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = "x86"; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} exit ;; *:QNX:*:4*) echo i386-pc-qnx exit ;; NEO-?:NONSTOP_KERNEL:*:*) echo neo-tandem-nsk${UNAME_RELEASE} exit ;; NSE-?:NONSTOP_KERNEL:*:*) echo nse-tandem-nsk${UNAME_RELEASE} exit ;; NSR-?:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux exit ;; BS2000:POSIX*:*:*) echo bs2000-siemens-sysv exit ;; DS/*:UNIX_System_V:*:*) echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} exit ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. if test "$cputype" = "386"; then UNAME_MACHINE=i386 else UNAME_MACHINE="$cputype" fi echo ${UNAME_MACHINE}-unknown-plan9 exit ;; *:TOPS-10:*:*) echo pdp10-unknown-tops10 exit ;; *:TENEX:*:*) echo pdp10-unknown-tenex exit ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) echo pdp10-dec-tops20 exit ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) echo pdp10-xkl-tops20 exit ;; *:TOPS-20:*:*) echo pdp10-unknown-tops20 exit ;; *:ITS:*:*) echo pdp10-unknown-its exit ;; SEI:*:*:SEIUX) echo mips-sei-seiux${UNAME_RELEASE} exit ;; *:DragonFly:*:*) echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` case "${UNAME_MACHINE}" in A*) echo alpha-dec-vms ; exit ;; I*) echo ia64-dec-vms ; exit ;; V*) echo vax-dec-vms ; exit ;; esac ;; *:XENIX:*:SysV) echo i386-pc-xenix exit ;; i*86:skyos:*:*) echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' exit ;; i*86:rdos:*:*) echo ${UNAME_MACHINE}-pc-rdos exit ;; i*86:AROS:*:*) echo ${UNAME_MACHINE}-pc-aros exit ;; esac #echo '(No uname command or uname output not recognized.)' 1>&2 #echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 eval $set_cc_for_build cat >$dummy.c < # include #endif main () { #if defined (sony) #if defined (MIPSEB) /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, I don't know.... */ printf ("mips-sony-bsd\n"); exit (0); #else #include printf ("m68k-sony-newsos%s\n", #ifdef NEWSOS4 "4" #else "" #endif ); exit (0); #endif #endif #if defined (__arm) && defined (__acorn) && defined (__unix) printf ("arm-acorn-riscix\n"); exit (0); #endif #if defined (hp300) && !defined (hpux) printf ("m68k-hp-bsd\n"); exit (0); #endif #if defined (NeXT) #if !defined (__ARCHITECTURE__) #define __ARCHITECTURE__ "m68k" #endif int version; version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; if (version < 4) printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); else printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); exit (0); #endif #if defined (MULTIMAX) || defined (n16) #if defined (UMAXV) printf ("ns32k-encore-sysv\n"); exit (0); #else #if defined (CMU) printf ("ns32k-encore-mach\n"); exit (0); #else printf ("ns32k-encore-bsd\n"); exit (0); #endif #endif #endif #if defined (__386BSD__) printf ("i386-pc-bsd\n"); exit (0); #endif #if defined (sequent) #if defined (i386) printf ("i386-sequent-dynix\n"); exit (0); #endif #if defined (ns32000) printf ("ns32k-sequent-dynix\n"); exit (0); #endif #endif #if defined (_SEQUENT_) struct utsname un; uname(&un); if (strncmp(un.version, "V2", 2) == 0) { printf ("i386-sequent-ptx2\n"); exit (0); } if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ printf ("i386-sequent-ptx1\n"); exit (0); } printf ("i386-sequent-ptx\n"); exit (0); #endif #if defined (vax) # if !defined (ultrix) # include # if defined (BSD) # if BSD == 43 printf ("vax-dec-bsd4.3\n"); exit (0); # else # if BSD == 199006 printf ("vax-dec-bsd4.3reno\n"); exit (0); # else printf ("vax-dec-bsd\n"); exit (0); # endif # endif # else printf ("vax-dec-bsd\n"); exit (0); # endif # else printf ("vax-dec-ultrix\n"); exit (0); # endif #endif #if defined (alliant) && defined (i860) printf ("i860-alliant-bsd\n"); exit (0); #endif exit (1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } # Apollos put the system type in the environment. test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } # Convex versions that predate uname can use getsysinfo(1) if [ -x /usr/convex/getsysinfo ] then case `getsysinfo -f cpu_type` in c1*) echo c1-convex-bsd exit ;; c2*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; c34*) echo c34-convex-bsd exit ;; c38*) echo c38-convex-bsd exit ;; c4*) echo c4-convex-bsd exit ;; esac fi cat >&2 < in order to provide the needed information to handle your system. config.guess timestamp = $timestamp uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` /bin/uname -X = `(/bin/uname -X) 2>/dev/null` hostinfo = `(hostinfo) 2>/dev/null` /bin/universe = `(/bin/universe) 2>/dev/null` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` /bin/arch = `(/bin/arch) 2>/dev/null` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` UNAME_MACHINE = ${UNAME_MACHINE} UNAME_RELEASE = ${UNAME_RELEASE} UNAME_SYSTEM = ${UNAME_SYSTEM} UNAME_VERSION = ${UNAME_VERSION} EOF exit 1 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: algol68g-2.8/ChangeLog0000644000175000001440000000003411766475162011511 00000000000000Please refer to file "NEWS".algol68g-2.8/ISSUES0000644000175000001440000000100612160172630010654 00000000000000ALGOL68G - ALGOL 68 GENIE Next issues are yet unresolved. > Issue: a68g 2.6, Bus Error on SPARC > Filed: 2012-11-30 by Hannu-Heikki Puupponen > Status: unable to reproduce on non-SPARC machines, no access to SPARCs. > > Target machine is Sun SPARCStation 10 with two SM81 SuperSPARC II CPU > modules, 512M memory. OS is NetBSD 4.0. > > Some regression tests cause a Bus Error, typically caused by unaligned fetch, > SPARC being one of the architectures that do not support unaligned fetches at all.